Attribute VB_Name = "basError"
' From Access 2000 Developer's Handbook
' by Litwin, Getz, and Gilbert. (Sybex)
' Copyright 1999. All Rights Reserved.
    
Option Compare Database
Option Explicit

#Const conFDebug = True

' Name of error form
Private Const conErrorForm As String = "frmError"

Public adhvarLogFile As Variant

Private Declare Function adh_apiLoadLibrary _
 Lib "kernel32" Alias "LoadLibraryA" _
 (ByVal lpLibFileName As String) As Long
Private Declare Function adh_apiGetProcAddress _
 Lib "kernel32" Alias "GetProcAddress" _
 (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function adh_apiGetDiskFreeSpaceEx _
 Lib "kernel32" Alias "GetDiskFreeSpaceExA" _
 (ByVal lpRootPathName As String, _
 curFreeBytesAvailableToCaller As Currency, _
 curTotalNumberOfBytes As Currency, _
 curTotalNumberOfFreeBytes As Currency) As Boolean

Private Declare Function adh_apiGetLogicalDriveStrings _
 Lib "kernel32" Alias "GetLogicalDriveStringsA" _
 (ByVal cchBuffer As Long, ByVal lpszBuffer As String) As Long

Private Declare Function adh_apiGetDriveType _
 Lib "kernel32" Alias "GetDriveTypeA" _
 (ByVal lpszRootPathName As String) As Integer

Private Declare Function adh_apiGetDiskFreeSpace _
 Lib "kernel32" Alias "GetDiskFreeSpaceA" _
 (ByVal lpszRootPathName As Any, ByRef lpSectorsPerCluster As Long, _
 ByRef lpBytesPerSector As Long, ByRef lpFreeClusters As Long, _
 ByRef lpCusters As Long) As Boolean

Public Type adhFreeDiskSpaceType
    strDrive As String
    intType As Integer
    fValid As Boolean
    curFree As Currency
    curSize As Currency
End Type
 
Private Const conDRIVE_REMOVABLE = 2
Private Const conDRIVE_FIXED = 3
Private Const conDRIVE_REMOTE = 4
Private Const conDRIVE_CDROM = 5
Private Const conDRIVE_RAMDISK = 6

Public Declare Function adh_apiGetSystemMetrics _
 Lib "user32" Alias "GetSystemMetrics" _
 (ByVal nIndex As Integer) As Integer

Public Const conSM_CYCAPTION = &H4&

Public Type adhMEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type

Public Declare Sub adh_apiGlobalMemoryStatus _
 Lib "kernel32" Alias "GlobalMemoryStatus" _
 (lpmstMemStat As adhMEMORYSTATUS)

Public Const conNoMap = 0
Public Const conExitSub = 1
Public Const conResumeNext = 2
Public Const conResume = 3
Public Const conResumeMax = 3

Public Function adhHandleError() As Integer
    Static fInError As Boolean
    
    ' Make sure we're not current in the
    ' error handler otherwise we'll end up
    ' with an infinite loop
    If fInError Then
        MsgBox "Already in error handler!", vbCritical
        Stop
    Else
        fInError = True
        
        ' Make sure error form isn't open
        If CurrentProject.AllForms(conErrorForm) _
         .IsLoaded Then
            DoCmd.Close acForm, conErrorForm
        End If
        
        ' Open the form in dialog mode--the form will
        ' use the LastError method of the global
        ' SavedErrors collection to get its information
        On Error Resume Next
        DoCmd.OpenForm FormName:=conErrorForm, _
         WindowMode:=acDialog
        
        ' Set return value and close the form
        If Err.Number = 0 Then
            adhHandleError = Forms(conErrorForm).Action
            DoCmd.Close acForm, conErrorForm
        End If
        
        ' Reset flag
        fInError = False
    End If
End Function



Public Function adhButtonMap(ByVal bytButton1 As Byte, _
 ByVal bytButton2 As Byte, ByVal bytButton3 As Byte) As Long
    ' This routine builds a long from three byte values. The
    ' byte order in the long is 0 K3 K2 K1. All unused buttons
    ' should be set to zero. Each byte represents one of the
    ' resume constants defined by adhResume*.
    '
    ' From Microsoft Access 2000 Developer's Handbook
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '   bytButton1, bytButton2, bytButton3 should be a constant
    '   defined by the adhResume error constants
    ' Out:
    '   A long representing the buttons passed to adhErrorHandler
    
    Debug.Assert (bytButton1 >= 0)
    Debug.Assert (bytButton1 <= conResumeMax)
    Debug.Assert (bytButton2 >= 0)
    Debug.Assert (bytButton2 <= conResumeMax)
    Debug.Assert (bytButton3 >= 0)
    Debug.Assert (bytButton3 <= conResumeMax)
    adhButtonMap = bytButton1 Or bytButton2 * 2 ^ 8 Or bytButton3 * 2 ^ 16
End Function

Function adhGetButtonMap(ByVal lngButtonMap, _
 ByVal intButton As Integer) As Integer
 
    Dim lngIndex As Long
    Const conBitmask = 2 ^ 8 - 1
    
    lngIndex = 2 ^ (8 * (intButton - 1))
    adhGetButtonMap = (lngButtonMap And conBitmask * lngIndex) \ lngIndex
End Function

Function adhDebugMessageBox(ByVal varMessage As Variant, _
 strCaller As String) As Integer
    ' Produces a message box if the conditional compilation
    ' constant conFDebug is defined
    '
    ' From Microsoft Access 2000 Developer's Handbook
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '   varMessage      Message to report
    '   strCaller       Calling procedure
    ' Out:
    '   Message
    adhDebugMessageBox = True
#If conFDebug Then
    adhDebugMessageBox = (MsgBox(CStr(varMessage), _
     vbOKCancel Or vbQuestion, "Debug: " & strCaller) _
     = vbOK)
#End If
End Function

Function adhCleanup()
    ' Return the application to normal programming mode.
    ' Reinstate screen updating,
    ' reset the cursor to its normal state,
    ' and reset warnings.

    On Error GoTo adhCleanupErr

    Application.Echo True
    DoCmd.Hourglass False
    DoCmd.SetWarnings True
    Application.SetOption "Built-In Toolbars Available", True

adhCleanupDone:
    On Error GoTo 0
    Exit Function

adhCleanupErr:
    MsgBox "Error " & Err.Number & ": " & Err.Description, _
     vbCritical, "adhCleanup"
    Resume adhCleanupDone
End Function


Sub adhFillErrors()
    ' Builds a table of all of the error messages
    ' known to Access
    '
    ' From Microsoft Access 2000 Developer's Handbook
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' Out:
    '     Filled in table tblError
    Dim db As Database
    Dim rst As Recordset
    Dim i As Long
    Dim qry As QueryDef
    Dim strNoSuchError As String
    
    strNoSuchError = Error$(32767)
    
    Set db = CurrentDb()
    Set rst = db.OpenRecordset("tblError")
    Set qry = db.CreateQueryDef("", "delete * from tblError")
    qry.Execute
    For i = 0 To 32767
        If Error$(i) <> strNoSuchError Then
            rst.AddNew
            rst("Number") = i
            rst("Description") = Error$(i)
            rst("Icon") = vbExclamation
            rst("ButtonSet") = vbOKOnly
            rst("KeyMap") = adhButtonMap(conExitSub, conNoMap, conNoMap)
            rst.Update
        End If
    Next i
    rst.Close
    db.Close
End Sub

Public Sub adhFreeDiskSpace(atyp() As adhFreeDiskSpaceType)
    ' Gets the free disk space on all drives
    '
    ' From Microsoft Access 2000 Developer's Handbook
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '    An array of user-defined types
    ' Out:
    '    The same array expanded and filled in
    Dim strDrives As String
    Dim i As Long
    Dim iBeg As Long
    Dim iEnd As Long
    Dim lngSectorsPerCluster As Long
    Dim lngBytesPerSector As Long
    Dim lngFreeClusters As Long
    Dim lngClusters As Long
    Dim iatyp As Long
    Dim lngRet As Long
    Dim fRet As Boolean
    
    On Error GoTo adhFreeDiskSpaceErr
    
    For i = 256 To 65535 Step 256
        strDrives = Space$(i)
        lngRet = adh_apiGetLogicalDriveStrings(Len(strDrives), strDrives)
        If lngRet < Len(strDrives) Then
            Exit For
        End If
    Next i
    
    Erase atyp
    
    iBeg = 1
    iEnd = InStr(iBeg, strDrives, Chr$(0))
    Do Until iEnd = iBeg
        ReDim Preserve atyp(UBound(atyp) + 1)
        iatyp = UBound(atyp)
        atyp(iatyp).strDrive = Mid$(strDrives, iBeg, iEnd - iBeg)
        atyp(iatyp).intType = adh_apiGetDriveType(atyp(iatyp).strDrive)
        fRet = DiskSpace(atyp(iatyp).strDrive, atyp(iatyp).curSize, atyp(iatyp).curFree)
        If fRet Then
            atyp(iatyp).fValid = True
        Else
            atyp(iatyp).curFree = 0
            atyp(iatyp).curSize = 0
            atyp(iatyp).fValid = False
        End If
        iBeg = iEnd + 1
        iEnd = InStr(iBeg, strDrives, Chr$(0))
    Loop
    Exit Sub
adhFreeDiskSpaceErr:
    Select Case Err.Number
    Case 9  'Subscript out of range
        ReDim atyp(0)
        Resume Next
    Case Else
        Stop
    End Select
End Sub

Public Function adhDriveType(ByVal intType As Integer) As String
    ' Returns the drive type based on the number
    ' returned from an API call
    '
    ' From Microsoft Access 2000 Developer's Handbook
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '    Drive type number
    ' Out:
    '    Drive type string
    Select Case intType
    Case 0
        adhDriveType = "Unknown"
    Case 1
        adhDriveType = "Unknown"
    Case conDRIVE_REMOVABLE
        adhDriveType = "Removable"
    Case conDRIVE_FIXED
        adhDriveType = "Fixed"
    Case conDRIVE_REMOTE
        adhDriveType = "Remote"
    Case conDRIVE_CDROM
        adhDriveType = "CD-ROM"
    Case conDRIVE_RAMDISK
        adhDriveType = "RAM Disk"
    Case Else
        Debug.Assert (False)
    End Select
End Function

Private Function IsGetDiskFreeSpaceExOK() As Boolean
    Dim hModule As Long
    Dim lngAddress As Long
    
    hModule = adh_apiLoadLibrary("kernel32.DLL")
    If hModule <> 0 Then
        lngAddress = adh_apiGetProcAddress(hModule, "GetDiskFreeSpaceExA")
    End If
    IsGetDiskFreeSpaceExOK = (lngAddress <> 0)
End Function

Private Function DiskSpace(strDrive As String, _
 curTotal As Currency, curFree As Currency) As Boolean

    If IsGetDiskFreeSpaceExOK() Then
        Dim curFreeToMe As Currency
        Dim curTotalBytes As Currency
        Dim curFreeBytes As Currency
    
        If adh_apiGetDiskFreeSpaceEx(strDrive, _
         curFreeToMe, curTotalBytes, curFreeBytes) Then
            curTotal = curTotalBytes * 10000
            curFree = curFreeBytes * 10000
            DiskSpace = True
        End If
    Else
        Dim lngSectorsPerCluster As Long
        Dim lngBytesPerSector As Long
        Dim lngNumberOfFreeClusters As Long
        Dim lngTotalNumberOfClusters As Long
        
        If adh_apiGetDiskFreeSpace(strDrive, lngSectorsPerCluster, _
         lngBytesPerSector, lngNumberOfFreeClusters, lngTotalNumberOfClusters) Then
            curTotal = lngBytesPerSector * lngSectorsPerCluster * lngTotalNumberOfClusters
            curFree = lngBytesPerSector * lngSectorsPerCluster * lngNumberOfFreeClusters
            DiskSpace = True
        End If
    End If
End Function