VBA Operating System Functions and Features

[GKJR]

I was always under the impression that VBA is only able to interact with MS Office applications. I recently learned that there are some operating system functions and features that are accessible with VBA, but I don't know anything about them. Could someone point me in the right direction so I can reasearch this further? Any general hints or tips about this would also be appreciated.
Thanks

[NeoPa]

This is complicated for two reasons :

1. Basic (and derivative) languages store and manipulate strings differently from how C (and derivative) languages do it.
   • In the former a string is represented by a length value at the start point of the string followed by that number of ASCII characters in successive memory locations.
   • In the latter the string starts with the list od ASCII characters in successive locations and terminated with a Null character (whose value is 0).
   
   The Windows O/S is basically written in, and to interact with, the latter. IE. Strings passed by a call from Basic type languages will not be recognised for what they are and this must be handled in code that calls, and receives data back from calls, to the O/S.
2. There appears to be no reference to the O/S so any procedures that need to be called also need to be declared manually in your code.

In case some example code helps here is a module I use for a limited number of calls that I use in my work from time-to-time.

Option Compare Database
Option Explicit

'Windows API Variable Prefixes
'cb = Count of Bytes (32-bit)
'w  = Word (16-bit)
'dw = Double Word (32-bit)
'lp = Long Pointer (32-bit)
'b  = Boolean (32-bit)
'h  = Handle (32-bit)
'ul = Unsigned Long (32-bit)

Public Const conHKCR = &H80000000
Public Const conHKCU = &H80000001
Public Const conHKLM = &H80000002
Public Const conHKU = &H80000003
Public Const conStandardRightsAll = &H1F0000
Public Const conReadControl = &H20000
Public Const conStandardRightsRead = (conReadControl)
Public Const conRegSz = 1
Public Const conOK = 0&
Public Const conKeyQueryValue = &H1
Public Const conKeySetValue = &H2
Public Const conKeyCreateLink = &H20
Public Const conKeyCreateSubKey = &H4
Public Const conKeyEnumerateSubKeys = &H8
Public Const conKeyNotify = &H10
Public Const conSynchronise = &H100000
Public Const conRegOptionNonVolatile = 0
Public Const conKeyAllAccess = ((conStandardRightsAll _
                              Or conKeyQueryValue _
                              Or conKeyCreateSubKey _
                              Or conKeyEnumerateSubKeys _
                              Or conKeyNotify _
                              Or conKeyCreateLink) _
                            And (Not conSynchronise))
Public Const conKeyRead = ((conReadControl _
                         Or conKeyQueryValue _
                         Or conKeyEnumerateSubKeys _
                         Or conKeyNotify) _
                       And (Not conSynchronise))

Private Const conUseShowWindow = &H1&
Private Const conNormalPriority = &H20&
Private Const conInfinite = -1&
Private Const conWinVis = &H10000000
Private Const conGWLStyle = -&H10&

Private Type typStartupInfo
    cbLen As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCount As Long
    dwYCount As Long
    dwFillAtt As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdIn As Long
    hStdOut As Long
    hStdErr As Long
End Type

Private Type typProcInfo
    hProc As Long
    hThread As Long
    dwProcID As Long
    dwThreadID As Long
End Type

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
    Alias "RegOpenKeyExA" (ByVal hKey As Long, _
                           ByVal lpSubKey As String, _
                           ByVal ulOptions As Long, _
                           ByVal samDesired As Long, _
                           phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) _
                             As Long
Private Declare Function RegQueryValueExStr Lib "advapi32.dll" _
    Alias "RegQueryValueExA" (ByVal hKey As Long, _
                              ByVal lpValueName As String, _
                              ByVal lpReserved As Long, _
                              lpType As Long, _
                              ByVal lpData As String, _
                              lpcbData As Long) As Long

Private Declare Function CreateProcessA Lib "kernel32" ( _
    ByVal lpApplicationName As Long, _
    ByVal lpCommandLine As String, _
    ByVal lpProcessAttributes As Long, _
    ByVal lpThreadAttributes As Long, _
    ByVal bInheritHandles As Long, _
    ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, _
    ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As typStartupInfo, _
    lpProcessInformation As typProcInfo) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
    ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long

Private Declare Function FindWindowEx Lib "user32" _
    Alias "FindWindowExA" (ByVal hwndParent As Long, _
                           ByVal hwndChildAfter As Long, _
                           ByVal lpszClass As String, _
                           ByVal lpszWindow As String) As Long
Private Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" (ByVal hwndID As Long, _
                            ByVal nIndex As Long) As Long
Private Declare Function IsMaximised Lib "user32" _
    Alias "IsZoomed" (ByVal hWnd As Long) As Boolean
Private Declare Function IsMinimised Lib "user32" _
    Alias "IsIconic" (ByVal hWnd As Long) As Boolean
Private Declare Function ShowWindow Lib "user32" _
                         (ByVal hWnd As Long, _
                          ByVal nCmdShow As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" _
    Alias "GetUserNameA" (ByVal lpBuffer As String, _
                          lpnSize As Long) As Long

Public Function RegRead(ByVal lngHive As Long, _
                        ByVal strKey As String, _
                        ByVal strValue As String) As Variant
    Dim intIdx As Integer, intHK As Integer
    Dim strWork As String
    Dim lngRet As Long, cbLen As Long, lngHKey As Long, lngType As Long

    RegRead = Null
    strKey = strKey & Chr(0)
    lngRet = RegOpenKeyEx(lngHive, strKey, 0, conKeyRead, lngHKey)
    If lngRet = conOK Then
        'Create buffer to store value
        strWork = Space(255)
        cbLen = 255
        lngRet = RegQueryValueExStr(lngHKey, _
                                    strValue, _
                                    0&, _
                                    lngType, _
                                    strWork, _
                                    cbLen)
        RegRead = Left(strWork, cbLen - 1)
        If Len(RegRead) = 254 Then RegRead = Null
        'Close key
        Call RegCloseKey(lngHKey)
    End If
End Function

'ShellWait() executes a command synchronously (Shell() works asynchronously).
Public Sub ShellWait(strCommand As String, _
                     Optional intWinStyle As Integer = vbNormalFocus)
    Dim objProcInfo As typProcInfo
    Dim objStart As typStartupInfo
    Dim lngRet As Long

    'Initialize the typStartupInfo structure:
    With objStart
        .cbLen = Len(objStart)
        .dwFlags = conUseShowWindow
        .wShowWindow = intWinStyle
    End With
    'Start the shelled application:
    Call CreateProcessA(lpApplicationName:=0&, _
                        lpCommandLine:=strCommand, _
                        lpProcessAttributes:=0&, _
                        lpThreadAttributes:=0&, _
                        bInheritHandles:=1&, _
                        dwCreationFlags:=conNormalPriority, _
                        lpEnvironment:=0&, _
                        lpCurrentDirectory:=0&, _
                        lpStartupInfo:=objStart, _
                        lpProcessInformation:=objProcInfo)
    'Wait for the shelled application to finish
    Call WaitForSingleObject(hHandle:=objProcInfo.hProc, _
                             dwMilliseconds:=conInfinite)
    Call CloseHandle(hObject:=objProcInfo.hProc)
End Sub

Public Function DBWindowVisible() As Boolean
    Dim hWnd As Long, lngStyle As Long

    'Get handle of MDIClient window of current application
    hWnd = FindWindowEx(hWndAccessApp, 0, "MDIClient", vbNullString)
    'Within that, find child window matching class Odb (database window)
    hWnd = FindWindowEx(hWnd, 0, "Odb", vbNullString)
    'Default result to False in case handle wasn't found
    DBWindowVisible = False
    If (hWnd) Then
        'Having found window, check the visibility flag of its style value
        lngStyle = GetWindowLong(hWnd, conGWLStyle)
        DBWindowVisible = ((lngStyle And conWinVis) = conWinVis)
    End If
End Function

'AppWindowState() returns and/or sets the app's window state.
Public Function AppWindowState(appVar As Application, _
                               Optional strSet As String = "Read") As String
    Dim blnVisible As Boolean

    With appVar
        AppWindowState = "Restore"
        If IsMaximised(.hWndAccessApp) Then AppWindowState = "Maximise"
        If IsMinimised(.hWndAccessApp) Then AppWindowState = "Minimise"
        If strSet = "Read" Then Exit Function
        If strSet <> AppWindowState Then
            blnVisible = .Visible
            If Not blnVisible Then .Visible = True
            Select Case strSet
            Case "Maximise"
                Call .RunCommand(acCmdAppMaximize)
            Case "Minimise"
                Call .RunCommand(acCmdAppMinimize)
            Case "Restore"
                Call .RunCommand(acCmdAppRestore)
            End Select
            If Not blnVisible Then .Visible = False
        End If
    End With
End Function

'GetLogonName() determines the logon ID of the current user.
Public Function GetLogonName() As String
    Dim lngMax As Long
    Dim strBuffer As String

    lngMax = &HFF
    strBuffer = String(lngMax, vbNullChar)
    Call GetUserName(lpBuffer:=strBuffer, lpnSize:=lngMax)
    GetLogonName = Trim(Left(strBuffer, lngMax - 1))
End Function

'GetUserObject() returns an IADs object representing either the LDAP: string
'  if passed, or the logged-on user otherwise.
Public Function GetUserObject(Optional ByVal strDN As String = "") As Object
    On Error Resume Next
    'If incorrect strDN passed then returned value will be a Nothing.
    If strDN > "" Then
        Set GetUserObject = GetObject("LDAP://" & strDN)
    Else
        strDN = "LDAP://OU=MyBusiness," & _
                GetObject("LDAP://RootDSE").Get("rootDomainNamingContext")
        Set GetUserObject = ProcessIAD(GetObject(strDN), GetLogonName())
    End If
End Function

'ProcessIAD() is called recursively and returns an object only when it is a user
'  that matches strUser.
Private Function ProcessIAD(ByRef iadVar As Object, strUser As String) As Object
    Dim iadWork As Object

    With iadVar
        Select Case IADType(iadVar)
        Case "User"
            If .sAMAccountName = strUser Then Set ProcessIAD = iadVar
            Exit Function
        Case "organizationalUnit"
            For Each iadWork In iadVar
                Set ProcessIAD = ProcessIAD(iadWork, strUser)
                If Not ProcessIAD Is Nothing Then Exit Function
            Next iadWork
        End Select
    End With
End Function

'IADType() returns whether the IAD should be treated as a container
'  (organizationalUnit), a user (user), or simply ignored (group).
Private Function IADType(iadVar As Object) As String
    Dim varWork As Variant

    With iadVar
        Call .GetInfo
        For Each varWork In .Get("objectClass")
            Select Case varWork
            Case "user", "group", "organizationalUnit"
                IADType = varWork
                Exit For
            End Select
        Next varWork
    End With
End Function

'ShowIADs() shows all users, groups and containers of the AD from strRoot.
Public Sub ShowIADs(Optional ByRef iadVar As Object, _
                    Optional ByVal strRoot As String = "")
    Dim iadWork As Object
    Dim strWork As String

    If iadVar Is Nothing Then
        strWork = "LDAP://" & _
                  strRoot & _
                  "OU=MyBusiness," & _
                  GetObject("LDAP://RootDSE").Get("rootDomainNamingContext")
        Set iadVar = GetObject(strWork)
    End If
    With iadVar
        strWork = IADType(iadVar)
        If strWork > "" Then
            Debug.Print strWork & "," & _
                        IIf(strWork = "user", .sAMAccountName, "") & "#" & _
                        .distinguishedName & "~";
        End If
        Select Case strWork
        Case "user"
            Exit Sub
        Case "organizationalUnit"
            For Each iadWork In iadVar
                Call ShowIADs(iadWork)
            Next iadWork
        End Select
    End With
End Sub

[GKJR]

Thanks for the info NeoPa. I've been looking into your code and it is a bit beyond my capabilities. I tried doing some research and I found that Windows has functions that are available for "middleware " software, which I take it are your references to kernel32, advapi32.dll, and user32. These must be library references with system defined functions that are available for programmers, but I wouldn't even know what they're used for or how they would help. I'm going to set it aside for now. All in due time I guess.

I do have a specific question though. At the beginning of your module in the Constant declarations why do the values take the format they they're in with the "&" and "-" and "H" followed by a series of numbers?

[NeoPa]

The only time a "-" appears is when the value is negative, but let's deal with the other two which are less clear :

1. &H --> as a prefix indicates the following data should be treated as a hex(adecimal) value. You may notice letters up to "F" in the values which are valid hex digits.
2. & --> as a suffix means that the literal value preceeding it is of type Long.