Need to get info from one spread sheet into another 1

[justmefjs]

I'm trying to automate the import of standardized info on one sheet of several different types of input forms. I've standardized the data I need onto a single sheet, and have a macro that will import it from a known spread sheet, but is there a way to invoke the open dialog box with out having it carry out it's open proceedure so I can collect the file name and directory to use in my macro? I used to know how, but I'm about 5 years rusty, and that was office 95.

 

[DomThePom]

Copy the code below into a new module - hopefully should be self explanatory - if not post again!

Option Explicit

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

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

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

' 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&quot
' 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("Zur GGL\09 Testing\01 UnitTest\Testing Input Output Files & Raw Data&quot & "\"


GetTextFileName = nz(dhFileDialog(strInitDir, _
"Text Files *.txt", _
1, _
"txt", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "&quot
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&quot
SaveTextFile = nz(dhFileDialog(strInitDir, _
"Text Files *.txt", _
1, _
"txt", _
strFileName, _
strTitle, , _
False, _
OFN_PATHMUSTEXIST), "&quot
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 = ThisWorkbook.Path
GetAccessDBName = nz(dhFileDialog(strInitDir, _
strfilter, _
0, _
"mdb", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "&quot
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 & &quot" & 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, " &quot
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 = ThisWorkbook.Path & "\"
End If

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

ProcError:
MsgBox Error(Err)
Resume ProcExit


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), "&quot
ProcExit:
Exit Function

ProcError:
MsgBox Error(Err)
Resume ProcExit


End Function









Function GetDirectory(strTitle As String)
'Opens a Treeview control that displays the directories in a computer

Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo

szTitle = strTitle
With tBrowseInfo
'.hWndOwner = Me.hwnd
.lpszTitle = lstrcat(szTitle, "&quot
.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




Public Function GetDrive(ByVal strPartPath As String) As String



Dim strPath As String
Dim hFileNew As Long 'Handle on new file
Dim varDrive As Variant
Dim intI As Integer

'get file handles

hFileNew = FreeFile

varDrive = Array("d", "e", "f", "g", "h", "i", "j", "k", "l", "m", _
"n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "c&quot
GetDrive = ""

For intI = 0 To UBound(varDrive)
On Error Resume Next
strPath = varDrive(intI) & ":\" & strPartPath & "\" & "zzTest.txt"

'open up files
Open strPath For Output As hFileNew

If Err = 0 Then
Close hFileNew
Kill strPath
GetDrive = varDrive(intI) & ":\" & strPartPath
Exit Function
End If

Next intI






End Function

Public Function GetThisPath(ByVal strType As String)
'returns path from full path / name
Dim strFullPath As String
Dim intPos As String
Dim intI As Integer
Dim b1done As Boolean

GetThisPath = ThisWorkbook.Path & "\" & strType





End Function

 

[justmefjs]

Sorry I should have been more specific. I am using office 2000 now, and just need the call to open the get file dialog with out it opening a file. I remember it used to be var = call , but I don't remember the call. Does any one have hat info? Thanks for all your help!

 

[ssVBAdev]

Is this what you are looking for...

strFileName = Application.GetOpenFilename(fileFilter:="Excel Worksheet (*.xls), *.xls&quot

********************
What's the best way to get the answers you need?? See FAQ222-2244 for details!

 

[justmefjs]

Bingo...thank you.