(1) Declare WinAPI
(2) Write public functions
Option Compare Database
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation _
As String, ByVal lpFile As String, ByVal lpParameters _
As String, ByVal lpDirectory As String, ByVal nShowCmd _
As Long) As Long
'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName _
Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter 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
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function GetSaveFileNameA Lib "comdlg32.dll" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Public Function SaveAsCommonDialog(iOfficeVersion As OfficeProduct, _
strForm As Form, _
Optional sTitle = "Save File", _
Optional sDefaultDir As String, _
Optional filename As String = "") As String
Const clBufferLen As Long = 255
Dim OFName As OPENFILENAME, sBuffer As String * clBufferLen
Dim sFilter As String
On Error GoTo ExitFunction
OFName.lStructSize = Len(OFName)
OFName.hwndOwner = strForm.hwnd ' GetActiveWindow 'or Me.hwnd in VB
'OFName.hInstance = 0 'or App.hInstance in VB
'If Len(sFilter) Then
' OFName.lpstrFilter = sFilter
'Else
' OFName.lpstrFilter = "Text Files (*.txt)" & Chr$(0) & "*.txt" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
'End If
Select Case iOfficeVersion
Case OfficeProduct.Excel2007Only
sFilter = "Excel 2007 Workbooks (*.xlsx)" & Chr(0) & "*.xlsx" & Chr(0) & _
"Excel 2003 Workbooks (*.xls)" & Chr(0) & "*.xls" & Chr(0)
Case OfficeProduct.Access2007Only
sFilter = "Access Databases 2007(*.acdb*)" & Chr(0) & "*.acdb" & Chr(0) & _
"Access Databases 2003 (*.MDB)" & Chr(0) & "*.MDB & Chr(0)"
Case Else
sFilter = "All Files (*.*)" & Chr(0) & "*.*"
End Select
OFName.lpstrFilter = sFilter
OFName.nFilterIndex = 1
' set file to initialDir and Filename (Note - need to retain length of sBuffer)
If filename <> "" Then
Dim initialFilePath As String
If Right(sDefaultDir, 1) = "\" Then
initialFilePath = sDefaultDir & filename
Else
initialFilePath = sDefaultDir & "\" & filename
End If
sBuffer = initialFilePath & (Right(sBuffer, Len(sBuffer) - Len(initialFilePath)))
End If
OFName.lpstrFile = sBuffer
OFName.nMaxFile = clBufferLen 'Set max number of characters
OFName.lpstrFileTitle = sBuffer
OFName.nMaxFileTitle = clBufferLen 'Set max number of characters
'Set the initial directory
If Len(sDefaultDir) Then
OFName.lpstrInitialDir = sDefaultDir
Else
OFName.lpstrInitialDir = CurDir$
End If
OFName.lpstrTitle = sTitle
OFName.Flags = 0
'debug.Print "sBuffer: " & sBuffer
'Show dialog
If GetSaveFileNameA(OFName) Then
SaveAsCommonDialog = Left$(OFName.lpstrFile, InStr(1, OFName.lpstrFile, Chr(0)) - 1)
Else
SaveAsCommonDialog = ""
End If
ExitFunction:
On Error GoTo 0
End Function
Function getWindowsUserId() As String
' Returns the network login name.
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = GetUserName(strUserName, lngLen)
If lngX <> 0 Then
getWindowsUserId = Left$(strUserName, lngLen - 1)
Else
getWindowsUserId = "Unknown"
End If
End Function
Public Function GetWorkstationId() As String
' Retrieve the name of the computer.
Const acbcMaxComputerName = 15
Dim strBuffer As String
Dim lngLen As Long
strBuffer = Space(acbcMaxComputerName + 1)
lngLen = Len(strBuffer)
If CBool(GetComputerName(strBuffer, lngLen)) Then
GetWorkstationId = Left$(strBuffer, lngLen)
Else
GetWorkstationId = ""
End If
End Function
Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
Function APIGetOpenFileNameCD(iOfficeVersion As OfficeProduct, _
strForm As Form, Optional _
InitialFileName As String) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = strForm.hwnd
Select Case iOfficeVersion
Case OfficeProduct.Excel2007Only
sFilter = "Excel 2007 Workbooks (*.xlsx)" & Chr(0) & "*.xlsx" & Chr(0) & _
"Excel 2003 Workbooks (*.xls)" & Chr(0) & "*.xls" & Chr(0)
Case OfficeProduct.Access2007Only
sFilter = "Access Databases 2007(*.acdb*)" & Chr(0) & "*.acdb" & Chr(0) & _
"Access Databases 2003 (*.MDB)" & Chr(0) & "*.MDB & Chr(0)"
Case Else
sFilter = "All Files (*.*)" & Chr(0) & "*.*"
End Select
'sFilter = "All Files (*.*)" & Chr(0) & "*.*" & Chr(0) & _
"JPEG Files (*.JPG)" & Chr(0) & "*.JPG" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
If Len(InitialFileName) > 0 Then
OpenFile.lpstrInitialDir = InitialFileName
Else
OpenFile.lpstrInitialDir = "C:\"
End If
OpenFile.lpstrTitle = "Select a file name"
OpenFile.Flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
'MsgBox "A file was not selected!", vbInformation, _
"Select a file using the Common Dialog DLL"
Exit Function
Else
APIGetOpenFileNameCD = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function
Public Function OpenPDFFile(ByVal strFileName) As Boolean
Dim lngErr As Long
'Dim objShell As Object
'objShell.ShellExecute
Const SW_SHOWNORMAL = 1
lngErr = ShellExecute(0, "OPEN", strFileName, vbNullString, vbNullString, SW_SHOWNORMAL)
OpenPDFFile = lngErr > 32
End Function
