[AccessD] Track PC Number

I think you lost part of this function in the cut and paste. 


John W. Colby
Colby Consulting
www.ColbyConsulting.com 
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of John Skolits
Sent: Tuesday, June 12, 2007 9:41 AM
To: 'Access Developers discussion and problem solving'
Subject: Re: [AccessD] Track PC Number

For security reasons I sometimes use the hard drives serial number. Here's
some code to get that info:

Function lbf_GetFirstHardDriveInfo(strType As String) As Variant

  ''*******************************************************
''                         Procedure Identification
''---------------------------------------------------------
''    Name:         lbf_GetFirstHardDriveInfo
''
''    Purpose:	Retrieves info on the hard drive
''
''    Options: 	"FreeSpace", "FileSystem", "SerialNumber"
''			"TotalSize", "VolumeName"
''
''    Notes:
''
''
''    Date/Author:   01/20/03 John Skolits
''***********************************************************

On Error GoTo lbf_GetFirstHardDriveInfo_ERR

'*********BEGIN CODE HERE ********
Dim fs, a, pdrive, pMachineID
Set fs = CreateObject("Scripting.FileSystemObject")
 For Each pdrive In fs.Drives
     If pdrive.DriveType = 2 Then
         Select Case strType

             Case "FreeSpace"
                 lbf_GetFirstHardDriveInfo = _
                    Format(CDbl((pdrive.FreeSpace)), "#,###,###")
             Case "FileSystem"
                 lbf_GetFirstHardDriveInfo = _
                    CStr((pdrive.FileSystem))
             Case "SerialNumber"
                 lbf_GetFirstHardDriveInfo = _
                    CStr(Hex(pdrive.SerialNumber))
             Case "TotalSize"
                 lbf_GetFirstHardDriveInfo = _
                    CDbl((pdrive.TotalSize))
             Case "VolumeName"
                 lbf_GetFirstHardDriveInfo = _
                    CStr((pdrive.VolumeName))
          End Select
     End If
 Next
    

lbf_GetFirstHardDriveInfo_EXIT:

Exit Function

lbf_GetFirstHardDriveInfo_ERR:       'Display the error
      If lg_intDEBUG_MODE = True Then
            DoCmd.Echo lg_intDEBUG_ECHO
            DoCmd.Hourglass lg_intDEBUG_HOURGLASS
            MsgBox "ERROR CODE:" & Err & "   DESC:" & Error
            Stop
            Resume
      End If

Dim strCallingObject As String
      strCallingObject = "lbf_GetFirstHardDriveInfo" _
      & "  " & Application.CurrentObjectName
      MsgBox Err, Error, strCallingObject
      Resume lbf_GetFirstHardDriveInfo_EXIT End Function



--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com