Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss

Using a CAC Card to access a Microsoft Access Database

456 views
Skip to first unread message

GaleD

unread,
May 4, 2007, 4:21:01 PM5/4/07
to
I am interested in Developing many different Databases that will require A
CAC interface to allow access to Microsofts Access Database. I am looking at
the ability for at least two to three levels of security entry.
At a minimum
Level 1 Identifies the User allows access to the database.
Level 2 Identifies what access the user has in the database (What Forms,
tables etc)
This is so the user has to enter thier CAC card pin once resulting in proper
access for the individual with out having to use any other passwords.

Can you assist? Can Access handle this requirement. How do I code this?


----------------
This post is a suggestion for Microsoft, and Microsoft responds to the
suggestions with the most votes. To vote for this suggestion, click the "I
Agree" button in the message pane. If you do not see the button, follow this
link to open the suggestion in the Microsoft Web-based Newsreader and then
click "I Agree" in the message pane.

http://www.microsoft.com/office/community/en-us/default.mspx?mid=0e171d0b-1bdd-4a38-96ed-d9b2d9a33d5c&dg=microsoft.public.access.modulesdaovba

toby....@us.af.mil

unread,
Feb 22, 2017, 1:41:25 PM2/22/17
to
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

egr...@groggbible.com

unread,
Jul 24, 2018, 6:07:23 PM7/24/18
to
trying to use this on an Access DB in mil environ and compiling, but "modProgress" is not defined. What is that to be defined as?
0 new messages