API Sample that demonstrates how to use the windows Shell to select any file, then select a directory, then use the shell to copy the file from one location to another, displaying the Shell Copy Progress Box.
A professional way of doing things.
Form Code
Private Sub Command1_Click(Index As Integer)
On Error Resume Next
Dim i As Integer
Select Case Index
Case 0
Call GetFileInfo
Case 1
Call GetDestinationDirectory
Case 2
TheFile = Text1(0).Text
Text1(2).Text = "Status: Copying file."
Call CopyData(TheFile, Text1(1).Text)
Command1(Index).Enabled = False
Case 3
Text1(0).Text = vbNullString
Text1(1).Text = vbNullString
Command1(0).Enabled = True
Command1(1).Enabled = False
Command1(2).Enabled = False
Command1(Index).Enabled = False
Text1(2).Text = "Status: Nothing pending."
Case Else: Exit Sub
End Select
End Sub
Private Sub Form_Load()
On Error Resume Next
Dim i As Integer
For i = 1 To 3
Command1(i).Enabled = False
Next i
End Sub
Private Sub Text1_Change(Index As Integer)
On Error Resume Next
Select Case Index
Case 0
Command1(1).Enabled = True: Command1(1).SetFocus
Case 1
If Text1(0).Text <> vbNullString And Text1(1).Text <> vbNullString Then
Command1(0).Enabled = False
Command1(1).Enabled = False
Command1(2).Enabled = True: Command1(2).SetFocus
Command1(3).Enabled = True
Text1(2).Text = "Status: Job pending."
End If
Case Else: Exit Sub
End Select
End Sub
Module Code:
Attribute VB_Name = "Module1"
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, _
hpvSource As Any, _
ByVal cbCopy As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, _
ByVal lpString2 As String) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, _
ByVal lpBuffer As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Const FO_COPY = &H2&
Public Const FO_DELETE = &H3&
Public Const FO_MOVE = &H1&
Public Const FO_RENAME = &H4&
Public Const FOF_ALLOWUNDO = &H40&
Public Const FOF_CONFIRMMOUSE = &H2&
Public Const FOF_CREATEPROGRESSDLG = &H0&
Public Const FOF_FILESONLY = &H80&
Public Const FOF_MULTIDESTFILES = &H1&
Public Const FOF_NOCONFIRMATION = &H10&
Public Const FOF_NOCONFIRMMKDIR = &H200&
Public Const FOF_RENAMEONCOLLISION = &H8&
Public Const FOF_SILENT = &H4&
Public Const FOF_SIMPLEPROGRESS = &H100&
Public Const FOF_WANTMAPPINGHANDLE = &H20&
Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String
End Type
Public 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
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260
Public Sub CopyData(FilePath, DestinationDir)
On Error Resume Next
Dim Result As Long
Dim lenFileop As Long
Dim foBuf() As Byte
Dim fileop As SHFILEOPSTRUCT
Dim SourceOfCopy As String
Dim DestDirectory As String
SourceOfCopy = FilePath
DestDirectory = DestinationDir
lenFileop = LenB(fileop)
ReDim foBuf(1 To lenFileop)
With fileop
.hwnd = Form1.hwnd
.wFunc = FO_COPY
.fFlags = FOF_SIMPLEPROGRESS Or FOF_FILESONLY
.pFrom = SourceOfCopy
.pTo = DestDirectory & "\" & vbNullChar & vbNullChar
.fFlags = FOF_SIMPLEPROGRESS Or FOF_NOCONFIRMATION Or FOF_NOCONFIRMMKDIR
.lpszProgressTitle = "The Copy process is healthy." _
& vbNullChar _
& vbNullChar
End With
Call CopyMemory(foBuf(1), fileop, lenFileop)
Call CopyMemory(foBuf(19), foBuf(21), 12)
Result = SHFileOperation(foBuf(1))
If Result <> 0 Then
MsgBox "An error prevented the Copy process." & _
vbCrLf & "Error returned: " & _
Err.LastDllError, _
vbApplicationModal + vbExclamation + vbOKOnly, _
"Copy error"
Else
If fileop.fAnyOperationsAborted <> 0 Then
MsgBox "The Copy process was not successful.", _
vbApplicationModal + vbExclamation + vbOKOnly, _
"Copy failed"
Form1.Text1(2).Text = "Status: Copy failed."
End If
End If
If fileop.fAnyOperationsAborted = 0 And Result = 0 Then
Form1.Text1(2).Text = "Status: Copy completed."
End If
End Sub
Public Sub GetFileInfo()
On Error Resume Next
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
With OpenFile
.lStructSize = Len(OpenFile)
.hWndOwner = Form1.hwnd
.hInstance = App.hInstance
sFilter = "MP4 Files (*.mp4)" & Chr(0) & "*.mp4" & Chr(0)
.lpstrFilter = sFilter
.nFilterIndex = 1
.lpstrFile = String(257, 0)
.nMaxFile = Len(OpenFile.lpstrFile) - 1
.lpstrFileTitle = OpenFile.lpstrFile
.nMaxFileTitle = OpenFile.nMaxFile
.lpstrInitialDir = "C:\"
.lpstrTitle = "Select file to copy."
.flags = 0
End With
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
Exit Sub
Else
Form1.Text1(0).Text = Trim(OpenFile.lpstrFile)
End If
End Sub
Public Sub GetDestinationDirectory()
On Error Resume Next
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
.hWndOwner = Form1.hwnd
.lpszTitle = lstrcat("C:\", "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left(sPath, iNull - 1)
End If
End If
Form1.Text1(1).Text = sPath
End Sub
Attachments
| File | Uploaded | Size |
|---|---|---|
| 932-20180216-040948-APIFileCopy.zip | 2/16/2018 4:09:48 AM | 4017 |