Common WinAPI functionality

(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