rk.txt

一个局域网文件的传送

Private Const BIF_RETURNONLYFSDIRS = 1 '从这里开始为API声明 
Private Const BIF_DONTGOBELOWDOMAIN = 2 
Private Const MAX_PATH = 260 

Private Declare Function SHBrowseForFolder Lib "Shell32" _ 
(lpbi As BrowseInfo) As Long 

Private Declare Function SHGetPathFromIDList Lib "Shell32" _ 
(ByVal pidList As Long, _ 
ByVal lpBuffer As String) As Long 

Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _ 
(ByVal lpString1 As String, ByVal _ 
lpString2 As String) As Long 

Private Type BrowseInfo 
hWndOwner As Long 
pIDLRoot As Long 
pszDisplayName As Long 
lpszTitle As Long 
ulFlags As Long 
lpfnCallback As Long 
lParam As Long 
iImage As Long 
End Type 
Dim a As New Shell 'Shell对象 

Private Sub Command1_Click() '源文件夹 
Dim lpIDList As Long 
Dim sBuffer As String 
Dim szTitle As String 
Dim tBrowseInfo As BrowseInfo 


With tBrowseInfo 
.hWndOwner = Me.hWnd 
.lpszTitle = lstrcat(szTitle, "") 
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN 
End With 

lpIDList = SHBrowseForFolder(tBrowseInfo) 

If (lpIDList) Then 
sBuffer = Space(MAX_PATH) 
SHGetPathFromIDList lpIDList, sBuffer 
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) 
Text1.Text = sBuffer 
End If 

End Sub 

Private Sub Command2_Click() '目标文件夹 
Dim lpIDList As Long 
Dim sBuffer As String 
Dim szTitle As String 
Dim tBrowseInfo As BrowseInfo 


With tBrowseInfo 
.hWndOwner = Me.hWnd 
.lpszTitle = lstrcat(szTitle, "") 
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN 
End With 

lpIDList = SHBrowseForFolder(tBrowseInfo) 

If (lpIDList) Then 
sBuffer = Space(MAX_PATH) 
SHGetPathFromIDList lpIDList, sBuffer 
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) 
Text2.Text = sBuffer 
End If 

End Sub 


Private Sub Command3_Click() 
If Text1.Text = "" Then 
MsgBox "请选择源文件夹", 48, "无文件路径" 
ElseIf Text2.Text = "" Then 
MsgBox "请选择目标文件夹", 48, "无文件路径" 
Else 

Timer1.Enabled = True 
Label3.Caption = "运行中……" 
End If 
End Sub 

Private Sub Command4_Click() 
Timer1.Enabled = False 
Label3.Caption = "中断" 
End Sub 

Private Sub Timer1_Timer() 


Dim limit_time As Data 
limit_data = CDate(Now - 1 / 288) '时间标记，大于这个时间的文件属于新文件 
Dim fso 
Set fso = CreateObject("Scripting.FileSystemObject") 
Dim fsobj 
Set fsobj = fso.GetFolder(Text1.Text) '目标文件夹 
Dim fsofolders 
Set fsofolders = fsobj.SubFolders 
Dim fsofile 
Set fsofile = fsobj.Files 
Dim i 
For Each i In fsofile 
If i.DateCreated > limit_data Then '如果文件的创建时间大于时间标记 
FileCopy Text1.Text + "\" + i.Name, Text2.Text + "\" + i.Name '复制文件 
End If 
Next 
End Sub