Below is a copy of a module I have that allows reading and extracting DoD CAC card information.
'DESCRIPTION:
'~~~~~~~~~~~~~
'Code to interact with CAC card
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' HISTORY:
'~~~~~~~~~
' Multiple vbScript sources - Microsoft, US Navy, USAF
' Toby Yadon adapted from vbScript to VBA
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'POC:
' Toby Yadon
'********************************************************************************
'Revision History: *
'*******************
' This version 1.5 is to correct a typo in the members of function.
'****************
' The initial version was written by Jeff Bowles, Microsoft Consulting Services. 2/2/06
' The script was modified by SSC-SD Gary Delgado. on 4/1/06 version 1.0 for.
'
'********************************************************************************
' Title: UPN_APT Logon script. *
'********************************
' Purpose:
' This script was developed to assist system administrators in implementing CLO. When the
' user logons on to the domain this script will check the users profile for a userPrincipalName(UPN) attribute.
' If the UPN is of 10 digits with @Mil then the script will not run, if the user is a member of any
' domain administrator account the script will not run.
'
' if any of the above is false then the script will run and notify the user that their EDIPI from the CAC
' must be registered in order to perform CLO.
' The script will then retrieve the information from the users CAC and publish it to their AD UPN.
'
' Currently this script does not publish the EmployeeID to AD this will be done later.
'**********************************************************************************
' Descripton: *
'**************
' This script uses ADSI bind to user and CAPICOM to read the CAC
' Capicom reads the CAC and only reads the default certificate on the card.
'***********************************************************************************
'Force explicit declaration of all variables.
Option Compare Database
Option Explicit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' DESCRIPTION:
'~~~~~~~~~~~~~
' This module contains API calls and functions to extract computer and user information
' from windows operating system when the CAC card functionality isn't available
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~
'DECLARATIONS:
'~~~~~~~~~~~~~
Private Const C_MODULE_NAME = "modCAC"
Public Const gcfErrHandlerrors As Boolean = True 'define a global error handler constant
' If gcfErrHandlerrors Then On Error GoTo ErrHandler ' toggle error handler on an off application wide
' API declarations
'~~~~~~~~~~~~~~~~~~~~~~~~~
' ~~ GET COMPUTER NAME ~~
'~~~~~~~~~~~~~~~~~~~~~~~~~
#If VBA7 Then
Private Declare PtrSafe Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#Else
Private Declare Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#End If
'~~~~~~~~~~~~~~~~~~~~~~~
' ~~ GET USER NAME ~~
'~~~~~~~~~~~~~~~~~~~~~~~
#If VBA7 Then
Declare PtrSafe Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" _
(ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
#Else
Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" _
(ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
#End If
Private sMsg As String
Public Enum CACStoreType
CA = 1
My = 2
Root = 3
End Enum
Public Enum CACInfo
Default ' = First MI Last / EDI Nbr
Email ' = objUser.mail
DisplayName ' = objUser.DisplayName
GradeRank ' = objuser.personaltitle
FirstName ' = objUser.givenname
LastName ' = objUser.sn
MI ' = objuser.initials
EDINbr ' = objUser.samAccountName
CompanyName ' = objUser.company
DepartmentName ' = objUser.department
ORGName ' = objUser.o
OSC ' = objuser.physicalDeliveryOfficeName
StateName ' = objUser.st
UserSharePointWWW ' = objuser.wWWHomePage
WorkPhone ' = objuser.telephoneNumber
employeeType ' = objuser.employeeType (C = Civ, O = Off, E = Enl)
JobTitle ' = objuser.Title
postalCode ' = objuser.postalCode
UserHomeDirectory ' = objuser.homeDirectory
UserHomeDrive ' = objuser.homeDrive
DistinguishedName ' = objUser.DistinguishedName (array of information)
End Enum
'******************************************************************************
'NOT USING THIS FUNCTION WILL POPULATE THE EMPLOYEE ID WITH UPN...
'******************************************************************************
' Function : ValidEDIPI
' Synopsis : CHecks employeeID attribute for Numeric 10 digit number
' Parameter : EmployeeID string from AD.
' Return : Boolean value.
'******************************************************************************
Function ValidEDIPI(strEmployeeID As Variant) As Boolean
ValidEDIPI = True
sMsg = "strEmployeeID = " & strEmployeeID
Select Case VarType(strEmployeeID)
Case 2, 3, 4, 5, 6, 8, 14, 20 'numeric
'sMsg = sMsg & " is Long Integer"
Select Case LenB(strEmployeeID)
Case 10 'Checking for 10 digits
ValidEDIPI = True
Case Else
ValidEDIPI = False
sMsg = sMsg & " Fails Check for 10 digit EDI " & vbCrLf
End Select
Case Else 'Single
ValidEDIPI = False
sMsg = IIf(sMsg = "strEmployeeID = " & strEmployeeID, sMsg, sMsg & " AND ") & " Fails Check for Numeric "
End Select
If sMsg <> ("strEmployeeID = " & strEmployeeID) Then modProgress.UpdateText sMsg
modProgress.CloseProgress
End Function 'ValidEDIPI
Function CACInfo(Optional CACReader As CACInfo = Default)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' DESCRIPTION:
'~~~~~~~~~~~~~
' This function returns information extracted from CAC / LDAP. By default _
returns the users full name and EDI number.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Requires the following ENUM to be declared at the top of the module!
'Public Enum CACInfo
' Default ' = First MI Last / EDI Nbr
' Email ' = objUser.mail
' DisplayName ' = objUser.DisplayName
' GradeRank ' = objuser.personaltitle
' FirstName ' = objUser.givenname
' LastName ' = objUser.sn
' MI ' = objuser.initials
' EDINbr ' = objUser.samAccountName
' CompanyName ' = objUser.company
' DepartmentName ' = objUser.department
' ORGName ' = objUser.o
' OSC ' = objuser.physicalDeliveryOfficeName
' StateName ' = objUser.st
' UserSharePointWWW ' = objuser.wWWHomePage
' WorkPhone ' = objuser.telephoneNumber
' employeeType ' = objuser.employeeType (C = Civ, O = Off, E = Enl)
' JobTitle ' = objuser.Title
' postalCode ' = objuser.postalCode
' UserHomeDirectory ' = objuser.homeDirectory
' UserHomeDrive ' = objuser.homeDrive
' DistinguishedName ' = objUser.DistinguishedName (array of information)
'End Enum
'~~~~~~~
' INPUT:
'~~~~~~~
' None.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' OUTPUT:
'~~~~~~~~
' First Middle last name / EDI Number of person on the computer.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' SAMPLE CALL:
'~~~~~~~~~~~~~
' strUserName = CACInfo() ' Return first mi last / EDI Nbr
' strUserName = CACInfo(OSC) ' Return Organizational office symbol
' strUserName = CACInfo(DisplayName) ' Return display name for Outlook
' strUserName = CACInfo(eMail) ' Return official email address
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' HISTORY:
'~~~~~~~~~
' YADON - 9/5/2013 - Wrote function.
' YADON - 9/5/2013 - Wrote function.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'DECLARATIONS
'~~~~~~~~~~~~
Const C_PROC_NAME = "CACInfo"
If gcfErrHandlerrors Then On Error GoTo ErrHandler
Dim ADSysInfo, objUser ' Leave undefined types
Dim iloop As Integer
Dim UserInfo() As String
Set ADSysInfo = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & ADSysInfo.UserName)
Select Case CACReader
Case EDINbr '
CACInfo = objUser.samAccountName
Case CompanyName '
CACInfo = objUser.Company
Case DepartmentName '
CACInfo = objUser.department
Case ORGName '
CACInfo = objUser.o
Case OSC '
CACInfo = objUser.physicalDeliveryOfficeName
Case GradeRank '
CACInfo = objUser.personaltitle
Case FirstName '
CACInfo = objUser.givenname
Case LastName '
CACInfo = objUser.sn
Case MI '
CACInfo = objUser.initials
Case DisplayName '
CACInfo = objUser.DisplayName
Case DistinguishedName '
CACInfo = objUser.DistinguishedName ' Contains array of information
Case StateName '
CACInfo = objUser.st
Case UserSharePointWWW '
CACInfo = objUser.wWWHomePage
Case WorkPhone '
CACInfo = objUser.telephoneNumber
Case employeeType '
CACInfo = objUser.employeeType ' C ' = Civ, O ' = Off, E ' = Enl
Case JobTitle '
CACInfo = objUser.Title
Case postalCode '
CACInfo = objUser.postalCode
Case Email '
CACInfo = objUser.mail
Case UserHomeDirectory '
CACInfo = objUser.homeDirectory
Case UserHomeDrive '
CACInfo = objUser.homeDrive
Case Else
UserInfo() = Split(objUser.CN, ".")
Select Case UBound(UserInfo())
Case 4
CACInfo = UserInfo(1) & " " & UserInfo(2)
CACInfo = Trim(CACInfo & " " & UserInfo(0))
CACInfo = Trim(CACInfo & " / " & UserInfo(3) & UserInfo(4))
Case 3
CACInfo = UserInfo(1) & " " & UserInfo(2)
CACInfo = Trim(CACInfo & " " & UserInfo(0))
CACInfo = Trim(CACInfo & " / " & UserInfo(3))
Case 2
For iloop = LBound(UserInfo()) To UBound(UserInfo())
CACInfo = Trim(CACInfo & Space(1) & UserInfo(iloop))
Next
End Select
End Select
Select Case Len(CACInfo)
Case 0
CACInfo = fGetUser()
End Select
WrapUp:
Exit Function
'ERROR HANDLER:
'~~~~~~~~~~~~~
ErrHandler:
Select Case Err
Case -
2147023564
CACInfo = fGetUser()
Case Else
MsgBox "Error: " & Err.Number & "-" & Err.Description
End Select
GoTo WrapUp
End Function
Public Function IsBlank(arg As Variant) As Boolean
' By using IsBlank() we avoid having to test both for Null and empty string.
'-----------------------------------------------------------------------------
' True if the argument is Nothing, Null, Empty, Missing or an empty string .
'-----------------------------------------------------------------------------
' So now I don’t have to worry so much about the type of the variable I’m testing
' when I want to know if it contains useful data:
'
' ' Here assume that CustomerReference is a control on a form.
' If IsBlank(CustomerReference) Then
' MsgBox "Customer Reference cannot be left blank."
' End If
Select Case VarType(arg)
Case vbDate
IsBlank = Not IsDate(arg)
Case vbEmpty
IsBlank = True
Case vbNull
IsBlank = True
Case vbString
IsBlank = (LenB(arg) = 0) ' faster than = ""
Case vbObject
IsBlank = (arg Is Nothing)
Case Else
IsBlank = IsMissing(arg)
End Select
End Function
Public Function CloseObjects(strContainerName As String, intContainerType As AcObjectType)
' Close all open database objects.
Dim dbs As Database, ctr As Container
Dim intX As Integer
Set dbs = DBEngine(0)(0)
Set ctr = dbs.Containers(strContainerName)
For intX = ctr.Documents.count - 1 To 0 Step -1
DoCmd.Close intContainerType, ctr.Documents(intX).Name
Next intX
Set dbs = Nothing
End Function
Public Function NulltoZero(arg As Variant) As Variant
'vbEmpty 0 Empty (uninitialized)
'vbNull 1 Null (no valid data)
'vbInteger 2 Integer
'vbLong 3 Long integer
'vbSingle 4 Single-precision floating-point number
'vbDouble 5 Double-precision floating-point number
'vbCurrency 6 Currency value
'vbDate 7 Date value
'vbString 8 String
'vbObject 9 Object
'vbError 10 Error value
'vbBoolean 11 Boolean value
'vbVariant 12 Variant (used only with arrays of variants)
'vbDataObject 13 A data access object
'vbDecimal 14 Decimal value
'vbByte 17 Byte value
'vbLongLong 20 LongLong integer (Valid on 64-bit platforms only.)
'vbUserDefinedType 36 Variants that contain user-defined types
'vbArray 8192 Array
Select Case VarType(arg)
Case vbDate
NulltoZero = Not IsDate(arg)
Case vbEmpty
NulltoZero = True
Case vbNull
NulltoZero = True
Case vbString
NulltoZero = (LenB(arg) = 0) ' faster than = ""
Case vbObject
NulltoZero = (arg Is Nothing)
Case Else
NulltoZero = IsMissing(arg)
End Select
If IsNull(arg) Then arg = 0
If IsEmpty(arg) Then arg = 0
NulltoZero = arg
End Function
Public Function NulltoZero2(Item As Variant) As Variant
If IsNull(Item) Then Item = 0
If IsEmpty(Item) Then Item = 0
NulltoZero2 = Item
End Function
Public Function NulltoZeroString(Item As Variant) As Variant
If IsNull(Item) Then Item = ""
If IsEmpty(Item) Then Item = ""
NulltoZeroString = Item
End Function
Public Function ReturnWord(Sentence As String, _
Optional sDelimeter As String = " ", _
Optional iWord As Integer = 0) As String
Dim vArray() As String
vArray = Split(Sentence, sDelimeter) ' <- USUALLY A ZERO BASED LIST
Select Case iWord 'return the REQUESTED value
Case Is <= LBound(vArray()) ' First word
ReturnWord = vArray(LBound(vArray))
Case Is >= UBound(vArray()) ' Last word
ReturnWord = vArray(UBound(vArray))
Case Else ' SPECIFIED word
ReturnWord = vArray(iWord)
End Select
End Function
Function OrdinalSuffix(ByVal lNum As Long, Optional bWithNbr As Boolean = True) As String
Const cSfx = "stndrdthththththth" ' 2 char suffixes
Dim N As Long
N = Abs(lNum Mod 100)
Select Case N
Case 0
OrdinalSuffix = ""
Case (N >= 10 And N <= 19), (N Mod 10 = 0)
OrdinalSuffix = "th"
Case Else
OrdinalSuffix = Mid(cSfx, ((Abs(N) Mod 10) * 2) - 1, 2)
End Select
Select Case bWithNbr
Case True
OrdinalSuffix = Format(lNum, "#,##0") & OrdinalSuffix
Case False
OrdinalSuffix = OrdinalSuffix ' OrdinalSuffix already has Suffix
End Select
End Function
Function OrdinalDate(Optional myDate As Variant)
If IsBlank(myDate) Then myDate = Date
OrdinalDate = Format(myDate, "MMMM") & Space(1) & OrdinalSuffix(Day(myDate))
End Function
Public Function fGetFilePart(Optional strin As String, _
Optional strPart As String = "FileName") As String
'<HEADER INFO>*************************************************************
'Code Name: Lib_file.fGetFilePart
'Plain English Name: Function Get File Part from full name and path
'Basic Purpose: Function returns a File Part from full name and path
'Input Data: strIn = String to process, strPart = part to return
'Output Data: string of Path, Filename, Extension, Stem, or Drive
'Calling Routines: multiple
'FlowChart Reference: N/A
'CSCI: N/A
'</HEADER INFO>************************************************************
'Public Const PathSeparator = "\" ' Windows Path Separator set in module top
'Public Const gcfErrHandlerrors = True ' Global Const to toggle error handlers on and off
'Public Const #DEBUG_ = True ' Global Const to toggle Debug printing on and off
'INITIALIZE:
'~~~~~~~~~~
If gcfErrHandlerrors Then On Error GoTo ErrHandler
Dim sMsg As String
'MAIN BODY:
'~~~~~~~~~
If IsBlank(strin) Then strin = DBEngine(0)(0).Name
Select Case strPart
Case "filename", "f" ' Full Filename
If (InStr(strin, ".") = 0 And InStr(strin, PathSeparator) = 0) Then GoTo WrapUp ' Handle no extension
fGetFilePart = VBA.Mid(strin, VBA.InStrRev(strin, PathSeparator) + 1, VBA.InStrRev(strin, "."))
Case "path", "p" 'Full Path Name
If InStr(strin, PathSeparator) = 0 Then GoTo WrapUp ' PreEmpt no Path
fGetFilePart = VBA.Left(strin, VBA.InStrRev(strin, PathSeparator))
Case "extension", "x", "e", "ext" ' File Extension
If InStr(strin, ".") = 0 Then GoTo WrapUp ' Handle no extension
fGetFilePart = VBA.Right(strin, VBA.Len(strin) - VBA.InStrRev(strin, "."))
Case "stem", "s" ' Core Filename no extension
If InStr(strin, ".") = 0 Then GoTo WrapUp ' PreEmpt no extension
fGetFilePart = VBA.Mid(strin, VBA.InStrRev(strin, PathSeparator) + 1, InStrRev(strin, ".") - VBA.InStrRev(strin, "\") - 1)
If UBound(Split(strin, ".")) >= 2 Then ' Notify user of multiple extensions
MsgBox fGetFilePart & " has had the last extension removed.", vbInformation, "The string processed returned more than one extension!"
End If ' Notify user of multiple extensions
Case "drive", "d" ' System Drive found on
If InStr(strin, ":") = 0 Then GoTo WrapUp ' Handle Drive Separator
fGetFilePart = VBA.Left(strin, VBA.InStr(strin, ":") - 1)
Case "?", "Help"
sMsg = ""
MsgBox sMsg
Case Else
GoTo WrapUp
End Select
If IsBlank(fGetFilePart) Then
MsgBox strin, vbCritical, "Error Encountered attempting to process input"
End If
'CODE SNIPPETS
'~~~~~~~~~~~~~
#If DEBUG_ Then
Debug.Print (fGetFilePart)
#End If
'WRAP-UP
'~~~~~~~
WrapUp:
Exit Function
'ERROR HANDLER:
'~~~~~~~~~~~~~
ErrHandler:
Select Case Err
Case Else
MsgBox "Error: " & Err.Number & "-" & Err.Description
End Select
GoTo WrapUp
End Function
Public Function OpenReportAllowed(repName$, _
Optional viewMode As AcView = acViewNormal, _
Optional filtName$ = "", _
Optional wherecond$ = "" _
) As Boolean
' return True if report runs normally
' return False if some error (e.g. No Data) is generated
OpenReportAllowed = False
On Error Resume Next
DoCmd.OpenReport repName$, viewMode, filtName$, wherecond$
If Err = 0 Then OpenReportAllowed = True
End Function
Public Function FormHasData(frm As Form) As Boolean
'Purpose: Return True if the form has any records (other than new one).
' Return False for unbound forms, and forms with no records.
'Note: Avoids the bug in Access 2007 where text boxes cannot use:
' [Forms].[Form1].[Recordset].[RecordCount]
'Forms use expression in the Control Source of the text box:
' =IIf(FormHasData([Form]), Sum([Amount]), 0)
' Use the HasData property property, specifically for this purpose.
'Reports use expression in the Control Source of the text box:
'So, instead of:
' =Sum([Amount])
'use:
' =IIf([Report].[HasData], Sum([Amount]), 0)
On Error Resume Next 'To handle unbound forms.
FormHasData = (frm.Recordset.RecordCount <> 0&)
End Function
Public Function NoData(rpt As Report)
'Purpose: Called by report's NoData event.
'Usage: =NoData([Report])
'
http://allenbrowne.com/ser-43.html
Dim strCaption As String 'Caption of report.
strCaption = rpt.Caption
If strCaption = vbNullString Then
strCaption = rpt.Name
End If
DoCmd.CancelEvent
MsgBox "There are no records to include in report """ & _
strCaption & """.", vbInformation, "No Data..."
End Function
Function fOSMachineName() As String
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' DESCRIPTION:
'~~~~~~~~~~~~~
' This function returns the Computer Name using windows API system calls.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' INPUT:
'~~~~~~~
' None.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' OUTPUT:
'~~~~~~~~
' Computer name of from windows.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' SAMPLE CALL:
'~~~~~~~~~~~~~
' strComputerName = fOSMachineName()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' HISTORY:
'~~~~~~~~~
'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'DECLARATIONS
'~~~~~~~~~~~~
Const C_PROC_NAME = "fOSMachineName"
Dim lngLen As Long, lngX As Long
Dim strCompName As String
'Returns the computername
'INITIALIZE
'~~~~~~~~~~
If gcfErrHandlerrors Then On Error GoTo ErrHandler
lngLen = 16
strCompName = String$(lngLen, 0)
'MAIN BODY
'~~~~~~~~~
lngX = apiGetComputerName(strCompName, lngLen)
'WRAP-UP
'~~~~~~~
WrapUp:
Select Case lngX
Case Is <> 0
fOSMachineName = Left$(strCompName, lngLen)
Case 0
fOSMachineName = ""
End Select
Exit Function
'ERROR HANDLER
'~~~~~~~~~~~~~
ErrHandler:
Call LogError(fnErrLvl.Warn, Err, DBEngine.Errors, C_MODULE_NAME, C_PROC_NAME, strErrNotes, Erl)
Resume WrapUp
End Function
Public Function fGetUser() As String
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' DESCRIPTION:
'~~~~~~~~~~~~~
' This function returns the User Name of the person logged onto the system.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' INPUT:
'~~~~~~~
' None.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' OUTPUT:
'~~~~~~~~
' User name of person logged onto the network.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' SAMPLE CALL:
'~~~~~~~~~~~~~
' strUserName = fGetUser()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' HISTORY:
'~~~~~~~~~
' MATPIE - 11/01/1998 - Wrote function.
' MATPIE - 03/18/1999 - Commented fx.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Const C_PROC_NAME = "fGetUser"
'DECLARATIONS
'~~~~~~~~~~~~
Dim sSystemUserID As String * 255
Dim lRet As Long
Static sUserID As String
'INITIALIZE
'~~~~~~~~~~
If gcfErrHandlerrors Then On Error GoTo ErrHandler
'MAIN BODY
'~~~~~~~~~
sSystemUserID = Space(255)
lRet = WNetGetUser(vbNullString, sSystemUserID, 255&)
sUserID = Left$(sSystemUserID, InStr(sSystemUserID, Chr(0)) - 1)
'WRAP-UP
'~~~~~~~
WrapUp:
Select Case lRet
Case Is = 0
fGetUser = sUserID
Case Else
fGetUser = ""
End Select
Exit Function
'ERROR HANDLER
'~~~~~~~~~~~~~
ErrHandler:
Select Case Err
Case 0
ERR.CLEAR
Case Else
MsgBox "Error: " & Err.Number & "-" & Err.Description
End Select
Resume WrapUp
End Function