Copy a windows folder to users desktop 1

[gretsch]

From an Access form (Access 2000), I need a user to be able to browse for a windows folder, then have that same folder with any files it contains, copy to the users desktop. Any examples any one has would be greatly appreciated.
thnx

D.

 

[GrahamHills]

To Folder browse you will need to create a module in your access database with the following code in it.

Option Compare Database
Option Explicit

'This module contains all the declarations to use the
'Windows 95 Shell API to use the browse for folders
'dialog box. To use the browse for folders dialog box,
'please call the BrowseForFolders function using the
'syntax: stringFolderPath=BrowseForFolders(Hwnd,TitleOfDialog)
'
'For contacting information, see other module


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 Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String

'declare variables to be used
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo

'initialise variables
With udtBI
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With

'Call the browse for folder API
lpIDList = SHBrowseForFolder(udtBI)

'get the resulting string path
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If

'If cancel was pressed, sPath = ""
BrowseForFolder = sPath

End Function

Then add this code to the declaration section of your form module:-

Private Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hWnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long

Private Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long


Then add this code to a button click event:-

Private Sub btnRun_Click()

Dim strDesktopPath As String
Dim strSourceFolderPath As String
Dim fso As FileSystemObject

Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long

Const CSIDL_DESKTOPDIRECTORY = &H10
Const MAX_PATH = 260
Const NOERROR = 0

'Select the File to copy
strSourceFolderPath = BrowseForFolder(hWnd, "Please select the Folder path to copy to your desktop")

' Obtain the physical path to the desktop folder
' for the current user.
strDesktopPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, lngPidl)

If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strDesktopPath)
If lngFolderFound Then
strDesktopPath = Left$(strDesktopPath, InStr(1, strDesktopPath, vbNullChar) - 1)
If Right(strDesktopPath, 1) <> "\" Then strDesktopPath = strDesktopPath & "\"
End If
End If

Set fso = New FileSystemObject

fso.CopyFolder strSourceFolderPath, strDesktopPath, True

End Sub


At this point you can add logic to let the user decide to overwrite the folder if it alreadyt exists.

 

[gretsch]

Very cool, thank you. Although I am getting an error
'User-defined type not defined' its stopping on
Dim fso As FileSystemObject

Not sure what reference I need to add for this to be recognized.

D.

 

[gretsch]

OK got rid of the reference error. But how do I start the folder browse off from a specific directory/folder?

D.

 

[bubba100]

take a look at

http://www.mvps.org/access/api/api0002.htm

 

[gretsch]

Thnx Bubba100, but still defaults to 'My Computer', I'm passing a path, but seems to be being ignored.

strFolderName = BFolder("T:\Afolder\Bfolder\CFolder")

but to no avail.

Gretsch

 

[TheAceMan1]

How are ya gretsch . . .

Here's an API that opens a good looking DIR search dialog of which the starting folder is easily set. The API returns "" if the [blue]Cancel[/blue] is pushed or the full path to the DIR.

Credit for the API goes to: [blue]KPD-Team 1998[/blue] allapi.net

So . . . in a new [blue]module[/blue] in the modules window, copy/paste the following:

[blue]Const MAX_PATH = 260
Const BIF_RETURNONLYFSDIRS = &H1&
Const BIF_STATUSTEXT = &H4
Const WM_USER = &H400
Const BFFM_INITIALIZED = 1
Const BFFM_SELCHANGED = 2
Const BFFM_SETSTATUSTEXT = WM_USER + 100
Const BFFM_SETSELECTION = WM_USER + 102
Const SHGFI_DISPLAYNAME = &H200
Const SHGFI_PIDL = &H8
Const WM_SETTEXT = &HC

Declare Sub CopyMemory Lib "kernel32" _
               Alias "RtlMoveMemory" _
              (Destination As Any, _
               Source As Any, _
               ByVal Length As Long)

Declare Function BrowseForFolder Lib "shell32" _
                    Alias "SHBrowseForFolder" _
                    (lpbi As BROWSEINFO) As Long

Declare Function GetPathFromIDList Lib "shell32" _
                    Alias "SHGetPathFromIDList" _
                   (ByVal pidl As Long, _
                    ByVal pszPath As String) As Long

Declare Function SHGetFileInfo Lib "shell32" _
                    Alias "SHGetFileInfoA" _
                   (ByVal pszPath As Any, _
                    ByVal dwFileAttributes As Long, _
                    psfi As SHFILEINFO, _
                    ByVal cbFileInfo As Long, _
                    ByVal uFlags As Long) As Long

Declare Function SendMessage Lib "user32" _
                    Alias "SendMessageA" _
                   (ByVal hwnd As Long, _
                    ByVal wMsg As Long, _
                    ByVal wParam As Long, _
                    lParam As Any) As Long

Type BROWSEINFO
    hwndOwner       As Long
    pidlRoot        As Long
    pszDisplayName  As String
    lpszTitle       As String
    ulFlags         As Long
    lpfn            As Long
    lParam          As String
    iImage          As Long
End Type

Type SHFILEINFO
    hIcon           As Long
    iIcon           As Long
    dwAttributes    As Long
    szDisplayName   As String * MAX_PATH
    szTypeName      As String * 80
End Type

Function BrowseCallbackProc(ByVal hwnd As Long, _
                            ByVal uMsg As Long, _
                            ByVal lParam As Long, _
                            ByVal lpData As String) As Long
   Dim Path As String * MAX_PATH
   
   If uMsg = BFFM_SELCHANGED Then
      GetPathFromIDList lParam, Path
      
      If Asc(Path) = 0 Then
          Dim sfi As SHFILEINFO
          SHGetFileInfo lParam, 0, sfi, Len(sfi), SHGFI_DISPLAYNAME Or SHGFI_PIDL
          Path = sfi.szDisplayName
      End If
      
      SendMessage hwnd, BFFM_SETSTATUSTEXT, 0&, ByVal Path
   ElseIf uMsg = BFFM_INITIALIZED Then
      SendMessage hwnd, BFFM_SETSELECTION, True, ByVal lpData
      SendMessage hwnd, WM_SETTEXT, 0, ByVal "Browse for Folder"
   End If

End Function

Public Function BrowseFolders(frm As Form, Optional StartFolder As String) As String
   Dim bi As BROWSEINFO, pidl As Long, Path As String * MAX_PATH, SF As String
   
   If StartFolder = "" Then StartFolder = "C:\"
   CopyMemory bi.lpfn, AddressOf BrowseCallbackProc, 4
   
   bi.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT
   bi.hwndOwner = Screen.ActiveForm.hwnd
   bi.lParam = StrConv(Trim$(StartFolder), vbUnicode)
   bi.lpszTitle = "Select a folder from the tree."
   pidl = BrowseForFolder(bi)
   
   If pidl Then
      GetPathFromIDList pidl, Path
      BrowseFolders = Left$(Path, InStr(Path, vbNullChar) - 1)
   Else
      BrowseFolders = StartFolder
   End If

End Function[/blue]

Now . . . an example of calling the API from any form ([purple]it has to be called from a form[/purple]) would look like:

[blue]   Me![purple][b][i]TextboxName[/i][/b][/purple] = BrowseFolders(Me, "C:\Windows")[/blue]

This'll get the folder. Have to search my library for the shortcut when I get back from an errand . . .

See Ya! . . . . . .

Be sure to see FAQ219-2884:

 

[gretsch]

AceMan,
very nice indeed, thank you so much. Works like a charm!

Gretsch

 

[GrahamHills]

The reference required for "Dimming" FileSystemObject is "Microsoft Scripting Runtime"