📄 form1.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form main
BorderStyle = 1 'Fixed Single
Caption = "File Copier"
ClientHeight = 4815
ClientLeft = 45
ClientTop = 330
ClientWidth = 6990
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4815
ScaleWidth = 6990
StartUpPosition = 3 'Windows Default
Begin VB.TextBox Text3
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H00000000&
BorderStyle = 0 'None
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FF00&
Height = 375
Left = 240
TabIndex = 7
Text = "Text3"
Top = 2520
Visible = 0 'False
Width = 6495
End
Begin VB.CommandButton Command2
Caption = "Add"
Height = 375
Left = 5760
TabIndex = 3
ToolTipText = ":: Add To List ::"
Top = 2520
Width = 975
End
Begin VB.CommandButton Command3
Caption = "^"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 5280
TabIndex = 4
ToolTipText = ":: Browse Destination Folder ::"
Top = 2520
Width = 495
End
Begin VB.TextBox Text1
Appearance = 0 'Flat
BackColor = &H00C0FFFF&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
Locked = -1 'True
TabIndex = 1
ToolTipText = ":: Destination Folder Name ::"
Top = 2520
Width = 5055
End
Begin VB.CommandButton Command4
Caption = "Exe Path"
Height = 375
Left = 5280
TabIndex = 6
ToolTipText = ":: Browse Source File ::"
Top = 3240
Width = 1455
End
Begin VB.TextBox Text2
Appearance = 0 'Flat
BackColor = &H00C0E0FF&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
Locked = -1 'True
TabIndex = 5
ToolTipText = ":: Source File Name ::"
Top = 3240
Width = 5055
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 0
Top = 0
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.ListBox List1
Appearance = 0 'Flat
BackColor = &H80000018&
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 2280
Left = 240
Style = 1 'Checkbox
TabIndex = 2
ToolTipText = ":: Destination Folder List ::"
Top = 120
Width = 6495
End
Begin VB.CommandButton Command1
Caption = "&Done"
Height = 855
Left = 240
TabIndex = 0
ToolTipText = ":: Save ::"
Top = 3840
Width = 2895
End
Begin VB.Line Line2
BorderColor = &H00FF0000&
X1 = 240
X2 = 6720
Y1 = 3720
Y2 = 3720
End
Begin VB.Line Line1
BorderColor = &H00FF0000&
X1 = 240
X2 = 6720
Y1 = 3120
Y2 = 3120
End
End
Attribute VB_Name = "main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' This project is done by Umesh C. Dwivedi
' any comment or suggestion are welcome
' you can reach me on umesh909@yahoo.com
' please add reference to Microsoft Scripting library (SCRRUN.DLL)
Option Explicit
Dim rs As New ADODB.Recordset
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
Const BIF_RETURNONLYFSDIRS = 0
Const BIF_DONTGOBELOWDOMAIN = 0
Const MAX_PATH = 260
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 blnstop As Boolean
Private Declare Function CopyFile Lib "kernel32" _
Alias "CopyFileA" (ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, ByVal bFailIfExists As Long) _
As Long
Private Sub Command1_Click()
If Text2.Text = "" Then
MsgBox "Please Select Source File Name", vbInformation, "Source"
Text2.SetFocus
Exit Sub
End If
If FileExists(Text2.Text) = False Then
MsgBox Text2.Text & " This File Does Not Exist", vbInformation, "File Exist"
Text2.SetFocus
Exit Sub
End If
If Dir(Text2.Text) = "" Then
MsgBox Text2.Text & " This Directory Does Not Exist", vbInformation, "Directory Exist"
Text2.SetFocus
Exit Sub
End If
If List1.ListCount > 0 Then
Screen.MousePointer = vbHourglass
List1.Enabled = False
blnstop = False
Dim bSuccess As Boolean
Dim i As Integer
Set rs = New ADODB.Recordset
rs.Fields.Append "Paths", adVarChar, 1000
rs.Open
For i = 0 To List1.ListCount - 1
If List1.Selected(i) = True Then
rs.AddNew
rs.Fields(0).Value = List1.List(i)
rs.Update
End If
Next
'-----------------------------------
If rs.RecordCount > 0 Then
rs.MoveFirst
Do Until rs.EOF
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
If blnstop = True Then
If vbYes = MsgBox("Do You Want To Stop Process", vbCritical + vbYesNo) Then
Screen.MousePointer = vbDefault
List1.Enabled = True
Exit Sub
End If
End If
Text3.Visible = True
Text3.Text = " Wait Copying To ( " & rs.AbsolutePosition & "/" & rs.RecordCount & " ) :-> " & rs.Fields(0).Value
DoEvents
DoEvents
DoEvents
bSuccess = APIFileCopy(Text2.Text, rs.Fields(0).Value & getfiletitle(Text2.Text))
If bSuccess = False Then
MsgBox "There is some problem with path >> " & rs.Fields(0).Value
End If
DoEvents
DoEvents
DoEvents
Text3.Visible = False
DoEvents
DoEvents
DoEvents
rs.MoveNext
Loop
End If
'-----------------------------------
If FileExists(App.Path & "\path.xml") = True Then
Kill App.Path & "\path.xml"
End If
rs.Save App.Path & "\path.xml", adPersistXML
Set rs = Nothing
Screen.MousePointer = vbDefault
List1.Enabled = True
MsgBox "File Has Been Copied To Destination/s", vbInformation, "Done"
Call FillList
Else
MsgBox "Please Add At Least One Folder Name In The List", vbInformation, "Empty List"
End If
End Sub
Public Function APIFileCopy(src As String, dest As String, _
Optional FailIfDestExists As Boolean) As Boolean
Dim lRet As Long
lRet = CopyFile(src, dest, FailIfDestExists)
APIFileCopy = (lRet > 0)
End Function
Public Function LoadRsFromXML(FullPath As String) As _
ADODB.Recordset
Dim oRs As New ADODB.Recordset
On Error Resume Next
If Dir(FullPath) = "" Then Exit Function
oRs.Open FullPath, "Provider=MSPersist;", adOpenForwardOnly, _
adLockReadOnly, adCmdFile
If Err.Number = 0 Then
Set LoadRsFromXML = oRs
End If
End Function
Private Sub Command2_Click()
If Text1.Text = "" Then
MsgBox "Please Select Destination Folder ", vbInformation, "Destination"
Text1.SetFocus
Exit Sub
End If
' If Dir(Text1.Text) = "" Then
' MsgBox Text1.Text & " This Directory Does Not Exist", vbInformation, "Directory Exist"
' Text1.SetFocus
' Exit Sub
' End If
Dim i As Integer
For i = 0 To List1.ListCount - 1
If UCase(Text1.Text) = UCase(List1.List(i)) Then
MsgBox "This Path is already added", vbInformation, "path"
Exit Sub
End If
Next
List1.AddItem Text1.Text
List1.Selected(List1.NewIndex) = True
Text1.Text = ""
End Sub
Private Sub Command3_Click()
Dim lpIDList As Long 'Declare Varibles
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "Select the folder"
With tBrowseInfo
.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 Command4_Click()
Dim Filter As String
On Error GoTo OpenError: 'Stops errors, like opening a false file path
Filter = "Aplication Files (*.exe)|*.exe;|" 'This is the normal way of opening a file with your own ext.
Filter = Filter + "All Formats(*.*)|*.*;*.*;|"
' Filter = Filter + "JPEG Files (*.jpg)|*.jpg;|" 'Shows JPG Files(This is how you normally open a file)
' Filter = Filter + "All Formats(*.*)|*.alw;*.jpg;|" 'Show both formats at once
CommonDialog1.Filter = Filter 'This is how you make the filter show in the filter section
CommonDialog1.ShowOpen 'Show the dialog now
CommonDialog1.FilterIndex = 1 'Makes the *.alw extention come up first as default
Text2.Text = CommonDialog1.filename 'The file from the dialog is loaded in the picture box
OpenError:
Exit Sub
End Sub
Private Sub Form_Activate()
Command4.SetFocus
End Sub
Private Sub Form_Load()
Call FillList
End Sub
Private Function FillList()
If FileExists(App.Path & "\path.xml") = True Then
Set rs = New ADODB.Recordset
rs.Fields.Append "Paths", adVarChar, 1000
rs.Open
Set rs = LoadRsFromXML(App.Path & "\path.xml")
If rs Is Nothing Then
Exit Function
End If
List1.Clear
If rs.RecordCount > 0 Then
Do Until rs.EOF
List1.AddItem rs.Fields(0).Value
List1.Selected(List1.NewIndex) = True
rs.MoveNext
Loop
End If
Set rs = Nothing
End If
End Function
Public Function getfiletitle(filename As String) As String
Dim i As Integer
Dim c As String
Dim pos As Integer
For i = Len(filename) To 2 Step -1
c = Mid(filename, i, 1)
If c = "\" Then
pos = i
Exit For
pos = i + 1
End If
Next
getfiletitle = Mid(filename, pos, (Len(filename) + 1 - pos))
End Function
Public Function FileExists(sFullPath As String) As Boolean
Dim oFile As New Scripting.FileSystemObject
FileExists = oFile.FileExists(sFullPath)
Set oFile = Nothing
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -