基于VB的局域网远程控制CS结构 - 源码爱好者下载
您的当前位置：
基于VB的局域网远程控制CS结构
基于VB的局域网远程控制程序，CS结构（服务端和客户端），主要是利用 winsck 控件的 UDP 协议进行编写的。
　　功能有：
　　1)屏幕监控 2)键盘监控 3)鼠标控制 4)键盘控制
　　5)文件的批量上传、下载、简单的删除 6)文件的运行和查找
　　6)进程、窗口、程序的查看和结束
　　（注：进行键盘鼠标控制时，必须先打开监视窗口进行监视，然后双击监视窗口，弹出一个专门控制鼠标键盘的窗口，这时再点选）（鼠标、键盘控制的复选框，对着刚才打开的窗口移动鼠标、敲击键盘即可），目前软件较粗糙，不过关键功能基本都全了，我的目的是抛砖引玉，想让大家把我这个程序再美化，并增强功能我希望下面解决的问题是：
　　1）屏幕监控时能不能实时监控，而不是像现在的一段时间截一次屏传过来再显示，这样不流畅
　　2）能解决视频实时传送的问题
　　3）能解决键盘对中文软件的监控问题，就是说我目前只能对键盘的按键进行监控，但如果对方打开输入法我就不能监控到输入的汉字
　　4）能绕过大部分杀软件
　　5）对网页输入的监控，比如在某个输入框输入了什么，然后又到另一输入框输入什么
　　6）最后最想解决的是如何在外网使用我的这个程序，即通过互联网实施真正的远程控制
　　好了，目前就这么多，我的QQ是：，希望高手帮我（也是帮大家）解决如上的问题。
运行环境：Windows/VB6
相关标签：
软件大小：77.3K
软件属性：共享版 | 简体中文
软件评级：
收录更新： |
相关链接：暂无演示
软件截图：
下载地址：VB远程控制相关的问题_百度知道
VB远程控制相关的问题
如果3样全做到加50分？就像用drivelistbox我用VB的Winsock控件做了一个远程控制软件，最好在旁边注上解释？请位高手给出代码、dirlistbox和filelistbox三个控件查看本地计算机上的文件一样，可是应该如何获取远程计算机硬盘文件列表显示给我看呢，或者有什么更好的办法吗！做到两样加30分！请大家回答我问题啊？还有应该如何上传文件到远程计算机和下载远程计算机的文件呢
并把操作结果通过winsock推送给控制端，只能提供思路，也就是自己的命令系统！你想实现什么功能都行！你可以在服务器端定义一个解释器，然后收到相应指令做出相应的操作源代码肯定没有了
可以这样吗？在本地计算机输入命令行的命令，发送给远程计算机，然后远程计算机执行，把执行结果发回给本地计算机，这样行不？
可以阿！没问题的，自己定义命令系统了！
来自团队：
其他类似问题
为您推荐：
远程控制的相关知识
其他3条回答
50分?5000分未必能求到
代码比较多，方法如下：首先再远程端的服务器软件上放置drivelistbox、dirlistbox、filelistbox三个控件，使他们互相关联，然后把这三个控件获得的数据发回到你的客户端，你把这些数据分离并写到你本地的同样的这三个控件中，当你点击本地的相应控件时，把相应要查看的目录发给服务端，服务端即受到这个目录后就出发它那边的这三个控件使其列出新的内容，最后把这个新的目录内容发回给你本地的客户端，客户端又把这些内容再本地的这三个控件中列出来，就这样不断重复发送和接收，本人也写过远程控制软件，不过感觉效果不是很理想，容易断开，内网又连不了，没啥用的
能给出代码吗？还有可以这样吗？在本地计算机输入命令行的命令，发送给远程计算机，然后远程计算机执行，把执行结果发回给本地计算机，这样行不？
对的，就是在本地计算机发送一个列出远程目录的命令，接到命令后远程的服务端就触发那三个控件变更到你要查看的目录，再把他们的列表发送回来，客户端就受到以后又还原出来，这样就想操作本地电脑一样了
可是应该如何做到呢？怎么同步啊？代码应该怎么写？
FTP上传下载用INET做！MSDN里有源码
等待您来回答
下载知道APP
随时随地咨询
出门在外也不愁&&&&vb远程控制完整源码.
&vb远程控制完整源码.
星子行V2.0(源码)
好像是完全访灰鸽子的原码写的， 不过是VB版的，层次很清楚。。。
若举报审核通过，可奖励20下载分
被举报人：
举报的资源分：
请选择类型
资源无法下载
资源无法使用
标题与实际内容不符
含有危害国家安全内容
含有反动色情等内容
含广告内容
版权问题，侵犯个人或公司的版权
*详细原因：
您可能还需要
Q.为什么我点的下载下不了，但积分却被扣了
A. 由于下载人数众多，下载服务器做了并发的限制。若发现下载不了，请稍后再试，多次下载是不会重复扣分的。
Q.我的积分不多了，如何获取积分？
A. 获得积分，详细见。
完成任务获取积分。
论坛可用分兑换下载积分。
第一次绑定手机，将获得5个C币，C币可。
关注并绑定CSDNID，送10个下载分
下载资源意味着您已经同意遵守以下协议
资源的所有权益归上传用户所有
未经权益所有人同意，不得将资源中的内容挪作商业或盈利用途
CSDN下载频道仅提供交流平台，并不能对任何下载资源负责
下载资源中如有侵权或不适当内容，
本站不保证本站提供的资源的准确性，安全性和完整性，同时也不承担用户因使用这些下载资源对自己和他人造成任何形式的伤害或损失。
开发技术下载排行
积分不够下载该资源
如何快速获得积分？
你下载资源过于频繁，请输入验证码
如何快速获得积分？
你已经下载过该资源，再次下载不需要扣除积分
vb远程控制完整源码.
所需积分：5
剩余积分：0
扫描微信二维码精彩活动、课程更新抢先知
VIP会员，免积分下载
会员到期时间：日
剩余下载次数：1000
VIP服务公告:BS架构含服务端与客户端的VB远程控制工具 展示 ServerMod.bas源代码
- 下载整个 - 类型：.bas文件
Attribute VB_Name = &ServerMod&
'//////////////////////////////////////////////////////////
'// Module for Andromeda 1.0 Remote File Server for & & &//
'// Microsoft Win32 by Ryan and Andrew Lederman & & & & &//
'// /andromeda & & & & & & & & & & & //
'//////////////////////////////////////////////////////////
Declare Function TerminateProcess Lib &kernel32& (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib &kernel32& (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Const HKEY_LOCAL_MACHINE = &H
Declare Function ProcessFirst Lib &kernel32& Alias &Process32First& (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Public Declare Function ShellExecute Lib &shell32.dll& Alias &ShellExecuteA& (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare Function ProcessNext Lib &kernel32& Alias &Process32Next& (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Declare Function CreateToolhelpSnapshot Lib &kernel32& Alias &CreateToolhelp32Snapshot& (ByVal lFlags As Long, lProcessID As Long) As Long
Declare Function CloseHandle Lib &kernel32& (ByVal hObject As Long) As Long
Const MAX_PATH& = 260
Public sEnabled As Boolean
Type PROCESSENTRY32
& & dwSize As Long
& & cntUsage As Long
& & th32ProcessID As Long
& & th32DefaultHeapID As Long
& & th32ModuleID As Long
& & cntThreads As Long
& & th32ParentProcessID As Long
& & pcPriClassBase As Long
& & dwFlags As Long
& & szexeFile As String * MAX_PATH
& & End Type
Public Declare Function RegisterServiceProcess Lib &kernel32& (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Public Declare Function GetCurrentProcessId Lib &kernel32& () As Long
Public filesOpen As Integer
Public strBuffer As String
Public PacketCount As Integer
Public EngineRunning As Boolean
Public SendPort(1 To 100)
Public intMax2 As Integer
Public fileNum As Long
Public FileSize1 As Long
Public fileName As String
Public StartSending &As Boolean
Declare Function WritePrivateProfileString Lib &kernel32& Alias &WritePrivateProfileStringA& (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName As String) As Long
Declare Function GetPrivateProfileString Lib &kernel32& Alias &GetPrivateProfileStringA& (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Type NOTIFYICONDATA
& & cbSize As Long
& & hwnd As Long
& & uId As Long
& & uFlags As Long
& & uCallBackMessage As Long
& & hIcon As Long
& & szTip As String * 64
& & End Type
& & 'constants required by Shell_NotifyIcon API call:
& &Public Const NIM_ADD = &H0
& & Public Const NIM_MODIFY = &H1
& & Public Const NIM_DELETE = &H2
& & Public Const NIF_MESSAGE = &H1
& & Public Const NIF_ICON = &H2
& & Public Const NIF_TIP = &H4
& & Public Const WM_MOUSEMOVE = &H200
Public Declare Function SetForegroundWindow Lib &user32& (ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib &shell32& Alias &Shell_NotifyIconA& (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public nid As NOTIFYICONDATA
Declare Function RegCloseKey Lib &advapi32.dll& (ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib &advapi32.dll& Alias &RegCreateKeyExA& (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegQueryValue Lib &advapi32.dll& Alias &RegQueryValueA& (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Declare Function RegDeleteValue Lib &advapi32.dll& Alias &RegDeleteValueA& (ByVal hKey As Long, ByVal lpValueName As String) As Long
Declare Function RegQueryValueEx Lib &advapi32& Alias &RegQueryValueExA& _
& (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
& &ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Public Const REG_NONE = (0) & & & & & & & & & & & & 'No value type
Public Const REG_SZ = (1) & & & & & & & & & & & & & 'Unicode nul terminated string
Public Const REG_EXPAND_SZ = (2) & & & & & & & & & &'Unicode nul terminated string w/enviornment var
Public Const REG_BINARY = (3) & & & & & & & & & & & 'Free form binary
Public Const REG_DWORD = (4) & & & & & & & & & & & &'32-bit number
Public Const REG_DWORD_LITTLE_ENDIAN = (4) & & & & &'32-bit number (same as REG_DWORD)
Public Const REG_DWORD_BIG_ENDIAN = (5) & & & & & & '32-bit number
Public Const REG_LINK = (6) & & & & & & & & & & & & 'Symbolic Link (unicode)
Public Const REG_MULTI_SZ = (7) & & & & & & & & & & 'Multiple Unicode strings
Public Const REG_RESOURCE_LIST = (8) & & & & & & & &'Resource list in the resource map
Public Const REG_FULL_RESOURCE_DESCRIPTOR = (9) & & 'Resource list in the hardware description
Public Const REG_RESOURCE_REQUIREMENTS_LIST = (10)
Const READ_CONTROL = &H20000
Type SECURITY_ATTRIBUTES
& & & & nLength As Long
& & & & lpSecurityDescriptor As Long
& & & & bInheritHandle As Boolean
Type SECURITY_DESCRIPTOR
& & & & Revision As Byte
& & & & Sbz1 As Byte
& & & & Control As Long
& & & & Owner As Long
& & & & Group As Long
& & & & AclRevision As Byte
& & & & Sbz1 As Byte
& & & & AclSize As Integer
& & & & AceCount As Integer
& & & & Sbz2 As Integer
Declare Function RegReplaceKey Lib &advapi32.dll& Alias &RegReplaceKeyA& (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpNewFile As String, ByVal lpOldFile As String) As Long
Declare Function RegRestoreKey Lib &advapi32.dll& Alias &RegRestoreKeyA& (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Declare Function RegSaveKey Lib &advapi32.dll& Alias &RegSaveKeyA& (ByVal hKey As Long, ByVal lpFile As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Declare Function RegSetKeySecurity Lib &advapi32.dll& (ByVal hKey As Long, ByVal SecurityInformation As Long, pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long
Declare Function RegSetValue Lib &advapi32.dll& Alias &RegSetValueA& (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueEx Lib &advapi32& Alias &RegSetValueExA& _
& (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
& &ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
Declare Function RegUnLoadKey Lib &advapi32.dll& Alias &RegUnLoadKeyA& (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegOpenKeyEx Lib &advapi32.dll& Alias _
& & &RegOpenKeyExA& (ByVal hKey As Long, _
& & ByVal lpSubKey As String, ByVal ulOptions As Long, _
& & ByVal samDesired As Long, phkResult As Long) As Long
Function CreateFolder(xFolder As String, Winsock As Winsock)
& & 'Creates a new folder. if function fails
& &'returns False
& &On Error GoTo failCreate
& & MkDir xFolder
& & sOutput &MKDIR '& & xFolder & &' from IP '& & Winsock.RemoteHostIP & &'&
& & Winsock.SendData (&CREATED&)
& & Exit Function
failCreate:
& & Winsock.SendData (&NOTCREATED&)
End Function
Function DisplayLogFile(strWhichLog As String)
& & 'Opens the specified log file and displays to user
& &Dim WhichFile As String
& & With frmLog
& & Select Case strWhichLog
& & & & Case &Login&:
& & & & & & .Caption = &ndromeda - Log File (Logins)&
& & & & & & WhichFile = App.Path + &\Log.txt&
& & & & & &
& & & & Case &FileTransfer&:
& & & & & & .Caption = &ndromeda - Log File (File Transfers)&
& & & & & & WhichFile = App.Path + &\FTransfer.txt&
& & & & Case &Output&:
& & & & & & .Caption = &ndromeda - Log File (Server Output)&
& & & & & & WhichFile = App.Path + &\Output.txt&
& & End Select
& & If Exists(WhichFile) = False Then
& & & & MsgBox &The Log file: & & vbCrLf & WhichFile & vbCrLf & &was not found. Andromeda will now create a new, empty log.&, 16, &Error: File Not Found&
& & & & i = FreeFile
& & & & Open WhichFile For Output As #i
& & & & Close #i
& & End If
i = FreeFile
Open WhichFile For Input As #i
& & Do While Not EOF(i): DoEvents
& & Line Input #i, Record$
& & Entire = Entire + Record$ + vbCrLf
.txtLogin.Text = Entire
.lblFileSize.Caption = FileLen(WhichFile) & & bytes&
.WhichLog.Text = strWhichLog
.Show , frmMain
End Function
Sub EnableServer(WhichState As Boolean)
& & 'Takes a boolean, toggles server state depending on value passed
& &'True = Enabled, False = Disabled
& &Select Case WhichState
& & Case True:
& & & & &frmMain.Server(0).Close
& & & & frmMain.Server(0).LocalPort = 6969
& & & & &frmMain.Server(0).Listen
& & & & &Do While frmMain.Server(0).State && sckListening
& & & & & & DoEvents
& & & & & & If frmMain.Server(0).State = sckError Then
& & & & & & & & MsgBox &An error occurred while trying to initialize the listening socket.&, 16, &Error&: Exit Sub
& & & & & & End If
& & & & Loop
& & & & sEnabled = True
& & & & frmMain.TimerUptime.Enabled = True
& & & & frmMain.Caption = &ndromeda RFS (Enabled)&
& & & & sOutput &Server Enabled&
& & Case False:
& & & & frmMain.Server(0).Close
& & & & Do While frmMain.Server(0).State && sckClosed
& & & & & & DoEvents
& & & & Loop
& & & & sEnabled = False
& & & & frmMain.TimerUptime.Enabled = False
& & & & frmMain.txtElapsed.Caption = &00:00:00&
& & & & frmMain.Caption = &ndromeda RFS (Disabled)&
& & & & sOutput &Server Disabled&
& & End Select
Function InvalidMessage() As String
& & 'Reads the Invalid Message file (\imessage.txt)
& &'and returns the contents
& &Dim fileNum As Integer
& & fileNum = FreeFile
& & If Exists(App.Path + &\imessage.txt&) = False Then
& & & & Open App.Path + &\imessage.txt& For Output As #fileNum
& & & & Close #fileNum
& & & & InvalidMessage = &&
& & Exit Function
& & End If
& & Open App.Path + &\imessage.txt& For Input As #fileNum
& & & & Do While Not EOF(fileNum): DoEvents
& & & & Line Input #fileNum, Record$
& & & & Entire = Entire + Record$ + vbCrLf
& & & & Loop
& & Close #fileNum
& & InvalidMessage = Entire
End Function
Function IsValidSharedFolder(strFolder As String) As Boolean
& & 'Takes the path of a folder, and checks it against
& &'the shared folder list. If it is found, returns TRUE, otherwise
& &'returns FALSE
If Right(strFolder, 1) && &\& Then strFolder = strFolder + &\&
For X = 1 To frmSharedFolders.lstDirectories.ListItems.Count
& & Debug.Print frmSharedFolders.lstDirectories.ListItems(X).T strFolder
& & If UCase(frmSharedFolders.lstDirectories.ListItems(X).Text) = UCase(strFolder) Then
& & & & IsValidSharedFolder = True: Exit Function
& & End If
& & If UCase(Left(strFolder, Len(frmSharedFolders.lstDirectories.ListItems(X).Text))) = UCase(frmSharedFolders.lstDirectories.ListItems(X).Text) Then
& & & & IsValidSharedFolder = True: Exit Function
& & End If
& & IsValidSharedFolder = False
End Function
Sub Main()
& & 'Entry point for application... depending on settings
& &'will display either splash screen or main window
If GetSetting(&Andromeda&, &Settings&, &SplashScreen&, &1&) = &1& Then
& & frmSplash.Show
& & start = Timer
& & Do While Timer - start & 2.5: DoEvents: Loop
& & frmSplash.Hide
& & frmMain.Show
& & frmMain.Show
Function MoveFile(oldPath As String, newPath As String, Winsock As Winsock)
& & 'Moves a file to new folder.
& &'Sends &MOVED& to client when done, so that client may refresh file list
& &On Error GoTo ErrorHandle
& & Dim fSObj As FileSystemObject
& & Set fSObj = CreateObject(&Scripting.FileSystemObject&)
& & Call fSObj.MoveFile(oldPath, newPath) 'Move file
& & Call Winsock.SendData(&MOVED&)
& & sOutput &MOVE '& & oldPath & &' to '& & newPath & &' from IP '& & Winsock.RemoteHostIP & &'&
& & Exit Function
ErrorHandle:
& & Winsock.SendData &NOTMOVED&
& & sOutput &Error occurred in MoveFile: & & Err.Description & & #: & & Err.Number
End Function
Function MoveFolder(oldPath As String, newPath As String, Winsock As Winsock)
& & 'Moves a folder and it's contents to new folder.
& &'Sends &MOVED& to client when done, so that client may refresh file list
& &On Error GoTo ErrorHandle
& & Dim fSObj As FileSystemObject
& & Set fSObj = CreateObject(&Scripting.FileSystemObject&)
& & Dim BackSlash As Integer
& & BackSlash = FindReverse(oldPath, &\&)
& & oldPath = Left(oldPath, BackSlash - 1)
& & Call fSObj.MoveFolder(oldPath, newPath) 'Move folder
& & Call Winsock.SendData(&MOVED&)
& & sOutput &MOVE '& & oldPath & &' to '& & newPath & &' from IP '& & Winsock.RemoteHostIP & &'&
& & Exit Function
ErrorHandle:
& & Winsock.SendData &NOTMOVED&
& & sOutput &Error occurred in MoveFolder: & & Err.Description & & #: & & Err.Number
End Function
Function FindReverse(str As String, char As String) As Integer
& & 'The opposite of InStr(). This function
& &'will return the index of the specified character from the END
& &'of the string, instead of the beginning
& &ind = Len(str)
& & Do While ind && 1
& & & & ch = Mid(str, ind, Len(char))
& & & & If LCase(ch) = LCase(char) Then
& & & & & & FindReverse = ind
& & & & & & Exit Function
& & & & End If
& & & & ind = ind - 1
& & FindReverse = 0
End Function
Function SendDirectoryContents(Path As String, coll As Collection)
Dim objFso As New FileSystemObject
If Right(Path, 1) && &\& Then Path = Path + &\&
& & 'This adds the files inside 'Path' (if any)
& & & &mypath = Path
& & & & myName = Dir(mypath)
& & & & Do While myName && &&: DoEvents
& & & & & & If myName && &.& And myName && &..& Then
& & & & & & & & If (GetAttr(mypath & myName) And vbDirectory) = vbDirectory Then GoTo next1
& & & & & & & & coll.Add (mypath & myName)
& & & & & & & &
& & & & & & End If
& & & & & & myName = Dir
& & & & Loop
& & Dim objDir1 As Folder
& & Dim objDir2 As Folder
& & Set objDir1 = objFso.GetFolder(Path)
& & 'This part adds all the files inside subfolders
& &If objDir1.SubFolders.Count = 0 Then Exit Function
& & For Each objDir2 In objDir1.SubFolders
& & & & 'add all the files inside the subfolder
& & & &Call SendDirectoryContents(Path & objDir2.Name, coll)
& & Next objDir2
& & Set objDir1 = Nothing
& & Set objDir2 = Nothing
& & Set objFso = Nothing
End Function
Function ReadINI(AppName$, Keyname$, fileName$) As String
& &Dim RetStr As String
& &RetStr = String(255, Chr(0))
& &ReadINI = Left(RetStr, GetPrivateProfileString(AppName$, ByVal Keyname$, &&, RetStr, Len(RetStr), fileName$))
End Function
Function ReadEncryptedINI(xAppName As String, xSubitem As String, xPathToFile As String) As String
& &'Just like ReadINI, but instead, reads an encrypted entry
& 'in the INI, and decrypts it before returning the value
& 'Very handy :)
& ReadEncryptedINI = Decrypt(ReadINI(xAppName, xSubitem, xPathToFile))
End Function
Function SendProcessesToClient(Winsock As Winsock)
& & 'Creates a data packet that the client can
& &'translate into a list of processes running on this machine
Dim xData As String
KillApp &none&, frmMain.lstProcesses
For X = 0 To frmMain.lstProcesses.ListCount - 1
& & xData = xData & frmMain.lstProcesses.List(X) & &|&
xData = &PROCESSES-&& & xData
Winsock.SendData (xData)
sOutput &Sent processes list to IP '& & Winsock.RemoteHostIP & &' (& & Len(xData) & & Bytes)&
End Function
Function ListBox_To_String(xList As ListBox)
& & 'Takes a ListBox control as an argument
& &'loops through the list, and concatenates the items
& &'into a string separated by semicolons
On Error Resume Next
If xList.ListCount = 0 Then
& & sOutput &ListBox_To_String() Returned: No items to write. Cannot continue.&: Exit Function
For X = 0 To xList.ListCount - 1
& & Item = xList.List(X)
If X = 0 Then xData = xData & Item: GoTo aa
& & xData = xData & &;& & Item
& & DoEvents
& & ListBox_To_String = xData
End Function
Function StartProcess(xPath As String, Winsock As Winsock)
& & 'Will execute a program passed in xPath
& &On Error GoTo error_handle
& & If GetSetting(&Andromeda&, &Settings&, &AllowProcessToggle&, &0&) = &0& Then
& & & & Winsock.SendData (&ERROR: Process toggling not allowed.&)
& & & & Exit Function
& & End If
& & 'In case of malicious intent...
& &If InStr(UCase(xPath), &DELTREE&) && 0 Or InStr(UCase(xPath), &FDISK&) && 0 Or InStr(UCase(xPath), &FORMAT&) && 0 Then
& & & & 'Someone thinks it would be funny to ruin the computer...
& & & &Winsock.SendData (&ERROR: You must be stupid to attempt to run that program.&)
& & & & Exit Function
& & End If
& & 'Execute the process
& &Call Shell(xPath, vbNormalFocus)
& & Winsock.SendData (&STARTED=& & xPath)
& & sOutput &Started '& & xPath & &' from IP '& & Winsock.RemoteHostIP & &'&
& & Exit Function
error_handle:
& & Winsock.SendData (&ERROR: An error occurred while trying to spawn the process: & & xPath)
End Function
Function TerminateRunningProcess(xPath As String, Winsock As Winsock)
& & 'Will execute a program passed in xPath
& &If GetSetting(&Andromeda&, &Settings&, &AllowProcessToggle&) = &0& Then
& & & & Winsock.SendData (&ERROR: Process toggling not allowed.&)
& & & & Exit Function
& & End If
& & On Error GoTo err_handle
& & KillApp xPath, frmMain.lstProcesses
& & Winsock.SendData (&TERMINATED=& & xPath)
& & sOutput &Terminated'& & xPath & &' from IP '& & Winsock.RemoteHostIP & &'&
& & Exit Function
err_handle:
& & Winsock.SendData (&ERROR: Process not terminated.&)
& & sOutput &Error in TerminateRunningProcess: xPath = & & xPath
End Function
Function WriteINI(mizainz$, Place$, Toput$, AppName$)
& & r% = WritePrivateProfileString(mizainz$, Place$, Toput$, AppName$)
End Function
Function WriteEncryptedINI(xAppName As String, xSubitem As String, xOutput As String, xPathToFile As String)
& & xOutput = Encrypt(xOutput)
& & r% = WritePrivateProfileString(xAppName, xSubitem, xOutput, xPathToFile)
End Function
Function AppName() As String
&AppName = &ndromeda RFS &
End Function
Sub ModifyUser(xUser As String)
& & 'Displays a dynamically created 'frmModifyUser'
& &'and initializes it's fields to the properties for the
& &'specified user
& &If Exists(App.Path + &\& + xUser + &.alf&) = False Then MsgBox &User '& & xUser & &' does not exist.&, 16, &SERVER ERROR&: Exit Sub
& & Dim frmModifyUser2 As New frmModifyUser
& & With frmModifyUser2
& & & & .txtPassword = ReadEncryptedINI(&Andromeda&, &PW&, App.Path + &\& + xUser + &.alf&)
& & & & .frameUser.Caption = &User settings for: & & xUser
& & & & .Caption = &ndromeda - Settings for '& & xUser & &'&
& & & & .txtUser = xUser
& & & & .Show
& & End With
Public Function Exists(fizile As String) As Boolean
& & 'Checks for the existence of a file or folder.
& &'Returns a Boolean value (T or F)
& &On Error Resume Next
& & If Dir(fizile) = && Then
& & & & Exists = False
& & & & Exists = True
& & End If
End Function
Sub RemoveFromRegistry()
& & 'Deletes the key in HKEY_LOCAL_MACHINE\_
& &'Software\Microsoft\Windows\CurrentVersion\Run
& &'(This allows the application to be executed when
& &'windows is loaded
Dim RetVal As Long, hKey As Long, ValueName As String, _
& & & & SubKey As String, phkResult As Long, SA As SECURITY_ATTRIBUTES, _
& & & & Create As Long
& & hKey = HKEY_LOCAL_MACHINE
& & SubKey = &SOFTWARE\Microsoft\Windows\CurrentVersion\Run\&
& & RetVal = RegCreateKeyEx(hKey, SubKey, _
& & & & 0, &&, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
& & & & SA, phkResult, Create)
& & ValueName = &AndromedaRFS&
& & RetVal = RegDeleteValue(phkResult, ValueName)
& & RegCloseKey phkResult
Sub FileTransferAdd(xFileName As String, xFileSize As Long, xIPAddress As String, xStatus As String)
& & 'Adds an item to the 'File Transfer' list on the
& &'main window (frmMain). When files are transferred, either
& &'to or from the server, it is recorded here, and if the option
& &'is enabled for logging, it is written to the file transfer log
& &'(App.Path + &\FTransfer.txt&)
& &With frmMain.lstTransfer
& & & & Dim pinche As ListItem
& & & & Set pinche = .ListItems.Add(1, , xFileName)
& & & & pinche.SubItems(1) = xFileSize & & bytes&
& & & & pinche.SubItems(2) = xIPAddress
& & & & pinche.SubItems(3) = xStatus
& & End With
Function Encrypt(eString As String) As String
'Takes a string as an argument,
'and encrypts it. (Doubles the memory required for the string)
Dim nextChr As String
ff$ = &1?&
mm$ = &1%&
vv$ = &1?&
yy$ = &1?&
qte$ = &?&
tld$ = &'1&
tld2$ = &?&
exc$ = &g1&
ats$ = &?&
pnd$ = &?&
dol$ = &_0&
per$ = &?&
crt$ = &?&
amp$ = &?&
ast$ = &?&
opr$ = &?&
cpr$ = &0?&
dsh$ = &?&
und$ = &?&
pls$ = &?&
eqs$ = &?&
obc$ = &?&
cbc$ = &?&
obr$ = &0?&
cbr$ = &?&
dsl$ = &1?&
fsl$ = &0?&
cln$ = &?&
scl$ = &?&
fqt$ = &?&
apy$ = &?&
lsn$ = &?&
cma$ = &?&
grn$ = &i1&
prd$ = &?&
qes$ = &1?&
bsl$ = &m0&
spa$ = &w1&
zer$ = &0?&
one$ = &?&
two$ = &60&
thr$ = &?&
fou$ = &?&
fiv$ = &1p&
six$ = &?&
sev$ = &1?&
eig$ = &0?&
nin$ = &h&&
Let inptxt$ = eString
Let lenth% = Len(inptxt$)
Do While NumSpc% &= lenth%
Let NumSpc% = NumSpc% + 1
Let nextChr$ = Mid$(inptxt$, NumSpc%, 1)
If nextChr$ = &A& Then Let nextChr$ = aa$
If nextChr$ = &a& Then Let nextChr$ = a$
If nextChr$ = &B& Then Let nextChr$ = bb$
If nextChr$ = &b& Then Let nextChr$ = b$
If nextChr$ = &C& Then Let nextChr$ = cc$
If nextChr$ = &c& Then Let nextChr$ = C$
If nextChr$ = &D& Then Let nextChr$ = dd$
If nextChr$ = &d& Then Let nextChr$ = d$
If nextChr$ = &E& Then Let nextChr$ = ee$
If nextChr$ = &e& Then Let nextChr$ = e$
If nextChr$ = &f& Then Let nextChr$ = f$
If nextChr$ = &F& Then Let nextChr$ = ff$
If nextChr$ = &G& Then Let nextChr$ = gg$
If nextChr$ = &g& Then Let nextChr$ = g$
If nextChr$ = &H& Then Let nextChr$ = hh$
If nextChr$ = &h& Then Let nextChr$ = h$
If nextChr$ = &I& Then Let nextChr$ = ii$
If nextChr$ = &i& Then Let nextChr$ = i$
If nextChr$ = &J& Then Let nextChr$ = jj$
If nextChr$ = &j& Then Let nextChr$ = j$
If nextChr$ = &k& Then Let nextChr$ = k$
If nextChr$ = &K& Then Let nextChr$ = KK$
If nextChr$ = &L& Then Let nextChr$ = ll$
If nextChr$ = &l& Then Let nextChr$ = l$
If nextChr$ = &M& Then Let nextChr$ = mm$
If nextChr$ = &m& Then Let nextChr$ = m$
If nextChr$ = &N& Then Let nextChr$ = nn$
If nextChr$ = &n& Then Let nextChr$ = n$
If nextChr$ = &O& Then Let nextChr$ = oo$
If nextChr$ = &o& Then Let nextChr$ = o$
If nextChr$ = &P& Then Let nextChr$ = pp$
If nextChr$ = &p& Then Let nextChr$ = p$
If nextChr$ = &Q& Then Let nextChr$ = qq$
If nextChr$ = &q& Then Let nextChr$ = q$
If nextChr$ = &r& Then Let nextChr$ = r1$
If nextChr$ = &R& Then Let nextChr$ = rr$
If nextChr$ = &S& Then Let nextChr$ = ss$
If nextChr$ = &s& Then Let nextChr$ = s$
If nextChr$ = &t& Then Let nextChr$ = t$
If nextChr$ = &T& Then Let nextChr$ = tt$
If nextChr$ = &U& Then Let nextChr$ = uu$
If nextChr$ = &u& Then Let nextChr$ = u$
If nextChr$ = &V& Then Let nextChr$ = vv$
If nextChr$ = &v& Then Let nextChr$ = V$
If nextChr$ = &W& Then Let nextChr$ = ww$
If nextChr$ = &w& Then Let nextChr$ = w$
If nextChr$ = &X& Then Let nextChr$ = xx$
If nextChr$ = &x& Then Let nextChr$ = X$
If nextChr$ = &Y& Then Let nextChr$ = yy$
If nextChr$ = &y& Then Let nextChr$ = Y$
If nextChr$ = &Z& Then Let nextChr$ = zz$
If nextChr$ = &z& Then Let nextChr$ = z$
If nextChr$ = &1& Then Let nextChr$ = one$
If nextChr$ = &2& Then Let nextChr$ = two$
If nextChr$ = &3& Then Let nextChr$ = thr$
If nextChr$ = &4& Then Let nextChr$ = fou$
If nextChr$ = &5& Then Let nextChr$ = fiv$
If nextChr$ = &6& Then Let nextChr$ = six$
If nextChr$ = &7& Then Let nextChr$ = sev$
If nextChr$ = &8& Then Let nextChr$ = eig$
If nextChr$ = &9& Then Let nextChr$ = nin$
If nextChr$ = &0& Then Let nextChr$ = zer$
If nextChr$ = &~& Then Let nextChr$ = tld$
If nextChr$ = &`& Then Let nextChr$ = tld2$
If nextChr$ = &!& Then Let nextChr$ = exc$
If nextChr$ = &@& Then Let nextChr$ = ats$
If nextChr$ = &#& Then Let nextChr$ = pnd$
If nextChr$ = &$& Then Let nextChr$ = dol$
If nextChr$ = &%& Then Let nextChr$ = per$
If nextChr$ = &^& Then Let nextChr$ = crt$
If nextChr$ = &&& Then Let nextChr$ = amp$
If nextChr$ = &*& Then Let nextChr$ = ast$
If nextChr$ = &(& Then Let nextChr$ = opr$
If nextChr$ = &)& Then Let nextChr$ = cpr$
If nextChr$ = &-& Then Let nextChr$ = dsh$
If nextChr$ = &_& Then Let nextChr$ = und$
If nextChr$ = &+& Then Let nextChr$ = pls$
If nextChr$ = &=& Then Let nextChr$ = eqs$
If nextChr$ = &{& Then Let nextChr$ = obc$
If nextChr$ = &}& Then Let nextChr$ = cbc$
If nextChr$ = &[& Then Let nextChr$ = obr$
If nextChr$ = &]& Then Let nextChr$ = cbr$
If nextChr$ = &|& Then Let nextChr$ = dsl$
If nextChr$ = &\& Then Let nextChr$ = fsl$
If nextChr$ = &:& Then Let nextChr$ = cln$
If nextChr$ = &;& Then Let nextChr$ = scl$
If nextChr$ = Chr$(34) Then Let nextChr$ = qte$
If nextChr$ = &'& Then Let nextChr$ = apy$
If nextChr$ = &&& Then Let nextChr$ = lsn$
If nextChr$ = &,& Then Let nextChr$ = cma$
If nextChr$ = &&& Then Let nextChr$ = grn$
If nextChr$ = &.& Then Let nextChr$ = prd$
If nextChr$ = &?& Then Let nextChr$ = qes$
If nextChr$ = &/& Then Let nextChr$ = bsl$
If nextChr$ = & & Then Let nextChr$ = spa$
Let Newsent$ = Newsent$ + nextChr$
If crapp% & 0 Then Let crapp% = crapp% - 1
Encrypt = Newsent$
End Function
Function Decrypt(dString) As String
'Takes an encrypted string (encrypted by our Encrypt() function)
'and decrypts it to normal text. See also: Read and WriteEncryptedINI()
ff$ = &1?&
mm$ = &1%&
vv$ = &1?&
yy$ = &1?&
qte$ = &?&
tld$ = &'1&
tld2$ = &?&
exc$ = &g1&
ats$ = &?&
pnd$ = &?&
dol$ = &_0&
per$ = &?&
crt$ = &?&
amp$ = &?&
ast$ = &?&
opr$ = &?&
cpr$ = &0?&
dsh$ = &?&
und$ = &?&
pls$ = &?&
eqs$ = &?&
obc$ = &?&
cbc$ = &?&
obr$ = &0?&
cbr$ = &?&
dsl$ = &1?&
fsl$ = &0?&
cln$ = &?&
scl$ = &?&
fqt$ = &?&
apy$ = &?&
lsn$ = &?&
cma$ = &?&
grn$ = &i1&
prd$ = &?&
qes$ = &1?&
bsl$ = &m0&
spa$ = &w1&
zer$ = &0?&
one$ = &?&
two$ = &60&
thr$ = &?&
fou$ = &?&
fiv$ = &1p&
six$ = &?&
sev$ = &1?&
eig$ = &0?&
nin$ = &h&&
Let lenth% = Len(dString)
Let NumSpc% = 1
Do While NumSpc% &= lenth% - 1
Let nextChr$ = Mid$(dString, NumSpc%, 2)
Let NumSpc% = NumSpc% + 2
If nextChr$ = aa$ Then Let nextChr$ = &A&
If nextChr$ = a$ Then Let nextChr$ = &a&
If nextChr$ = bb$ Then Let nextChr$ = &B&
If nextChr$ = b$ Then Let nextChr$ = &b&
If nextChr$ = cc$ Then Let nextChr$ = &C&
If nextChr$ = C$ Then Let nextChr$ = &c&
If nextChr$ = dd$ Then Let nextChr$ = &D&
If nextChr$ = d$ Then Let nextChr$ = &d&
If nextChr$ = ee$ Then Let nextChr$ = &E&
If nextChr$ = e$ Then Let nextChr$ = &e&
If nextChr$ = f$ Then Let nextChr$ = &f&
If nextChr$ = ff$ Then Let nextChr$ = &F&
If nextChr$ = gg$ Then Let nextChr$ = &G&
If nextChr$ = g$ Then Let nextChr$ = &g&
If nextChr$ = hh$ Then Let nextChr$ = &H&
If nextChr$ = h$ Then Let nextChr$ = &h&
If nextChr$ = ii$ Then Let nextChr$ = &I&
If nextChr$ = i$ Then Let nextChr$ = &i&
If nextChr$ = j$ Then Let nextChr$ = &j&
If nextChr$ = jj$ Then Let nextChr$ = &J&
If nextChr$ = k$ Then Let nextChr$ = &k&
If nextChr$ = KK$ Then Let nextChr$ = &K&
If nextChr$ = ll$ Then Let nextChr$ = &L&
If nextChr$ = l$ Then Let nextChr$ = &l&
If nextChr$ = mm$ Then Let nextChr$ = &M&
If nextChr$ = m$ Then Let nextChr$ = &m&
If nextChr$ = nn$ Then Let nextChr$ = &N&
If nextChr$ = n$ Then Let nextChr$ = &n&
If nextChr$ = oo$ Then Let nextChr$ = &O&
If nextChr$ = o$ Then Let nextChr$ = &o&
If nextChr$ = pp$ Then Let nextChr$ = &P&
If nextChr$ = p$ Then Let nextChr$ = &p&
If nextChr$ = qq$ Then Let nextChr$ = &Q&
If nextChr$ = q$ Then Let nextChr$ = &q&
If nextChr$ = r1$ Then Let nextChr$ = &r&
If nextChr$ = rr$ Then Let nextChr$ = &R&
If nextChr$ = ss$ Then Let nextChr$ = &S&
If nextChr$ = s$ Then Let nextChr$ = &s&
If nextChr$ = t$ Then Let nextChr$ = &t&
If nextChr$ = tt$ Then Let nextChr$ = &T&
If nextChr$ = uu$ Then Let nextChr$ = &U&
If nextChr$ = u$ Then Let nextChr$ = &u&
If nextChr$ = vv$ Then Let nextChr$ = &V&
If nextChr$ = V$ Then Let nextChr$ = &v&
If nextChr$ = ww$ Then Let nextChr$ = &W&
If nextChr$ = w$ Then Let nextChr$ = &w&
If nextChr$ = xx$ Then Let nextChr$ = &X&
If nextChr$ = X$ Then Let nextChr$ = &x&
If nextChr$ = yy$ Then Let nextChr$ = &Y&
If nextChr$ = Y$ Then Let nextChr$ = &y&
If nextChr$ = zz$ Then Let nextChr$ = &Z&
If nextChr$ = z$ Then Let nextChr$ = &z&
If nextChr$ = qte$ Then Let nextChr$ = Chr$(34)
If nextChr$ = one$ Then Let nextChr$ = &1&
If nextChr$ = two$ Then Let nextChr$ = &2&
If nextChr$ = thr$ Then Let nextChr$ = &3&
If nextChr$ = fou$ Then Let nextChr$ = &4&
If nextChr$ = fiv$ Then Let nextChr$ = &5&
If nextChr$ = six$ Then Let nextChr$ = &6&
If nextChr$ = sev$ Then Let nextChr$ = &7&
If nextChr$ = eig$ Then Let nextChr$ = &8&
If nextChr$ = nin$ Then Let nextChr$ = &9&
If nextChr$ = zer$ Then Let nextChr$ = &0&
If nextChr$ = tld$ Then Let nextChr$ = &~&
If nextChr$ = tld2$ Then Let nextChr$ = &`&
If nextChr$ = exc$ Then Let nextChr$ = &!&
If nextChr$ = ats$ Then Let nextChr$ = &@&
If nextChr$ = pnd$ Then Let nextChr$ = &#&
If nextChr$ = dol$ Then Let nextChr$ = &$&
If nextChr$ = per$ Then Let nextChr$ = &%&
If nextChr$ = crt$ Then Let nextChr$ = &^&
If nextChr$ = amp$ Then Let nextChr$ = &&&
If nextChr$ = ast$ Then Let nextChr$ = &*&
If nextChr$ = opr$ Then Let nextChr$ = &(&
If nextChr$ = cpr$ Then Let nextChr$ = &)&
If nextChr$ = dsh$ Then Let nextChr$ = &-&
If nextChr$ = und$ Then Let nextChr$ = &_&
If nextChr$ = pls$ Then Let nextChr$ = &+&
If nextChr$ = eqs$ Then Let nextChr$ = &=&
If nextChr$ = obc$ Then Let nextChr$ = &{&
If nextChr$ = cbc$ Then Let nextChr$ = &}&
If nextChr$ = obr$ Then Let nextChr$ = &[&
If nextChr$ = cbr$ Then Let nextChr$ = &]&
If nextChr$ = dsl$ Then Let nextChr$ = &|&
If nextChr$ = fsl$ Then Let nextChr$ = &\&
If nextChr$ = cln$ Then Let nextChr$ = &:&
If nextChr$ = scl$ Then Let nextChr$ = &;&
If nextChr$ = apy$ Then Let nextChr$ = &'&
If nextChr$ = lsn$ Then Let nextChr$ = &&&
If nextChr$ = cma$ Then Let nextChr$ = &,&
If nextChr$ = grn$ Then Let nextChr$ = &&&
If nextChr$ = prd$ Then Let nextChr$ = &.&
If nextChr$ = qes$ Then Let nextChr$ = &?&
If nextChr$ = bsl$ Then Let nextChr$ = &/&
If nextChr$ = spa$ Then Let nextChr$ = & &
Let Newsent$ = Newsent$ + nextChr$
Decrypt = Newsent$
End Function
Function FindPort() As Long
& & 'Uses a randomized seed to create an open data port
& &Randomize
& & FindPort = Int((10000 - 1000) * Rnd + 1000)
End Function
Function RenameFile(xPath As String, xNewName As String) As Boolean
& & 'Renames a disk file
& &If Exists(xPath) = False Then RenameFile = False: Exit Function
& & Dim Fiz As File
& & Dim fizile As FileSystemObject
& & Set fizile = CreateObject(&Scripting.FileSystemObject&)
& & Set Fiz = fizile.GetFile(xPath)
& & Fiz.Name = xNewName
& & RenameFile = True
& & Set Fiz = Nothing
& & Set fizile = Nothing
End Function
Function RenameFolder(xPath As String, xNewName As String) As Boolean
& & 'Renames a folder
& & Dim Fld As Folder
& & Dim fizile As FileSystemObject
& & Set fizile = CreateObject(&Scripting.FileSystemObject&)
& & If fizile.FolderExists(xPath) = False Then RenameFolder = False: Exit Function
& & Set Fld = fizile.GetFolder(xPath)
& & Fld.Name = xNewName
& & RenameFolder = True
& & Set Fld = Nothing
& & Set fizile = Nothing
End Function
Sub TimeOut(HowLong)
'Halts program execution for a specified time (in seconds)
TheBeginning = Timer
Do While Timer - TheBeginning & HowLong
& & X = DoEvents()
Public Function KillApp(myName As String, List As ListBox) As Boolean
& & 'If called with &none&, this function will clear frmMain.lstProcesses,
& &'and then query the Windows OS for running processes, then add them
& &'into the list. If called with a valid running executable's path (example: C:\MyProgram\Myprogram.exe)
& &'it will terminate that process.
& &Const PROCESS_ALL_ACCESS = 0
& & Dim uProcess As PROCESSENTRY32
& & Dim rProcessFound As Long
& & Dim hSnapshot As Long
& & Dim szExename As String
& & Dim exitCode As Long
& & Dim myProcess As Long
& & Dim AppKill As Boolean
& & Dim appCount As Integer
& & Dim i As Integer
& & On Local Error GoTo Finish
& & appCount = 0
& & Const TH32CS_SNAPPROCESS As Long = 2&
& & uProcess.dwSize = Len(uProcess)
& & hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
& & rProcessFound = ProcessFirst(hSnapshot, uProcess)
& & List.Clear
& & Do While rProcessFound
& & & & DoEvents
& & & & i = InStr(1, uProcess.szexeFile, Chr(0))
& & & & szExename = LCase$(Left$(uProcess.szexeFile, i - 1))
& & & & List.AddItem (szExename)
& & & & If Right$(szExename, Len(myName)) = LCase$(myName) Then
& & & & & & KillApp = True
& & & & & & appCount = appCount + 1
& & & & & & myProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
& & & & & & AppKill = TerminateProcess(myProcess, exitCode)
& & & & & & Call CloseHandle(myProcess)
& & & & End If
& & & & DoEvents
& & & & rProcessFound = ProcessNext(hSnapshot, uProcess)
& & Call CloseHandle(hSnapshot)
End Function
Function DeleteFiles(xFiles As String, IPAddress As String) As Boolean
& & 'Deletes files passed in xFiles... ('file1|file2|file3|')
& &'Returns Boolean (True for success, False otherwise)
On Error GoTo ErrorHandle
Dim dDir As File
Dim dObj As FileSystemObject
Set dObj = CreateObject(&Scripting.FileSystemObject&)
If Not Mid(xFiles, Len(xFiles), 1) = &|& Then
& & xFiles = xFiles & &|&
For DoList = 1 To Len(xFiles)
& & thechars$ = thechars$ & Mid(xFiles, DoList, 1)
& & fileName = Mid(thechars$, 1, Len(thechars$) - 1)
& & If Mid(xFiles, DoList, 1) = &|& Then
& & & & If (GetAttr(fileName) And vbDirectory) = vbDirectory Then 'It's a dir, so we have to strip the .d
& & & & & & &
& & & & & & & & RmDir (fileName)
& & & & & & & & DeleteFiles = True
& & & & & & & & sOutput &DELETE '& & fileName & &' from IP '& & IPAddress & &'&
& & & & & & & & thechars$ = &&
& & & & Else
& & & & Kill fileName
& & & & sOutput &DELETE '& & fileName & &' from IP '& & IPAddress & &'&
& & & & thechars$ = &&
& & & & End If
& & End If
Next DoList
DeleteFiles = True
Exit Function
ErrorHandle:
sOutput &Error occurred in DeleteFiles(): & & Err.Description & & #: & & Err.Number
DeleteFiles = False
End Function
Sub SendFileToClient(xFileName As String, IPAddy As String, whichWinsock As Winsock)
'Opens a disk file using Binary Access Read, reads a specified block of data
'(size is governed by BufferSize (default 2048))
'after reading block of data, sends it to the remote machine
'via the Winsock control passed as the third argument (WhichWinsock)
On Error GoTo errorhandler
Dim Buffer As String
Dim BufferSize As Integer
Dim Fiz As File
Dim pinche As ListItem
Dim FizObj As Scripting.FileSystemObject
Dim fileLength As Long, SuperBuffer As Long
Dim PercentDone As Long, b As Integer
& & BufferSize = 2048
& & & & & &
& & & & &Do While whichWinsock.State && 7: DoEvents
& & & & &If whichWinsock.State = sckError Then
& & & & &sOutput &Winsock Error:& & vbCrLf & Err.Description: Exit Sub
& & & & &End If
& & & & &Loop
& & & & &StartSending = False
& & & & &whichWinsock.SendData &FILESIZE=& & FileLen(xFileName)
& & & & &Do While StartSending && True: DoEvents: Loop
& & i = FreeFile 'Find free file
& & Set FizObj = CreateObject(&Scripting.FileSystemObject&)
& & Set Fiz = FizObj.GetFile(xFileName)
& & Set pinche = frmMain.lstTransfer.ListItems.Add(1, , Fiz.ParentFolder + &\& + Fiz.Name)
& & & & pinche.SubItems(1) = Fiz.Size & & bytes&
& & & & pinche.SubItems(2) = IPAddy
& & Open xFileName For Binary Access Read As #i
& & & & fileLength = LOF(i)
& & & & Do While Not EOF(i): DoEvents
& & & & & & If fileLength - Loc(i) & BufferSize Then
& & & & & & & & Let BufferSize = fileLength - Loc(i)
& & & & & & & & If BufferSize = 0 Then GoTo done
& & & & & & End If
& & & & & &
& & & & & & Buffer = Space(BufferSize)
& & & & If Loc(i) = 0 Then GoTo skipPercent 'Don't want division by zero
& & & & PercentDone = Loc(i) / fileLength * 100
& & & & If b & 30 Then: b = b + 1: GoTo skipPercent
& & & & pinche.SubItems(3) = PercentDone & &%&
& & & & b = 0
skipPercent:
& & & & Get #i, , Buffer
& & & & whichWinsock.SendData Buffer
& & & & SuperBuffer = SuperBuffer + Len(Buffer)
& & & & Loop
& & Close #i
& & & & StartSending = False
& & & & pinche.SubItems(3) = &Complete.&
& & & & sOutput &SENT-& & & xFileName & & (& & SuperBuffer & & bytes) to [& & IPAddy & &]&
& & & & If GetSetting(&Andromeda&, &Settings&, &WriteTransferLog&) = &1& Then
& & & & & & WriteLog App.Path + &\FTransfer.txt&, &Sent '& & xFileName & &' (& & SuperBuffer & & bytes) to IP '& & IPAddy & &' Time/Date=& & Format(Now, &HH:MM:SS AM/PM - MM/DD/YYYY&)
& & & & End If
& & & & Exit Sub
errorhandler:
Call sOutput(&Error in SendFileToClient: & & Err.Description & &Number: & & Err.Number)
Sub LoadExistingUserInformation()
& & Dim firsthtml As String
& & With frmManageUsers
& & & & Path$ = App.Path + &\*.alf&
& & & & firsthtml = Dir(Path$)
& & & & If firsthtml = && Then
& & & & & & MsgBox &No User files could be found to search through.&, 16, &Files Not Found&: btnCancel.Enabled = False: &Exit Sub
& & & & End If
& & & & .lstbuffer.Clear
& & Do While firsthtml && &&
& & & & DoEvents
& & & & .lstbuffer.AddItem (firsthtml)
& & & & firsthtml = Dir
& & & & .ListView1.ListItems.Clear
& & For X = 0 To .lstbuffer.ListCount - 1
& & & & username = ReadEncryptedINI(&Andromeda&, &UserName&, App.Path + &\& + .lstbuffer.List(X))
& & & & Pw = ReadEncryptedINI(&Andromeda&, &PW&, App.Path + &\& + .lstbuffer.List(X))
& & & & lastlogin = ReadEncryptedINI(&Andromeda&, &LastLogin&, App.Path + &\& + .lstbuffer.List(X))
Dim itm As ListItem
& & & & Pw = &''& & Pw & &''&
& & & & If lastlogin = && Then lastlogin = &Never.&
If username = && Then GoTo izend
Set itm = .ListView1.ListItems.Add(, , username)
& & itm.SubItems(1) = Pw
& & itm.SubItems(2) = lastlogin
& & DoEvents
& & Next X
& & End With
Sub LoadSharedDirectories()
& & 'Opens the Shared Directories config file (\SD.DLL)
& &'and adds the shared folders to frmSharedFolders.lstDirectories
& &Dim Jig As ListItem
& & With frmSharedFolders
& & i = FreeFile
& & If Exists(App.Path + &\SD.DLL&) = False Then
& & & & MsgBox &No shared directory information could be located. You need to add shared directories.&, 16, &Error: No Shared Directory Information&: Exit Sub
& & End If
& & & & Open App.Path + &\SD.DLL& For Input As #i
& & & & & & Do While Not EOF(i): DoEvents
& & & & & &
& & & & & & Line Input #i, shmoo$
& & & & & &
& & & & & & Set Jig = .lstDirectories.ListItems.Add(, , shmoo$, , 1)
& & & & & &
& & & & & & Loop
& & & & Close #i
& & End With
&Sub WriteRegistry(hKey As Long, SubKey As String, _
& & ValueName As String, vNewValue As String)
& & Dim phkResult As Long, RetVal As Long
& & 'Writes a key in the registry under the HKEY passed in first argument
& &RetVal = RegOpenKeyEx(hKey, SubKey, 0, KEY_ALL_ACCESS, phkResult)
& & RetVal = RegSetValueEx(phkResult, ValueName, 0, REG_SZ, vNewValue, _
& & & & & CLng(Len(vNewValue) + 1))
& & 'Close the keys
& &RegCloseKey hKey
& & RegCloseKey phkResult
Sub SaveSharedDirectories()
& & 'Saves the list of shared directories for the server
& &i = FreeFile
& & Open App.Path + &\SD.DLL& For Output As #i
& & & & For X = 1 To frmSharedFolders.lstDirectories.ListItems.Count
& & & & Print #i, frmSharedFolders.lstDirectories.ListItems(X).Text
& & & & DoEvents
& & & & Next X
& & Close #i
Function DirectoryToString(xPath As String) As String
& & 'Takes the path to a folder as an argument,
& &'and returns a string that the client can translate
& &'into a list of files and subdirectories
On Error GoTo ErrorHandle
& & Dim FirstFile, xPath2 As String
& & Dim fizile As File
& & Dim ReturnValue As String
& & Dim FizileObject As Scripting.FileSystemObject
& & Set FizileObject = CreateObject(&Scripting.FileSystemObject&)
'----------------------------------- Directories
& &mypath = xPath
& & If mypath = &C:\& Then myName = Dir(mypath, vbDirectory): GoTo skip1
& & myName = Dir(xPath, vbDirectory)
& & Do While myName && &&
& &If InStr(mypath, myName) = 0 Then
& &If myName && &.& And myName && &..& Then
& & & If (GetAttr(mypath & myName) And vbDirectory) = vbDirectory Then
& & & & &ReturnValue = ReturnValue & myName & &.d|&
& & & End If
& &myName = Dir
'------------------------------------ Files
& &xPath2 = xPath & &*.*&
& & If xPath = &C:\& Then xPath2 = xPath
& & FirstFile = Dir$(xPath2)
Do While FirstFile && &&: DoEvents
& & Set fizile = FizileObject.GetFile(xPath + FirstFile)
& & ReturnValue = ReturnValue & fizile.Name & &:& & fizile.Size & &|&
& & FirstFile = Dir
& & DirectoryToString = ReturnValue
Exit Function
ErrorHandle:
sOutput &Error occurred in DirectoryToString(): & & Err.Description & & #: & & Err.Number
End Function
Sub sOutput(xOutput As String)
& & 'Displays output in the Server Output list on frmMain
& &'Called to alert user to activity
& &Dim Dta As String, LITM As ListItem
& & Set LITM = frmMain.lstOutput.ListItems.Add(1, , xOutput)
& & & & LITM.SubItems(1) = Format(Now, &HH:MM:SS AM/PM - MM/DD/YYYY&)
& & Call WriteLog(App.Path + &\Output.txt&, xOutput & & : & & Format(Now, &HH:MM:SS AM/PM - MM/DD/YYYY&))
Sub WriteLog(strPath As String, strLine As String)
& & 'Writes data (strLine) to a specified file (strPath)
& &'*Only appends to the end of the file, does not erase any
& &'existing data in the file*
& &If Exists(strPath) = False Then
& & & & i = FreeFile
& & & & Open strPath For Output As #i
& & & & Close #i
& & End If
& & Dim fileNum As Integer
& & fileNum = FreeFile
& & Open strPath For Append As #fileNum
& & & & Print #fileNum, strLine$ '&- for some reason, if you dont include the '$' char, it adds quotes to the line written... weird
& & Close #fileNum
- 下载整个
相关源码/软件：
- VB版神经网络——BP神经网络实验平台：输出幅值可调ATN激励函数，一个很绝的算法，以前在论坛上讨论...
- VB做的QQ工具，包括有模拟QQ截屏、QQ在线查询，CF点亮等，本程序需联网才能用，当显示图像里出现...
- 标准Dll生成程序VB版源代码，注意：在过程的右边必须 注释上 ‘ 输出函数
否则link.e...
- VB做的小型相册，实际上是一个图片浏览程序，打开时显示缩略图，鼠标点击显示大图片，并可接着浏览下去，...
- Vb打印预览程序，带放大、缩小功能，简单实用的程序，希望大家喜欢，编译顺利。
- VB控件版透明万年历程序，类似于桌面日历，在屏幕上显示半透明的效果，可显示农历、世界节日、公历、星期...
- 一款IE辅助的下载插件，运行安装程序后即可将本功能添加至IE。当然，源代码完全可以再次开发、修改和再...
- 用VB语言编写的QQ右下角弹出新闻功能，程序会自动检测QQ是否允许弹出，如果不允许则本程序不会弹出！...
- Vb生成带小数位的随机数示例程序，每点一次生成一组随机数，如上图所示。
- 基于Winsock技术的VB高速网络扫描器，源程序来自国外源代码网站，完整无错，可快速扫描指定网络I...
- 本程序自带反向回传语音代理服务，可以使两个不同局域网内的客户机通过国际互连网进行语音通讯，本程序使用...
- 关窗子游戏规则：开启或关闭一扇窗子，其自身和其上下左右的窗子的状态都要发生改变&&nbsp...
- delphi7(用到了delphi&devexpress第三方控件)+sqlserver2...
- 通过odbc配置mssql连接要备份的数据库进行备份,本备份放到sqlserver默认备份目录下.
- 暂时没有该资源介绍
- DirectShow视频捕捉代码用雷达RS232电子警察.用DirectShow保存JPG文件,&n...
- 为一个小KTV场所做的收费系统,说好价钱的.可是老板又不出,就随便做了出来,发出来共享...
- 一个网络综合扫描源码,用到了多线程等技术,想学DELPHI&HACK编程的朋友可参考
- 计算期货交易的收益,结果支持图形曲线显示,数据可以灵活的导入和导出.系统操作界面友好,醒目.
- 盘点的正确率，柱状图显示，并可查询盘点数据，是初学delphi数据库编程朋友们的助手。}