Manufacturing Information Solutions Forum Index Manufacturing Information Solutions
Your Place for Support and Discussions
 
 FAQFAQ   SearchSearch   MemberlistMemberlist   UsergroupsUsergroups   RegisterRegister 
 ProfileProfile   Log in to check your private messagesLog in to check your private messages   Log inLog in 

File Open Dialog Boxes Without Active X Controls

 
Post new topic   Reply to topic    Manufacturing Information Solutions Forum Index -> Microsoft Access
View previous topic :: View next topic  
Author Message
BIGmiralli
Frequent Poster


Joined: 17 Apr 2007
Posts: 38
Location: Boston, Massachusetts

PostPosted: Fri May 23, 2008 12:47 pm    Post subject: File Open Dialog Boxes Without Active X Controls Reply with quote

The database below has one module, which contains all the functions you require to show a file open dialog box without using the commondialog activex control. This is usefull if you have restrictions on your network stopping you from using custom activex controls, but would like a familiar interface for the endusers. There is one form in the database which has three examples showing how to use the file function.

On a form put:
Code:
Private Sub CmdBrowse_Click()
    Me.txtDir.Value = GetDirectory("Please Select a directory", Me)
End Sub

Private Sub CmdDBBrowse_Click()
    Me.txtDB.Value = FindDB(Me.txtDir.Value)
End Sub

Private Sub CmdXLBrowse_Click()
    Me.txtXLFIle.Value = FindFile(Me.txtDir.Value, "Please Select an Excel File", "Excel Files", "*.xl?")
End Sub



Code:
Option Explicit
Option Compare Database
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' This Module contains commonly used file functions:
'   GetDirectory - API wrapper for SHBrowseForFolder Function
'   FindFile - ask the user to pick a specific file
'   FindDB - Specific FindFile for Access MDBs
'   RefreshLinks - refresh linked tables in a database
'
' All code has been lifted & adapted from Microsoft Sources
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'API Functions
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Private Declare Function SHBrowseForFolder Lib "shell32" _
                                        (lpbi As BrowseInfo) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32" _
                                        (ByVal pidList As Long, _
                                        ByVal lpBuffer As String) As Long

Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
                                        (ByVal lpString1 As String, ByVal _
                                        lpString2 As String) As Long

'constants
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Const ALLFILES = "All Files"
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_EXPLORER = &H80000
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHOWHELP = &H10

'types
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

Private Type MSA_OPENFILENAME
    ' Filter string used for the Open dialog filters.
    ' Use MSA_CreateFilterString() to create this.
    ' Default = All Files, *.*
    strFilter As String
    ' Initial Filter to display.
    ' Default = 1.
    lngFilterIndex As Long
    ' Initial directory for the dialog to open in.
    ' Default = Current working directory.
    strInitialDir As String
    ' Initial file name to populate the dialog with.
    ' Default = "".
    strInitialFile As String
    strDialogTitle As String
    ' Default extension to append to file if user didn't specify one.
    ' Default = System Values (Open File, Save File).
    strDefaultExtension As String
    ' Flags (see constant list) to be used.
    ' Default = no flags.
    lngFlags As Long
    ' Full path of file picked.  When the File Open dialog box is
    ' presented, if the user picks a nonexistent file,
    ' only the text in the "File Name" box is returned.
    strFullPathReturned As String
    ' File name of file picked.
    strFileNameReturned As String
    ' Offset in full path (strFullPathReturned) where the file name
    ' (strFileNameReturned) begins.
    intFileOffset As Integer
    ' Offset in full path (strFullPathReturned) where the file extension begins.
    intFileExtension As Integer
End Type

Private Type OPENFILENAME
    lStructSize As Long
    hWndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustrFilter 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
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Function RefreshLinks
'   Inputs: strFileName - FileName of Database
'   Outputs:Return True if successful.
'   Comments: Refresh links to the supplied database.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function RefreshLinks(strFileName As String) As Boolean
    Dim Dbs As Database
    Dim tdf As TableDef

    ' Loop through all tables in the database.
    Set Dbs = CurrentDb
    For Each tdf In Dbs.TableDefs
        ' If the table has a connect string, it's a linked table.
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = ";DATABASE=" & strFileName
            Err = 0
            On Error Resume Next
            tdf.RefreshLink         ' Relink the table.
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next tdf
    RefreshLinks = True        ' Relinking complete.
End Function


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Function GetDirectory
'   Inputs: szTitle - Text Prompt in Dialog Box
'           CallingForm - Form that is to act as owner of dialog (usually Me)
'   Outputs:Returns Selected Directory Path
'   Comments: Opens a Treeview control that displays the directories in a computer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function GetDirectory(szTitle As String, CallingForm As Form) As String
         Dim lpIDList As Long
         Dim sBuffer As String
         Dim tBrowseInfo As BrowseInfo

         With tBrowseInfo
            .hWndOwner = CallingForm.Hwnd
            .lpszTitle = lstrcat(szTitle, "")
            .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
         End With

         lpIDList = SHBrowseForFolder(tBrowseInfo)

         If (lpIDList) Then
            sBuffer = Space(MAX_PATH)
            SHGetPathFromIDList lpIDList, sBuffer
            sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
            GetDirectory = sBuffer
         End If
End Function


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Function FindDB
'   Inputs: strSearchPath - Initial Path to set dialog to
'   Outputs:Returns the full path to Database.
'   Comments: Displays the Open dialog box for the user to locate
'             a database.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function FindDB(SearchPath) As String
    Dim msaof As MSA_OPENFILENAME
   
    ' Set options for the dialog box.
    msaof.strDialogTitle = "Where Is The Database?"
    If IsNull(SearchPath) Then SearchPath = "c:\"
    msaof.strInitialDir = SearchPath
    msaof.strFilter = MSA_CreateFilterString("Databases", "*.mdb")
   
    ' Call the Open dialog routine.
    MSA_GetOpenFileName msaof
   
    ' Return the path and file name.
    FindDB = Trim(msaof.strFullPathReturned)
   
End Function


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Function FindFile
'   Inputs: SearchPath - Initial Path to set dialog to
'           Title - Title of the dialog box
'           Filtername - frendly name for type of files to be located (E.G. "Excel Files")
'           Filter - Wildcard Patern for Files (E.G. *.XLS)
'   Outputs:Returns the full path to File.
'   Comments: Displays the Open dialog box for the user to locate
'             a File.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function FindFile(SearchPath As String, Title As String, FilterName As String, Filter As String) As String
    Dim msaof As MSA_OPENFILENAME
   
    ' Set options for the dialog box.
    msaof.strDialogTitle = Title
    msaof.strInitialDir = SearchPath
    msaof.strFilter = MSA_CreateFilterString(FilterName, Filter)
   
    ' Call the Open dialog routine.
    MSA_GetOpenFileName msaof
   
    ' Return the path and file name.
    FindFile = Trim(msaof.strFullPathReturned)
   
End Function


Private Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Creates a filter string from the passed in arguments.
' Returns "" if no argumentss are passed in.
' Expects an even number of argumentss (filter name, extension), but
' if an odd number is passed in, it appends "*.*".
   
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer

    intNum = UBound(varFilt)
    If (intNum <> -1) Then
        For intRet = 0 To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod 2 = 0 Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
       
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If

    MSA_CreateFilterString = strFilter
End Function

Private Function MSA_ConvertFilterString(strFilterIn As String) As String
' Creates a filter string from a bar ("|") separated string.
' The string should pairs of filter|extension strings, i.e. "Access Databases|*.mdb|All Files|*.*"
' If no extensions exists for the last filter pair, *.* is added.
' This code will ignore any empty strings, i.e. "||" pairs.
' Returns "" if the strings passed in is empty.

   
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer

    strFilter = ""
    intNum = 0
    intPos = 1
    intLastPos = 1

    ' Add strings as long as we find bars.
    ' Ignore any empty strings (not allowed).
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum + 1
            intLastPos = intPos + 1
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos + 1
        End If
    Loop Until (intPos = 0)
       
    ' Get last string if it exists (assuming strFilterIn was not bar terminated).
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
        intNum = intNum + 1
    End If
   
    ' Add *.* if there's no extension for the last string.
    If intNum Mod 2 = 1 Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
   
    ' Add terminating NULL if we have any filter.
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
   
    MSA_ConvertFilterString = strFilter
End Function

Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the file save dialog.
   
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    of.Flags = of.Flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Private Function MSA_SimpleGetSaveFileName() As String
' Opens the file save dialog with default values.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
   
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
   
    MSA_SimpleGetSaveFileName = strRet
End Function

Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the Open dialog.
   
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet
End Function

Private Function MSA_SimpleGetOpenFileName() As String
' Opens the Open dialog with default values.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
   
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
   
    MSA_SimpleGetOpenFileName = strRet
End Function


Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' This sub converts from the Win32 structure to the Microsoft Access structure.
   
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' This sub converts from the Microsoft Access structure to the Win32 structure.
   
    Dim strFile As String * 512

    ' Initialize some parts of the structure.
    of.hWndOwner = Application.hWndAccessApp
    of.hInstance = 0
    of.lpstrCustomFilter = 0
    of.nMaxCustrFilter = 0
    of.lpfnHook = 0
    of.lpTemplateName = 0
    of.lCustrData = 0
   
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
   
    of.lpstrFile = msaof.strInitialFile _
        & String(512 - Len(msaof.strInitialFile), 0)
    of.nMaxFile = 511

    of.lpstrFileTitle = String(512, 0)
    of.nMaxFileTitle = 511

    of.lpstrTitle = msaof.strDialogTitle

    of.lpstrInitialDir = msaof.strInitialDir
   
    of.lpstrDefExt = msaof.strDefaultExtension

    of.Flags = msaof.lngFlags
   
    of.lStructSize = Len(of)
End Sub

________
MERCEDES-BENZ PONTON
Back to top
View user's profile Send private message
Display posts from previous:   
Post new topic   Reply to topic    Manufacturing Information Solutions Forum Index -> Microsoft Access All times are GMT - 5 Hours
Page 1 of 1

 
Jump to:  
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum


Powered by phpBB © 2001, 2005 phpBB Group