by DiskJunky (16 Submissions)
Category: String Manipulation
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Thu 14th December 2000
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
This get the registered owner of a machine and is about 60 times faster than the last code I put up. I know that I can access the registry to
API Declarations
'way. It gets the owner by accessing the User.exe
'and HwInfo.dat files and compares the two strings.
'Created by Eric O'Sullivan.
'Any changes made to this code should be made aware
'to the creator at [email protected]
'-------------------------------------------------
'=================================================
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
VBcoders
Const UserOrig = "User.Exe"
'HwOrig = windows dir
'UserOrig = windows\system dir
Dim HwInfo As String
Dim User As String
'used to stop file access during owner search
Public Searching As Boolean
Public Function SystemDirectory() As String
'returns the path of the windows directory.
Dim WinPath As String
Dim Temp As Variant
WinPath = String(145, Chr(0))
Temp = GetSystemDirectory(WinPath, 145)
'remove the NULL character from the returned
'String.
SystemDirectory = Left(WinPath, InStr(WinPath, Chr(0)) - 1)
End Function
Public Function WindowsDirectory() As String
'returns the path of the windows directory.
Dim WinPath As String
Dim Temp As Variant
WinPath = String(145, Chr(0))
Temp = GetWindowsDirectory(WinPath, 145)
'remove the NULL character from the returned
'String.
WindowsDirectory = Left(WinPath, InStr(WinPath, Chr(0)) - 1)
End Function
Public Function AddFile(Path As String, File As String) As String
'This procedure adds a file name to a path.
If Right(Path, 2) = ":\" Then
Path = Path & File
Else
Path = Path & "\" & File
End If
AddFile = Path
End Function
Public Function GetRegOwner() As String
'This is the function to call in your code
'RegisteredOwnerEric O'Sullivan ÿ HwInfo.Dat
'BOULAMITE?Eric O'Sullivan? User.exe
'BOULAMITE?Eric O'Sullivan ?
Dim UOwner As String 'owner from user.exe
Dim HwOwner As String 'owner from HwInfo.Dat
Dim FileNum As Integer
Dim Check As String
Dim ErrNum As Long
Searching = False
'get file paths.
HwInfo = AddFile(WindowsDirectory, HwOrig)
User = AddFile(SystemDirectory, UserOrig)
'get a file number not used
FileNum = FreeFile
'check if there are no problems accessing files
On Error Resume Next
Open LCase(HwInfo) For Input As FileNum
ErrNum = Err
Close FileNum
If ErrNum <> 0 Then
'exit function
GetRegOwner = ""
Searching = False
Exit Function
End If
Open LCase(User) For Input As FileNum
ErrNum = Err
Close FileNum
If ErrNum <> 0 Then
'exit function
GetRegOwner = ""
Searching = False
Exit Function
End If
On Error GoTo 0
'get owner
'==================================================
Searching = True
'check the HwInfo.Dat file
Open LCase(HwInfo) For Binary As FileNum
Do While (Not EOF(FileNum)) And (HwOwner = "")
If Not Searching Then
'if the search was cancelled
Close FileNum
GetRegOwner = ""
Exit Function
End If
'get data in 30k chunks
Check = Input((1024 * 30), #FileNum)
'continue program while searching
DoEvents
HwOwner = GetInHw(Check)
Loop
Close FileNum
'check the User.exe file
If HwOwner = "" Then
Open LCase(User) For Binary As FileNum
Do While (Not EOF(FileNum)) And (UOwner = "")
'continue program while searching
DoEvents
If Not Searching Then
'if the search was cancelled
Close FileNum
GetRegOwner = ""
Exit Function
End If
'get data in 30k chunks
Check = Input((1024 * 30), #FileNum)
UOwner = GetInUser(Check)
Loop
Close FileNum
End If
'==================================================
'if the two values were the same, then return name
If HwOwner <> "" Then
GetRegOwner = HwOwner
Else
GetRegOwner = UOwner
End If
Searching = False
End Function
Private Function GetInHw(Text As String) As String
'RegisteredOwnerEric O'Sullivan ÿ HwInfo.Dat
'BOULAMITE?Eric O'Sullivan? User.exe
Const RegHwSt = "RegisteredOwner"
Const RegHwEn = "ÿ"
Const RegUrSt = "BOULAMITE" '+ ASCII #30
'Const RegUrEn = ASCII #30
Dim Start As Integer
Dim LastP As Integer
Dim RetVal As String
Dim Counter As Integer
Dim Index As Integer
Dim GotHw As String
Dim GotUr As String
Dim FoundInStr As Long
RetVal = Text
'string from HwInfo.Dat
'do normal events
If Second(Time) <> Second(frmHandsClk.lblShowTime.Caption) Then
Call frmHandsClk.ShowDigitalValues
End If
DoEvents
'if something important comes up, stop searching
If Not Searching Then
Exit Function
End If
FoundInStr = InStr(1, LCase(RetVal), LCase(RegHwSt))
If (FoundInStr <> 0) Then '(FoundInStr <> Null) And
'find where the start of the name is
Start = FoundInStr + Len(RegHwSt)
'find where name ends
Index = InStr(Start, RetVal, RegHwEn)
If (Index <> 0) Then
LastP = Index
End If
If LastP > 0 Then
GotHw = Mid(RetVal, Start, (LastP - Start))
'remove trailing zero characters
GotHw = RemoveNull(Trim(GotHw))
'return name
GetInHw = GotHw
Exit Function
End If
End If
'--------------------------------------------------
End Function
Public Function GetInUser(Text As String) As String
'RegisteredOwnerEric O'Sullivan ÿ HwInfo.Dat
'BOULAMITE?Eric O'Sullivan? User.exe
Const RegHwSt = "RegisteredOwner"
Const RegHwEn = "ÿ"
Const RegUrSt = "BOULAMITE" '+ ASCII #30
Dim RegUrEn As String '= ASCII #30
Dim Start As Integer
Dim LastP As Integer
Dim RetVal As String
Dim Counter As Integer
Dim Index As Integer
Dim GotUr As String
RetVal = Text
RegUrEn = Chr(30)
'search string from User.dat
'do normal events
If Second(Time) <> Second(frmHandsClk.lblShowTime.Caption) Then
Call frmHandsClk.ShowDigitalValues
End If
DoEvents
'if something important comes up, stop searching
If Not Searching Then
Exit Function
End If
FoundInStr = InStr(1, LCase(RetVal), LCase(RegUrSt))
If (FoundInStr <> 0) Then '(FoundInStr <> Null) And
'find where the start of the name is
Start = FoundInStr + Len(RegUrSt) + 1
'find where name ends
Index = InStr(Start, RetVal, RegUrEn)
If (Index <> 0) Then
LastP = Index
End If
If LastP > 0 Then
GotUr = Mid(RetVal, Start, (LastP - Start))
'remove trailing zero characters
GotUr = RemoveNull(Trim(GotUr))
'return name
GetInUser = GotUr
Exit Function
End If
End If
'==================================================
End Function
Private Function RemoveNull(Text As String) As String
'This function remove null characters.
Const NullChars = 10
Dim Counter As Integer
Dim Result As String
For Counter = 1 To Len(Text)
If Asc(Mid(Text, Counter, 1)) >= NullChars Then
Result = Result & Mid(Text, Counter, 1)
End If
Next Counter
'test = Asc(Right(Result, 1))
RemoveNull = Result
End Function
No comments have been posted about This get the registered owner of a machine and is about 60 times faster than the last code I put up. Why not be the first to post a comment about This get the registered owner of a machine and is about 60 times faster than the last code I put up.
