'#### Sample Code Use In Your Application:

Option Compare Database
Option Explicit

Sub Test()
    Dim objAPP1 As clsExtra: Set objAPP1 = New clsExtra
    objAPP1.Visible: objAPP1.LogScreens 'while testing
    
    'logon and test for successful logon
    If Not objAPP1.Logon(APP1) Then
        'ideally handle failure gracefully
        Set objAPP1 = Nothing
        MsgBox "error: logon to APP1 failed"
    Else
        Debug.Print "Logon ok to APP1"
        'do stuff
    End If

End Sub

'#### Module: modGeneral (paste into a module)

Option Compare Database
Option Explicit

'used by OSUserName, gets the currently logged on windows user
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    
'used by PasswordInputbox
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SetTimer& Lib "user32" (ByVal hwnd&, ByVal nIDEvent&, ByVal uElapse&, ByVal lpTimerFunc&)
Private Declare Function KillTimer& Lib "user32" (ByVal hwnd&, ByVal nIDEvent&)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const NV_INPUTBOX As Long = &H5000&
Private MWindowTitle As String

'self explanitory
Public Function GetPath() As String
    GetPath = CurrentProject.Path
End Function

'log a message (with timestamp) to a log file
Public Sub LogString(ByVal strText As String, Optional ByVal blnNew As Boolean = False)
    Dim strFile As String
    Dim lngFile As Long
    strFile = Application.CurrentProject.Path & "\log.txt"
    lngFile = FreeFile
    If blnNew then Open strFile For Output As #lngFile Else Open strFile For Append As #lngFile
    Print #lngFile, Now() & " - " & strText
    Close #lngFile
End Sub

'returns the network login name
Public Function OSUserName() As String
    Dim strUsername As String
    Dim lngLen As Long: lngLen = 255
    Dim lngX As Long
    strUsername = String(254, 0)
    lngX = apiGetUserName(strUsername, lngLen)
    OSUserName = IIf(lngX > 0, Left$(strUsername, lngLen - 1), vbNullString)
End Function

'used by PasswordInputbox
Private Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    Dim EditHwnd As Long
    EditHwnd = FindWindowEx(FindWindow("#32770", MWindowTitle), 0, "Edit", "")
    Call SendMessage(EditHwnd, EM_SETPASSWORDCHAR, Asc("*"), 0)
    KillTimer hwnd, idEvent
End Sub

'creates an inputbox that masks input/password with *
Public Function PasswordInputbox(ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal Default As String, Optional ByVal XPos As Long, Optional ByVal YPos As Long, Optional ByVal HelpFile As Long, Optional ByVal Context As Long) As String     Dim ret As String
    MWindowTitle = IIf(Title = "", "Password Required", Title)
    SetTimer 0, 0, 1, AddressOf TimerProc
    PasswordInputbox = InputBox(Prompt, MWindowTitle, Default, XPos, YPos, HelpFile, Context)
End Function

'very rouch code
'pass this function an empty array, sql query and the columns you want from a table
'and the function will return the data as a single dimension array, the return value will be the number of elements
Public Function GetArrayFromSQL(ByVal strSQL As String, ByRef varArray As Variant, ByVal varField As Variant) As Long
On Error GoTo Error_GetStringArray
    Dim lngField As Long
    lngField = IIf(IsArray(varField), 1, 0)
    If lngField <> 0 Then lngField = UBound(varField)
    Debug.Print "lngfield=" & lngField
    GetArrayFromSQL = 0
    Dim db As Database
    Set db = CurrentDb
    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
    Dim L As Long
    Dim lngRecordCount As Long
    With rs
        If Not (.BOF And .EOF) Then
            .MoveLast
            lngRecordCount = .RecordCount
            ReDim Preserve varArray(lngRecordCount * (lngField + 1))
            .MoveFirst
            While Not .EOF
                GetArrayFromSQL = GetArrayFromSQL + 1
                For L = 0 To lngField
                    If lngField = 0 Then
                        varArray(GetArrayFromSQL) = rs.Fields(varField)
                    Else
                        varArray((lngRecordCount * L) + GetArrayFromSQL) = rs.Fields(varField(L))
                    End If
                Next L
                .MoveNext
            Wend
        End If
    End With
Exit_GetStringArray:
    rs.Close
    Set rs = Nothing    'Deassign all objects.
    Set db = Nothing
    Exit Function
Error_GetStringArray:
    MsgBox "Error_GetStringArray" & vbCrLf & "strSQL=" & strSQL & vbCrLf & "varField=" & varField
    Resume Exit_GetStringArray
    'Resume
End Function

'#### Class: clsExtra

Option Compare Database
Option Explicit

'    REQUIRES
'modGeneral.PasswordInputbox
'modGeneral.OSUserName

'    PUBLIC
'Me.CheckScreen - checks for string, returns blnFound ... USE RETURN VALUE ... IF! THEN! ELSE!
'Me.GetScreen - grabs entire screen as string
'Me.GetString - reads string from screen
'Me.Logon - common logon procedures
'Me.LogScreens - activates automatic screen captures
'Me.Send - move, send text or commands
'Me.Visible - hide or show screen

'module/class level variables
Private mSystem As Object
Private mSessions As Object
Private mSession As Object
Private mstrExtraFile As String
Private mLogScreens As Boolean
Private mLogScreenFile As String
Private mEnumSessionType As enumLogon

'when adding/updating a new system include in enum then include a logon and logoff component below
'where possible teach your applications how to logoff gracefully from any point
Public Enum enumLogon
    APP1 = 1
    APP2 = 2
    '..etc
End Enum

'by default clsExtra.GetString returns a trimmed string
'these enum's handle some basic conversion
Public Enum enumGetString
    strTrimmed = 0
    strUnTrimmed = 1
    lngNumber = 2
    curNumber = 3
    dblNumber = 4
    dtDateFormat = 5
    dtTimeFormat = 6
End Enum

'used for setting focus back to access
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

'used as a crude name to get a random session name
Private Declare Function GetTickCount Lib "kernel32" () As Long

'path where attachmate expects sessions by default
Private Const EXTRA_PATH = "C:\Program Files\Attachmate\sessions\"

'when a new instance of the class is created, create a new session
Private Sub Class_Initialize()
On Error GoTo errorhandler
    mLogScreens = False
    mLogScreenFile = Application.CurrentProject.Path & "\screen.txt"
    Set mSystem = CreateObject("EXTRA.System")
    CheckObjectExists mSystem, "System"
    Set mSessions = mSystem.Sessions
    CheckObjectExists mSessions, "Sessions collection"
    mstrExtraFile = EXTRA_PATH & Right(CStr(GetTickCount), 8) & ".EDP"
    Debug.Print mstrExtraFile
    KillEDP
    On Error Resume Next
    FileCopy EXTRA_PATH & "session1.edp", mstrExtraFile
    On Error GoTo 0
    Set mSession = GetObject(mstrExtraFile)
    Me.Visible (False)
Exit Sub
errorhandler:
Cleanup
End Sub

'hide/show the session
Public Sub Visible(Optional ByVal blnVisible As Boolean = True)
On Error Resume Next
    mSession.Visible = blnVisible
    'necessary as changing visibility sets focus to attachmate extra (even if hidden)
    SetForegroundWindow (Application.hWndAccessApp)
End Sub

'disconnect and re-connect the session
private Sub ReConnect()
    mSession.Connected = False
    mSession.Connected = True
End Sub

'gracefully logoff
'called when closing a session or before re-logging onto an existing session
Private Sub Logoff()
    Dim lCount As Long
    lCount = 0
    Select Case mEnumSessionType
        Case APP1
            Me.Send "<Clear>"
            Me.Send "/logoff <enter>"
        Case APP2
            While Me.CheckScreen("SUBSCREEN", 1, 2, False) And lCount < 7
                Me.Send ("<pf3>")
                lCount = lCount + 1
            Wend
            If Me.CheckScreen("ENTRYSCREEN", 1, 2, False) Then
                Me.Send ("<pf3>")
            Else
                Debug.Print "clsExtra.Class_Terminate: APP2 - failed to exit cleanly."
            End If
        Case Else
            Debug.Print "clsExtra.Class_Terminate: WARNING no logoff defined for current session"
    End Select
    mEnumSessionType = 0
End Sub

'close session when this goes out of scope or set to nothing
Private Sub Class_Terminate()
    Call Logoff 'gracefully logout if already logged in
    Call Cleanup
End Sub

Private Sub Cleanup()
On Error Resume Next
    mSession.closeex 9
    Set mSession = Nothing
    Set mSessions = Nothing
    Set mSystem = Nothing
    KillEDP
End Sub

'creates an object and outputs error if object does not exist
Private Sub CheckObjectExists(ByRef obj As Object, ByVal strText As String)
    If (obj Is Nothing) Then MsgBox "clsExtra.CheckObjectExists: Could not create the " & _
        strText & " object."
End Sub

'logon to a session, we could handle this in code rather than the class but if creating
'several projects this may be useful code to keep, and it keeps code clearer
'also we want to handle logoff gracefully as simply disconnecting sessions is poor form
'and may use up your logons, locking you out of a system
'since handling logoff we may as well handle logon also
Public Function Logon(ByVal enumType As enumLogon, Optional ByVal strUser As String = "", _
        Optional ByVal strPassword As String = "") As Boolean
    If mEnumSessionType <> 0 Then
        Call Logoff
        Call ReConnect
    End If
    If Not ValidUserID(strUser) Then strUser = modGeneral.OSUserName
    If Not ValidPassword(strPassword) Then
        Do
            strUser = InputBox("UserID?", "UserID Required", strUser)
            If strUser = "" Then
                Debug.Print "cancelled at username prompt"
                Logon = False
                Exit Function
            End If
        Loop While Not ValidUserID(strUser)
        Do
            strPassword = modGeneral.PasswordInputbox("Password?")
            If strPassword = "" Then
                Debug.Print "cancelled at password prompt"
                Logon = False
                Exit Function
            End If
        Loop While Not ValidPassword(strPassword)
    End If
    If Not Me.CheckScreen("===>", 23, 6) Then
        Call Reconnect
        Call CheckScreenOrDie("===>", 23, 6)
    End If
    'moved individual logon's to seperate private functions to keep code seperate and purposes clear
    'using enum for simplicity outside the class/black box, even though it makes within more complex
    Select Case enumType
        Case APP1
            Logon = APP1Logon(strUser, strPassword)
        Case APP2
            Logon = APP2Logon(strUser, strPassword)
        Case Else
            Logon = False
            MsgBox "clsExtra.Logon Select Case enumType Case Else should never be reached!"
    End Select
    If Logon = True Then
        mEnumSessionType = enumType
        Debug.Print "clsExtra.Logon: Success enumLogon(" & mEnumSessionType & ")"
    End If
End Function


Private Function APP1Logon(Optional ByVal strUser As String = "", _
                    Optional ByVal strPassword As String = "") As Boolean
    Me.Send "LOGON APP1 <enter>"
    Call CheckScreenOrDie("CURRENT PASSWORD : ==>", 7, 11)
    Me.Send strUser, 6, 35, True
    Me.Send strPassword, 7, 35, True
    Me.Send "<enter>"
    APP1Logon = Me.CheckScreen("** SIGNON PROCEDURES COMPLETE **", 4, 27)
End Function


Private Function APP2Logon(Optional ByVal strUser As String = "", _
                    Optional ByVal strPassword As String = "") As Boolean
    Me.Send "LOGON APP2 <enter>"
    Call CheckScreenOrDie("CURRENT PASSWORD : ==>", 7, 11)
    Me.Send strUser, 6, 35, True
    Me.Send strPassword, 7, 35, True
    Me.Send "<enter>"
    APP2Logon = Me.CheckScreen("USER LOGGED ON", 28, 2)
End Function


'not used here but if you don't want to handle usernames/passwords due to security
'reasons within your vba code/access application you could use something like this
Private Sub ManualLogon(ByVal strtype As String, Optional ByVal lngDelaySeconds As Long = 30)
    MsgBox "After pressing OK you have " & CStr(lngDelaySeconds) & " seconds to logon."
    Me.Visible
    Wait lngDelaySeconds
    Me.Visible (False)
End Sub

'remove the session file
Private Sub KillEDP()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(mstrExtraFile) Then
        On Error Resume Next
        Kill mstrExtraFile
        On Error GoTo 0
    End If
End Sub

'wait safely
Private Sub Wait(Optional ByVal lngMaxDelaySeconds As Long = 10)
On Error GoTo errorhandler
    Dim strXStatus(9) As String
    strXStatus(0) = "Ready"
    strXStatus(1) = "User entered an invalid number"
    strXStatus(2) = "User entered non-numeric data in a numeric field"
    strXStatus(3) = "User typed in a protected field"
    strXStatus(4) = "User typed past the end of the field"
    strXStatus(5) = "Host is busy"
    strXStatus(6) = "Function is invalid"
    strXStatus(7) = "Unauthorized printer requested"
    strXStatus(8) = "System locked during processing"
    strXStatus(9) = "An invalid character was entered"
    Dim lngErrorStatus As Long
    Dim strErrorStatus(3) As String
    strErrorStatus(0) = "No Error"
    strErrorStatus(1) = "Configuration mismatch occurred"
    strErrorStatus(2) = "Communications hardware problem occurred"
    strErrorStatus(3) = "A problem with the physical connection occurred"
    Dim lngConnectionStatus As Long
    Dim strConnectionStatus(3) As String
    strConnectionStatus(0) = "No Connection"
    strConnectionStatus(1) = "Session is connected to an application"
    strConnectionStatus(2) = "Control program owned"
    strConnectionStatus(3) = "Session is not connected to an application"
    Dim lngXstatus As Long
    Dim blnStatusOk As Boolean
    Dim s As String 'status string for debugging
    Dim dtWaitUntil As Date
    dtWaitUntil = DateAdd("s", lngMaxDelaySeconds, Now)
    Dim blnWaitTimeExceeded As Boolean
    Do
        Do While mSession.Screen.OIA.Xstatus <> 0
            DoEvents
        Loop
        
        lngXstatus = mSession.Screen.OIA.Xstatus
        lngErrorStatus = mSession.Screen.OIA.ErrorStatus
        lngConnectionStatus = mSession.Screen.OIA.ConnectionStatus

        blnStatusOk = (lngXstatus = 0) And (lngErrorStatus = 0) And (lngConnectionStatus = 1)
        blnWaitTimeExceeded = Now > dtWaitUntil
        
        s = strXStatus(lngXstatus) & ", " & strErrorStatus(lngErrorStatus) & ", " & _
                strConnectionStatus(lngConnectionStatus)
        'Debug.Print (S)
    Loop Until blnStatusOk Or blnWaitTimeExceeded
    
    If Not blnStatusOk Then
        MsgBox s
        MsgBox "something is screwed up"
        'Stop
    End If
Exit Sub
errorhandler:
Cleanup
End Sub


'returns the current screen as a string
Public Function GetScreen() As String
    Dim lngMaxRow As Long
    Dim lngMaxCol As Long
    Dim s() As String
    Dim lngRow As Long
    lngMaxRow = mSession.Screen.ROWS
    lngMaxCol = mSession.Screen.COLS
    ReDim s(lngMaxRow)
    For lngRow = 1 To lngMaxRow Step 1
        s(lngRow) = Me.GetString(lngRow, 1, lngMaxCol, strUnTrimmed)
    Next lngRow
    GetScreen = Join(s, vbCrLf)
End Function

'saves a screen to a file
Private Sub WriteScreenToFile()
    If mLogScreens Then
         Dim lngFile As Long
         Dim strHeader As String
         Dim strFooter As String
         Dim lngMaxCol As Long
         lngMaxCol = mSession.Screen.COLS
         strHeader = "START " & Now
         strFooter = "END"
         lngFile = FreeFile
         Open mLogScreenFile For Append As #lngFile
         Print #lngFile, Pad(strHeader, "*", lngMaxCol) & vbCrLf & GetScreen & vbCrLf & _
                Pad(strFooter, "*", lngMaxCol) & vbCrLf
         Close #lngFile
    End If
End Sub

'returns string, by default trimmed
'optionally returns variant formatted correctly as per enumType requested
'note for date/time you need to specify strDateFormat
'note for numeric or date/time invalid data will be returned as 0 or null
'pass bln BYREFblnValidData BYREF to determine if this is the case
Public Function GetString(ByVal intRow As Integer, ByVal intCol As Integer, _
        ByVal intLength As Integer, Optional ByVal enumDataType As enumGetString, _
        Optional ByVal strDateFormat = "", Optional ByRef BYREFblnValidData As Boolean = True) As Variant
    Dim s As String
    Dim V As Variant
    Dim sDay, sMonth, sYear As String
    Dim sHour, sMinute, sSecond, sAMPM As String
    Dim L As Long
    s = mSession.Screen.GetString(intRow, intCol, intLength)
    BYREFblnValidData = True
    Select Case enumDataType
        Case strUnTrimmed
            V = s
        Case lngNumber
            If IsNumeric(Trim(s)) Then
                V = CLng(Trim(s))
            Else
                BYREFblnValidData = False
                V = CLng(0)
            End If
        Case curNumber
            If IsNumeric(Trim(s)) Then
                V = CCur(Trim(s))
            Else
                BYREFblnValidData = False
                V = CCur(0)
            End If
        Case dblNumber
            If IsNumeric(Trim(s)) Then
                V = CDbl(Trim(s))
            Else
                BYREFblnValidData = False
                V = CDbl(0)
            End If
        Case dtDateFormat
            If strDateFormat = "" Then
                Debug.Print "clsExtra.GetString enumType dtDateFormat: strDateFormat must be provided!"
                BYREFblnValidData = False
                V = Null
            Else
                For L = 1 To Len(strDateFormat)
                    Select Case Mid(strDateFormat, L, 1)
                    Case "D"
                        sDay = sDay & Mid(s, L, 1)
                    Case "M"
                        sMonth = sMonth & Mid(s, L, 1)
                    Case "Y"
                        sYear = sYear & Mid(s, L, 1)
                    End Select
                Next L
                If Len(sYear) = 2 Then sYear = "20" & sYear
                
                s = sYear & "-" & sMonth & "-" & sDay
                If IsDate(s) Then
                    V = CDate(s)
                Else
                    BYREFblnValidData = False
                    V = Null
                End If
            End If
        Case dtTimeFormat
            If strDateFormat = "" Then
                Debug.Print "clsExtra.GetString enumType dtTimeFormat: strDateFormat must be provided!"
                BYREFblnValidData = False
                V = Null
            Else
                For L = 1 To Len(strDateFormat)
                    Select Case Mid(strDateFormat, L, 1)
                    Case "S"
                        sSecond = sSecond & Mid(s, L, 1)
                    Case "N"
                        sMinute = sMinute & Mid(s, L, 1)
                    Case "H"
                        sHour = sHour & Mid(s, L, 1)
                    Case "A"
                        sAMPM = sAMPM & Mid(s, L, 1)
                    End Select
                Next L
                If Trim(sSecond) = "" Then sSecond = "0"
                s = sHour & ":" & sMinute & ":" & sSecond & " " & sAMPM
                If IsDate(s) Then
                    V = CDate(s)
                Else
                    BYREFblnValidData = False
                    V = Null
                End If
            End If
        Case Else
            'default is trimmed string
            V = Trim(s)
    End Select
    GetString = V
End Function

'pads a string with a character
Private Function Pad(ByVal strString As String, ByVal strChar As String, _
                    ByVal lnglength As Long) As String
    Dim L As String
    Dim s As String
    Dim c As String
    c = Mid(strChar, 1, 1)
    L = lnglength - Len(strString) - 2
    If IsOdd(L) Then
        L = L - 1
        s = c
    End If
    L = L / 2
    Pad = String(L, c) & Chr(32) & strString & Chr(32) & String(L, c) & s
End Function

'simple way to determine if a number is odd or even
Private Function IsOdd(ByVal lngNumber As Long) As Boolean
    IsOdd = IIf((lngNumber Mod 2) = 0, False, True)
End Function

'used to check if you are on the right screen, like a glorified getstring
'make use of the return value, handle incorrect screens gracefully
'DO NOT WRITE A WRAPPER FUNCTION TO HALT ON ERROR, INSTEAD HANDLE PROPERLY IN CODE/APP
'by default waits for string and waits 10 seconds
'optionally change wait time or do not wait
Public Function CheckScreen(ByVal strTest As String, ByVal lngRow As Long, lngCol As Long, _
        Optional ByVal blnWaitIfRequired As Boolean = True, _
        Optional ByVal lngWaitTimeSeconds = 10) As Boolean
    Dim blnFound As Boolean: blnFound = False
    Dim lngWaitTime As Long
    Call Wait 'wait until system is responsive
    blnFound = (GetString(lngRow, lngCol, Len(strTest), strUnTrimmed) = strTest)
    If (Not blnFound) And (blnWaitIfRequired) Then
        lngWaitTime = lngWaitTimeSeconds * 1000
        blnFound = mSession.Screen.waitforstring(strTest, lngRow, lngCol, , , lngWaitTime)
    End If
    If (Not blnFound) Then Debug.Print "clsExtra.CheckScreen NOTFOUND (" & lngRow & "," & lngCol & _
            "): '" & strTest & "'"
    CheckScreen = blnFound
    Call WriteScreenToFile
End Function

'internal wrapper to checkscreen function, do not use outside the class as it is not safe
'preferrable outside the class that people handle (gracefully) when valid screen not found
Private Sub CheckScreenOrDie(ByVal strTest As String, ByVal lngRow As Long, lngCol As Long, _
        Optional ByVal blnWaitIfRequired As Boolean = True, Optional ByVal lngWaitTimeSeconds = 10)
    If Not CheckScreen(strTest, lngRow, lngCol, blnWaitIfRequired, lngWaitTimeSeconds) Then
        MsgBox "clsExtra.CheckScreen ERROR (" & lngRow & "," & lngCol & "): '" & strTest & "'"
        Stop
    End If
End Sub

'sends text/commands to screen
'by default uses SendKeys but where possible make use of Putstring as it offers
'performance benefits
Public Function Send(ByVal strText As String, Optional ByVal lngRow As Long = 0, _
                    Optional ByVal lngCol As Long = 0, Optional ByVal blnPutString = False)
    If blnPutString Then
        mSession.Screen.PutString strText, lngRow, lngCol
    Else
        If (lngCol > 0) And (lngRow > 0) Then mSession.Screen.MoveTo lngRow, lngCol
        If (strText <> "") Then mSession.Screen.SendKeys strText
        Call Wait
    End If
End Function

'toggle module variable mLogScreens to save copies of screens everytime we do a checkscreen
Public Sub LogScreens(Optional ByVal strLogScreenFile As String = "", _
        Optional ByVal blnLogScreens As Boolean = True)
    If strLogScreenFile <> "" Then mLogScreenFile = strLogScreenFile
    mLogScreens = blnLogScreens
End Sub

'valid password length - very basic validation
Private Function ValidPassword(ByVal strPassword As String) As Boolean
    Dim i As Integer
    ValidPassword = False
    i = Len(strPassword)
    If (i <= 8) And (i >= 6) Then ValidPassword = True
    If (ValidPassword = False) Then Debug.Print "clsExtra.ValidPassword: failure"
End Function

'valid username length and starting character combinations - very basic validation
Private Function ValidUserID(ByVal strUsername As String) As Boolean
    Dim c As String
    ValidUserID = False
    c = UCase(Mid(strUsername, 1, 1))
    If ((c = "A") Or (c = "B")) And (Len(strUsername) = 7) Then ValidUserID = True
    If (UCase(Mid(strUsername, 1, 3)) = "CDE") And (Len(strUsername) = 7) Then ValidUserID = True
    If (UCase(Mid(strUsername, 1, 4)) = "FGHI") And (Len(strUsername) = 7) Then ValidUserID = True
    If (ValidUserID = False) Then Debug.Print "clsExtra.ValidUserID: failure"
End Function