API File Copy Demo

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

About this post

Posted: 2018-02-16
By: AXO
Viewed: 588 times

Comments

No comments have been added for this post.

You must be logged in to make a comment.