Get External Data

[Martin]

I would like to write some code that will import some data but I want the
user to select the file to import. I would like the first import box to
point to a specific location and not the last location used. Is there a way
to get the first import box to look in a folder I chose?

Here is the first part of the code that just brings up the import window:

DoCmd.DoMenuItem acFormBar, acFile, 2, acImport, acMenuVer70

Many thanks for your help,

Martin

[DomThePom via AccessMonster.com]

Hi Martin

You need to use the file open dialog (with the title of import) and then use
the filename & path returned in your import code.

Here are the functions that you need (all gleaned / adapted from the access
developers handbook) - just copy into a new module and adapt as you wish
using strInitDir as your directory starting point

All the best

Dom
*******************************************************
********************************************************
Option Compare Database
Option Explicit

Public gstrDir As String

' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.

' Examples from Chapter 12

Private Type OPENFILENAME
lngStructSize As Long ' Size of structure
hWndOwner As Long ' Owner window handle
hInstance As Long ' Template instance handle
strfilter As String ' Filter string
strCustomFilter As String ' Selected filter string
intMaxCustFilter As Long ' Len(strCustomFilter)
intFilterIndex As Long ' Index of filter string
strFile As String ' Selected filename & path
intMaxFile As Long ' Len(strFile)
strFileTitle As String ' Selected filename
intMaxFileTitle As Long ' Len(strFileTitle)
strInitialDir As String ' Directory name
strTitle As String ' Dialog title
lngFlags As Long ' Dialog flags
intFileOffset As Integer ' Offset of filename
intFileExtension As Integer ' Offset of file extension
strDefExt As String ' Default file extension
lngCustData As Long ' Custom data for hook
lngfnHook As Long ' LP to hook function
strTemplateName As String ' Dialog template name
End Type

Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean

' Open/Save dialog flags
Global Const OFN_READONLY = &H1
Global Const OFN_OVERWRITEPROMPT = &H2
Global Const OFN_HIDEREADONLY = &H4
Global Const OFN_NOCHANGEDIR = &H8
Global Const OFN_SHOWHELP = &H10
Global Const OFN_NOVALIDATE = &H100
Global Const OFN_ALLOWMULTISELECT = &H200
Global Const OFN_EXTENSIONDIFFERENT = &H400
Global Const OFN_PATHMUSTEXIST = &H800
Global Const OFN_FILEMUSTEXIST = &H1000
Global Const OFN_CREATEPROMPT = &H2000
Global Const OFN_SHAREAWARE = &H4000
Global Const OFN_NOREADONLYRETURN = &H8000
Global Const OFN_NOTESTFILECREATE = &H10000
Global Const OFN_NONETWORKBUTTON = &H20000
Global Const OFN_NOLONGNAMES = &H40000
' Flags for hook functions and dialog templates
'Global Const OFN_ENABLEHOOK = &H20
'Global Const OFN_ENABLETEMPLATE = &H40
'Global Const OFN_ENABLETEMPLATEHANDLE = &H80
' Windows 95 flags
Global Const OFN_EXPLORER = &H80000
Global Const OFN_NODEREFERENCELINKS = &H100000
Global Const OFN_LONGNAMES = &H200000

' Custom flag combinations
Global Const dhOFN_OPENEXISTING = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or
OFN_HIDEREADONLY
Global Const dhOFN_SAVENEW = OFN_PATHMUSTEXIST Or OFN_OVERWRITEPROMPT Or
OFN_HIDEREADONLY
Global Const dhOFN_SAVENEWPATH = OFN_OVERWRITEPROMPT Or OFN_HIDEREADONLY

Private Declare Function GetActiveWindow Lib "user32" () As Long

Function dhFileDialog( _
Optional strInitDir As String, _
Optional strfilter As String = _
"All files (*.*)" & vbNullChar & "*.*" & _
vbNullChar & vbNullChar, _
Optional intFilterIndex As Integer = 1, _
Optional strDefaultExt As String = "", _
Optional strFileName As String = "", _
Optional strDialogTitle As String = "Open File", _
Optional hwnd As Long = -1, _
Optional fOpenFile As Boolean = True, _
Optional ByRef lngFlags As Long = _
dhOFN_OPENEXISTING) As Variant

' Wrapper function for the GetOpenFileName API function.
' Displays the common open/save as dialog and returns
' the file(s) selected by the user.

' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.

' In:
' strInitDir (Optional)
' Inital directory.
' strFilter (Optional)
' File filter as null delimited/double-null
' terminated string.
' intFilterIndex (Optional, default = 1)
' Initial filter index.
' strDefaultExt (Optional)
' Default file extension if none specified.
' strFilename (Optional)
' Initial file name for dialog.
' strDialogTitle (Optional, default = "Open File")
' Dialog title.
' hwnd (Optional, default = -1)
' Handle of dialog owner window.
' fOpenFile (Optional, default = True)
' If True, displays Open dialog, if False,
' displays Save As dialog.
' lngFlags (Optional)
' Flags for API function (see declarations section).
' Out:
' lngFlags
' Returns flags set by the API function after closing
' the dialog.
' Return Value:
' Name of the file or files chosen by the user.
' Note:
' If you allow multi-select, returned string will
' be the directory name followed by a space-delimited
' list of files.
' Example:
' strFile = dhFileDialog(strFilter:="All files" & _
' vbNullChar & "*.*" & vbNullChar & vbNullChar)

Dim ofn As OPENFILENAME
Dim strFileTitle As String
Dim fResult As Boolean

' Fill in some of the missing arrguments
If strInitDir = "" Then
strInitDir = CurDir
End If
If hwnd = -1 Then
hwnd = GetActiveWindow()
End If

' Set up the return buffers
strFileName = strFileName & String(1000 - Len(strFileName), 0)
strFileTitle = String(1000, 0)

' Fill in the OPENFILENAME structure members
With ofn
.lngStructSize = Len(ofn)
.hWndOwner = hwnd
.strfilter = strfilter
.intFilterIndex = intFilterIndex
.strFile = strFileName
.intMaxFile = Len(strFileName)
.strFileTitle = strFileTitle
.intMaxFileTitle = Len(strFileTitle)
.strTitle = strDialogTitle
.lngFlags = lngFlags
.strDefExt = strDefaultExt
.strInitialDir = strInitDir
.hInstance = 0
.strCustomFilter = String(255, 0)
.intMaxCustFilter = 255
.lngfnHook = 0
End With

' Call the right function
If fOpenFile Then
fResult = GetOpenFileName(ofn)
Else
fResult = GetSaveFileName(ofn)
End If

' If successful, return the filename,
' otherwise return Null
If fResult Then
' Return any flags to the calling procedure
lngFlags = ofn.lngFlags

' Return the result
If (ofn.lngFlags And OFN_ALLOWMULTISELECT) = 0 Then
dhFileDialog = dhTrimNull(ofn.strFile)
Else
dhFileDialog = ofn.strFile
End If
Else
dhFileDialog = Null
End If
End Function

Sub dhTestDialog()

' Test function for dhFileDialog function.

' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.

' In:
' n/a
' Out:
' n/a
' Example:
' Call dhTestDialog()

' Open a file in the current directory
Debug.Print dhFileDialog()

' Open multiple files in the Windows directory
Debug.Print dhFileDialog(strInitDir:="C:\WINDOWS", _
lngFlags:=dhOFN_OPENEXISTING Or OFN_ALLOWMULTISELECT _
Or OFN_EXPLORER)

' Save a file as a text file
Debug.Print dhFileDialog(strfilter:="Text Files" & _
vbNullChar & "*.txt" & vbNullChar & vbNullChar, _
strDialogTitle:="Save As", lngFlags:=dhOFN_SAVENEW, _
fOpenFile:=False)
End Sub

Function GetTextFileName(ByVal strTitle As String) As String

'calls common dialog for test file with title strtitle

Dim strInitDir As String


On Error GoTo ProcError
'strInitDir = GetDrive("****************************") & "\"


GetTextFileName = Nz(dhFileDialog(strInitDir, _
"Text Files *.txt", _
1, _
"txt", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function

ProcError:
MsgBox Error(Err)
Resume ProcExit

End Function

Function SaveTextFile(ByVal strTitle As String, strFileName As String) As
String

'calls common dialog for test file with title strtitle

Dim strInitDir As String
On Error GoTo ProcError
'strInitDir = GetThisPath("export")
SaveTextFile = Nz(dhFileDialog(strInitDir, _
"Text Files *.txt", _
1, _
"txt", _
strFileName, _
strTitle, , _
False, _
OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function

ProcError:
MsgBox Error(Err)
Resume ProcExit

End Function

Function GetAccessDBName(ByVal strTitle As String) As String

'calls common dialog for test file with title strtitle

Dim strInitDir As String
Dim strfilter As String
On Error GoTo ProcError
strfilter = "Access files" & vbNullChar & "*.mdb" & vbNullChar &
vbNullChar

'strInitDir = GetPath(CurrentDb.Name)
GetAccessDBName = Nz(dhFileDialog(strInitDir, _
strfilter, _
0, _
"mdb", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function

ProcError:
MsgBox Error(Err)
Resume ProcExit

End Function

Public Function GetMultipleFiles(ByVal strExtension As String, strTitle As
String) As Variant

'Purpose: Get list of files of a single type to open from user
'Inputs: strExtension - filetype required
' strTitle - dialog title
'Output: variant array of full path file names selected by user
' or Null if none selected



Dim varFiles As Variant 'variant array to hold result of
dialog
Dim strfilter As String 'for use in dialog
Dim lngFlags As Long 'ditto
Dim intFileCount As Integer 'how many files were selected
Dim strArrFiles() As String 'to work with file array
Dim intI As Integer 'counter
Dim strDirectory As String 'to determine full path
Dim intPosStart As Integer 'counters in parsing of file name
string
Dim intPosEnd As Integer


'set constants
lngFlags = dhOFN_OPENEXISTING Or OFN_ALLOWMULTISELECT Or OFN_EXPLORER
strfilter = strExtension & " Files (*." & strExtension & ")" & vbNullChar
& "*." & _
strExtension & vbNullChar & vbNullChar

'get list of files



varFiles = dhFileDialog(strDialogTitle:=strTitle, strfilter:=strfilter,
lngFlags:=lngFlags)
'if no file sselected then return null and exit
If IsNull(varFiles) = True Then
GetMultipleFiles = Null

'otherwise
Else
'dhFileDialog returns
' 1. Directory
' 2. File names
'separated by vbnull chars
'repalce nulls with spaces and trim
'varFiles = dhReplaceAll(varFiles, vbNullChar, " ")
varFiles = drRightTrimNull(varFiles)
varFiles = varFiles & vbNullChar

'determine number of files we are dealing with
intFileCount = dhCountIn(CStr(varFiles), strExtension)

'if just 1 file then simple assignment
If intFileCount = 1 Then
ReDim strArrFiles(0)
strArrFiles(0) = drRightTrimNull(Trim(varFiles))

Else

'redim an array of filenames
ReDim strArrFiles(intFileCount - 1)

'first get the directory (assume first vbnullchar)
intPosStart = InStr(1, varFiles, vbNullChar)
strDirectory = Left(varFiles, intPosStart - 1) & "\"
'now get file names
For intI = 1 To intFileCount
intPosEnd = InStr(intPosStart + 1, varFiles, vbNullChar)
strArrFiles(intI - 1) = drRightTrimNull(Trim(strDirectory & _
Mid(varFiles, intPosStart + 1, intPosEnd -
intPosStart - 1)))
intPosStart = intPosEnd
Next intI
End If
GetMultipleFiles = strArrFiles
End If
End Function

Function GetCSVFileName(ByVal strTitle As String) As String

'calls common dialog for test file with title strtitle

Dim strInitDir As String
Dim strfilter As String
strfilter = "csv files" & vbNullChar & "*.csv" & vbNullChar & vbNullChar

On Error GoTo ProcError

If Len(gstrDir) > 0 Then
strInitDir = gstrDir
Else
'strInitDir = GetPath(CurrentDb.Name) & "\"
End If

GetCSVFileName = Nz(dhFileDialog(strInitDir, _
strfilter, _
1, _
".csv", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function

ProcError:
MsgBox Error(Err)
Resume ProcExit

End Function

Function drRightTrimNull(ByVal strValue As String) As String
'dh function removes all characters to right of first vbnullchar
'this is ok for most purposes but not for file dialog returns
'which include internal null chars!

Dim intI As Long

For intI = Len(strValue) To 1 Step -1
If Mid(strValue, intI, 1) <> vbNullChar Then
drRightTrimNull = Left(strValue, intI)
Exit For
End If

Next intI

End Function

Function SaveCSVFileName(ByVal strTitle As String, ByVal strInitDir As String,
ByVal strFileName As String) As String

'calls common dialog for test file with title strtitle


Dim strfilter As String
strfilter = "csv files" & vbNullChar & "*.csv" & vbNullChar & vbNullChar

On Error GoTo ProcError



SaveCSVFileName = Nz(dhFileDialog(strInitDir, _
strfilter, _
1, _
".csv", strFileName, _
strTitle, , False, _
dhOFN_SAVENEW), "")
ProcExit:
Exit Function

ProcError:
MsgBox Error(Err)
Resume ProcExit

End Function

Function GetXLFileName(ByVal strTitle As String) As String

'calls common dialog for test file with title strtitle

Dim strInitDir As String
Dim strfilter As String
strfilter = "Excel files" & vbNullChar & "*.xls" & vbNullChar &
vbNullChar

On Error GoTo ProcError

If Len(gstrDir) > 0 Then
strInitDir = gstrDir
Else
strInitDir = GetPath(CurrentDb.Name) & "\"
End If

GetXLFileName = Nz(dhFileDialog(strInitDir, _
strfilter, _
1, _
".xls", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function

ProcError:
MsgBox Error(Err)
Resume ProcExit

End Function

Function dhTrimNull(ByVal strValue As String) As String
' Find the first vbNullChar in a string, and return
' everything prior to that character. Extremely
' useful when combined with the Windows API function calls.
Dim intPos As Integer

intPos = InStr(strValue, vbNullChar)
Select Case intPos
Case 0
' Not found at all, so just
' return the original value.
dhTrimNull = strValue
Case 1
' Found at the first position, so return
' an empty string.
dhTrimNull = ""
Case Is > 1
' Found in the string, so return the portion
' up to the null character.
dhTrimNull = Left$(strValue, intPos - 1)
End Select
End Function

Function dhCountIn(strText As String, strFind As String, _
Optional fCaseSensitive As Boolean = False) As Integer
' Determine the number of times strFind appears in strText

Dim intCount As Integer
Dim intPos As Integer
Dim intMode As Integer

' If there's nothing to find, there surely can't be any
' found, so return 0.
If Len(strFind) > 0 Then
' Set up the comparison mode.
If fCaseSensitive Then
intMode = vbBinaryCompare
Else
intMode = vbTextCompare
End If
intPos = 1
Do
intPos = InStr(intPos, strText, strFind, intMode)
If intPos > 0 Then
intCount = intCount + 1
intPos = intPos + Len(strFind)
End If
Loop While intPos > 0
Else
intCount = 0
End If
dhCountIn = intCount
End Function

Public Function GetPath(ByVal strFullPath As String)

'returns path from full path / name
Dim intPos As String
Dim intI As Integer
For intI = Len(strFullPath) To 1 Step -1
If Mid(strFullPath, intI, 1) = "\" Then
intPos = intI
Exit For
End If
Next intI
If intPos = 0 Then
GetPath = ""
Else
GetPath = Left(strFullPath, intPos - 1)
End If
End Function

********************************************************
********************************************************

--
Message posted via AccessMonster.com
http://www.accessmonster.com/Uwe/Forums.aspx/access-modules/200608/1