API File Copy Demo

By | 2018-02-16

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

FileUploadedSize
932-20180216-040948-APIFileCopy.zip2/16/2018 4:09:48 AM4017
Author: dwirch

Derek Wirch is a seasoned IT professional with an impressive career dating back to 1986. He brings a wealth of knowledge and hands-on experience that is invaluable to those embarking on their journey in the tech industry.

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.