by ICE (35 Submissions)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Intermediate
Date Added: Fri 12th February 2021
Rating: 
(1 Votes)
It's a simple 1 form 1 module code All it does is let the user type in their name & then, when they reboot their PC ........ the name they typed in appears to the right of their PC's Clock in the bottom right corner
follow along by carefully reading the text & yes you can copy an paste it,, making it faster like what needs to go on the form & the codes for both the form & the module
It should take less then 5 mins to make & 2 mins to test it. I think its like adding a personal touch to your own PC ,, Having your name in the system tray LOL
For form 1 you need
1 Label ( set just below the Title bar )
Caption in the label is ....
( Change name by the clock in the systray: )
1 TextBox set just below the above Label
Text is Blank ( text.text = "" )
1 Command Button
Caption ( Change name on systray )
Note even if you test it in VB6 when you reboot your PC
There will be a name beside the Clock when it restarts LOL
VBcoders ' Name By Clock
' Form1
Option Explicit
Dim strSysTray01 As String
Dim strSysTray02 As String
Private Sub Command1_Click()
SaveSettings
MsgBox _
"You have 2 restart your computer B4 the settings take place!", _
vbOKOnly, "Restart now!!!"
End Sub
Sub SaveSettings()
If Text1.Text <> "" Then strSysTray01 = Text1.Text
SetStringValue "HKEY_USERS\.DEFAULT\CONTROL PANEL\INTERNATIONAL", _
"s1159", strSysTray01
SetStringValue "HKEY_USERS\.DEFAULT\CONTROL PANEL\INTERNATIONAL", _
"s2359", strSysTray01
End Sub
Sub GetSettings()
strSysTray01 = _
GetStringValue("HKEY_USERS\.DEFAULT\CONTROL PANEL\INTERNATIONAL", "s1159")
strSysTray02 = _
GetStringValue("HKEY_USERS\.DEFAULT\CONTROL PANEL\INTERNATIONAL", "s2359")
Text1.Text = IIf(strSysTray01 = "Error", "", strSysTray01)
End Sub
Private Sub Form_Load()
GetSettings
End Sub
' Name By Clock ....... This following section is for the Module
Option Explicit
Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved _
As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, _
ByRef lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved _
As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData _
As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType _
As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved _
As Long, ByVal dwType As Long, ByRef lpData As Byte, _
ByVal cbData As Long) As Long
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
eyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function
Function ErrorMsg(lErrorCode As Long) As String
Dim GetErrorMsg As String
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)
End Select
End Function
Public Function AGetStringValue(Subkey As String, Entry As String)
Call ParseKey(Subkey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Subkey, 0, KEY_READ, hKey)
If rtn = ERROR_SUCCESS Then
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
sBuffer = Trim(sBuffer)
AGetStringValue = Left(sBuffer, Len(sBuffer) - 1)
Else
AGetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
AGetStringValue = ""
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
Private Sub ParseKey(Keyname As String, Keyhandle As Long)
rtn = InStr(Keyname, "\")
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname
Exit Sub
ElseIf rtn = 0 Then
Keyhandle = GetMainKeyHandle(Keyname)
Keyname = ""
Else
Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1))
Keyname = Right(Keyname, Len(Keyname) - rtn)
End If
End Sub
Function CreateKey(Subkey As String)
Call ParseKey(Subkey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, Subkey, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
End If
End If
End Function
Function SetStringValue(Subkey As String, Entry As String, ByVal Value As String)
Call ParseKey(Subkey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Subkey, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal Value, Len(Value))
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
Public Function GetStringValue(Subkey As String, Entry As String) As String
Dim MemString As String
MemString = AGetStringValue(Subkey, Entry)
If InStr(MemString, Chr(0)) Then
GetStringValue = Left(MemString, InStr(MemString, Chr(0)) - 1)
Else
GetStringValue = MemString
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
the stuff below here you'll have to see if you want to use it & fgure out where to place it,
Maybe someone will figure it out & post it & let others know about it....
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&
Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or _
KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ
Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte
Const DisplayErrorMsg = False
Function SetDWORDValue(Subkey As String, Entry As String, Value As Long)
Call ParseKey(Subkey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Subkey, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, Entry, 0, REG_DWORD, Value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
Function GetDWORDValue(Subkey As String, Entry As String)
Call ParseKey(Subkey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Subkey, 0, KEY_READ, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegQueryValueExA(hKey, Entry, 0, REG_DWORD, lBuffer, 4)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetDWORDValue = lBuffer
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
Function SetBinaryValue(Subkey As String, Entry As String, Value As String)
Dim i As Integer
Call ParseKey(Subkey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Subkey, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
lDataSize = Len(Value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(Value, i, 1))
Next
rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, ByteArray(1), lDataSize)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
Function GetBinaryValue(Subkey As String, Entry As String)
Call ParseKey(Subkey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Subkey, 0, KEY_READ, hKey)
If rtn = ERROR_SUCCESS Then
lBufferSize = 1
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, 0, lBufferSize)
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, sBuffer, lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetBinaryValue = sBuffer
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
Function DeleteKey(Keyname As String)
Call ParseKey(Keyname, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Keyname, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteKey(hKey, Keyname)
rtn = RegCloseKey(hKey)
End If
End If
End Function
Function GetMain
