Selecting a file Excel/Access

[njwilli3]

i'm trying to automate the import of an excel spreadhseet into Access 2000. The following code does so and imports this into a table called 'New'. However as you can see i have put the full path of where the spreadsheet is to be located everytime a user wants to import it.

What i need is this to be a dialog box that appears (on push of a button) where you can browse and choose the file wherever it may be located. I have tried adding a MS common dialog control but it says i do not have the activeX license, is there any other way around this?? Many thanks

'''''''''''''''''''code
DoCmd.TransferSpreadsheet acImport, , "New", _
"C:\Documents and Settings\Nick Williams\My Documents\My Databases\SupplierParts.xls", _
True, "A:C"
'''''''''''''''''''''

[JustinLabenne]

Sure:

Option Explicit
'^*^*^*^*^*^*^*^*^*^*^*^*^*
'> Folder/File browsing code module
'^*^*^*^*^*^*^*^*^*^*^*^*^*
 
'Retrieves the window handle to the active window associated with the thread that calls the function
Private Declare Function apiGetActiveWindow& Lib "user32" Alias "GetActiveWindow" ()
 
'Retrieves a handle to the specified child window's parent window
Private Declare Function apiGetParent& Lib "user32" Alias "GetParent" _
                        (ByVal hWnd As Long)
 
'Retrieves the dimensions of the bounding rectangle of the specified window
Private Declare Function GetWindowRect& Lib "user32" _
                        (ByVal hWnd As Long, _
                         lpRect As RECT)
 
'Retrieves various system metrics (in pixels)
Private Declare Function GetSystemMetrics& Lib "user32" _
                        (ByVal nIndex As Long)
 
'Changes the position and dimensions of the specified window
Private Declare Function MoveWindow& Lib "user32" _
                        (ByVal hWnd As Long, _
                         ByVal x As Long, _
                         ByVal y As Long, _
                         ByVal nWidth As Long, _
                         ByVal nHeight As Long, _
                         ByVal bRepaint As Long)
  
'Appends one string to another
Private Declare Function lstrcat& Lib "kernel32.dll" Alias "lstrcatA" _
                        (ByVal lpString1 As String, _
                         ByVal lpString2 As String)
                         
'Displays a dialog box enabling the user to select a Shell folder
Private Declare Function SHBrowseForFolder& Lib "shell32.dll" _
                        (lpbi As BrowseInfo)
                        
'Converts an item identifier list to a file system path
Private Declare Function SHGetPathFromIDList& Lib "shell32.dll" _
                        (ByVal pidList As Long, _
                         ByVal lpBuffer As String)
                         
'Retrieves a pointer to the ITEMIDLIST structure of a special folder
Private Declare Function SHGetSpecialFolderLocation& Lib "shell32.dll" _
                        (ByVal hWndOwner As Long, _
                         ByVal nFolder As Long, _
                         ppidl As Long)
                         
'Retrieves a handle to a window whose class name and window name match the specified strings
Private Declare Function FindWindowEx& Lib "user32" Alias "FindWindowExA" _
                        (ByVal hWnd1 As Long, _
                         ByVal hWnd2 As Long, _
                         ByVal lpsz1 As String, _
                         ByVal lpsz2 As String)
                         
'Retrieves the identifier of the thread that created the specified window
Private Declare Function GetWindowThreadProcessId& Lib "user32" _
                        (ByVal hWnd As Long, _
                         ByRef lpdwProcessId As Long)
                         
'Retrieves the process identifier of the calling process
Private Declare Function GetCurrentProcessId& Lib "kernel32" ()
 
'Returns a handle to the desktop window
Private Declare Function GetDesktopWindow& Lib "user32" ()
 
'Frees a block of task memory
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
 
'Parameters for the dialog centering
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
 
'Parameters for the SHBrowseForFolder function
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
 
'Special Folder Types
Public Enum FolderType
    AppData = &H1A
    BitBucket = &HA
    CommonDesktopDirectory = &H19
    CommonDocuments = &H2E
    CommonFavorites = &H1F
    CommonPrograms = &H17
    CommonStartMenu = &H16
    CommonStartup = &H18
    CommonTemplates = &H2D
    CommonAltStartup = &H1E
    CommonAppData = &H23
    CommonDesktop = &H0
    CommonMyMusic = &H35
    CommonMyPictures = &H36
    CommonMyVideos = &H37
    CommonStartAdmin = &H2F
    Connections = &H31
    Controls = &H3
    Drives = &H11
    Favorites = &H6
    Fonts = &H14
    LocalAltStartup = &H1D
    LocalAppData = &H1C
    LocalAppMSCDBurning = &H3B
    LocalCookies = &H21
    LocalDesktop = &H10
    LocalHistory = &H22
    LocalInternetCache = &H20
    LocalMyVideos = &HE
    LocalStartAdmin = &H30
    MSHome = &H3D
    MyMusic = &HD
    MyPictures = &H27
    NetHood = &H13
    Network = &H12
    Personal = &H5
    Printers = &H4
    Printhood = &H1B
    Profile = &H28
    ProgramFiles = &H26
    CommonProgramFiles = &H2B
    CommonX86ProgramFiles = &H2C
    X86ProgramFiles = &H2A
    Programs = &H2
    Recent = &H8
    Resources = &H39
    SendTo = &H9
    StartMenu = &HB
    Startup = &H7
    System = &H25
    SystemX86 = &H29
    Templates = &H15
    Windows = &H24
End Enum
 
'What to browse for
Public Enum BrowseType
    BrowseForComputers = &H1000
    BrowseForPrinters = &H2000
    BrowseForFiles = &H4000
    BrowseForFilesCreateOption = &H4040
    BrowseForFoldersWithEditBox = &H10
    BrowseForFoldersCreateOption = &H40
    BrowseForFolders = &H1
End Enum
 
'Screen metric constants
Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11
 
'Dialog fully initiallized constant
Private Const BFFM_INITIALIZED = &H1
 
'Maximum character length of path
Private Const MAX_PATH  As Long = 260
 
Private Function GetAccesshWnd()
    Dim hWnd As Long
    Dim hWndAccess As Long
 
    ' Get the handle to the currently active window.
    hWnd = apiGetActiveWindow()
    hWndAccess = hWnd
 
    ' Find the top window (which has no parent window).
    While hWnd <> 0
        hWndAccess = hWnd
        hWnd = apiGetParent(hWnd)
    Wend
 
    GetAccesshWnd = hWndAccess
End Function
 
Private Function BrowseCallBackFunc(ByVal hWnd As Long, ByVal lMsg As Long, ByVal lParam As Long, ByVal pData As Long) As Long
'   Windows calls this function when the dialog events occur
    Select Case lMsg
        Case BFFM_INITIALIZED
            CenterDialog hWnd
    End Select
    
    'Allow the dialog to close
    BrowseCallBackFunc = 0
End Function
 
Private Function BrowseCallBackFuncAddress() As Long
    BrowseCallBackFuncAddress = Long2Long(AddressOf BrowseCallBackFunc)
End Function
 
Private Function Long2Long(x As Long) As Long
    'Explicitly convert a udt to a long
    Long2Long = x
End Function
 
Private Function fValidatePath(ByVal szFullPath As String) As String
    'Check the folder path and add a seperator if necessary
    Select Case Right$(szFullPath, 1)
        Case ""
            Exit Function
        Case "\"
            fValidatePath = szFullPath
        Case Else
            fValidatePath = szFullPath & "\"
    End Select
End Function
 
Private Sub CenterDialog(hWnd As Long)
    'Used to center the dialog on the screen
    Dim WinRect As RECT
    Dim ScrWidth As Integer
    Dim ScrHeight As Integer
    Dim DlgWidth As Integer
    Dim DlgHeight As Integer
    
    GetWindowRect hWnd, WinRect
    DlgWidth = WinRect.Right - WinRect.Left
    DlgHeight = WinRect.Bottom - WinRect.Top
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
    MoveWindow hWnd, (ScrWidth - DlgWidth) / 2, (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub
 
Public Function fBrowseFor(ByVal BrowseFor As BrowseType, _
                               ByVal RootFolder As FolderType, _
                               Optional bCenter As Boolean) As String
    Dim iNullpos As Integer
    Dim lpIDList As Long
    Dim lres As Long
    Dim szPath As String
    Dim BInfo As BrowseInfo
    Dim lRootID As Long
    
    
    'Foolproof way to find the main Access window handle
    Dim AppWnd As Long
  '  If Val(Application.Version) >= 10 Then
   '     AppWnd = Application.hWndAccessApp
   ' Else
        AppWnd = GetAccesshWnd()
   ' End If
        
    'Retrieve special folder locations
    SHGetSpecialFolderLocation AppWnd, RootFolder, lRootID
    With BInfo
        .hWndOwner = AppWnd
        If bCenter Then .lpfnCallback = BrowseCallBackFuncAddress
        .ulFlags = BrowseFor
        
        
        'Determine our browse title
        Select Case BrowseFor
            Case 1
                .lpszTitle = lstrcat("Select a Folder", "")
            Case 64
                .lpszTitle = lstrcat("Select a Folder", "")
            Case 4096
                .lpszTitle = lstrcat("Select a Computer", "")
            Case 8192
                .lpszTitle = lstrcat("Select a Printer", "")
            Case Else
                .lpszTitle = lstrcat("Select a File", "")
        End Select
    End With
 
    If lRootID <> 0 Then BInfo.pIDLRoot = lRootID
        lpIDList = SHBrowseForFolder(BInfo)
 
    If lpIDList <> 0 Then
        szPath = String(MAX_PATH, 0)
        lres = SHGetPathFromIDList(lpIDList, szPath)
        Call CoTaskMemFree(lpIDList)
        iNullpos = InStr(szPath, vbNullChar)
        If iNullpos <> 0 Then
            szPath = Left$(szPath, iNullpos - 1)
        End If
    End If
 
    'Browsing for files allow folders to be selected also
    'We check the selected item to see if it is a file or not
    If Not Mid$(Right$(szPath, 4), 1, 1) = "." Then
        fBrowseFor = fValidatePath(szPath)
    Else
        fBrowseFor = szPath
    End If
End Function

Then incorporate like this:

Dim szFilePicked As String
    szFilePicked = fBrowseFor(BrowseForFiles, Drives, True)
    
    DoCmd.TransferSpreadsheet acImport, , "New", szFilePicked, True, "A:C"

[njwilli3]

That is genious my friend.. it works great, your a legend.