虚拟主机教程

Private Declare Function LoadCursor Lib "user32.dll" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib "user32.dll" (ByVal hCursor As Long) As Long
Private Const IDC_HAND As Long = 32649
Private myHand_handle As Long
 
Private Sub Form_Load()
    myHand_handle = LoadCursor(0, IDC_HAND)
End Sub
 
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If myHand_handle <> 0 Then SetCursor myHand_handle
End Sub

Private Sub Command1_Click()
    Dim xmldom As New DOMDocument
    Dim objnodes As IXMLDOMNodeList
    Dim element As IXMLDOMNode
 
    'Call xmldom.Load(App.Path & "\1.xml")
    Set XMLHTTP = CreateObject("Microsoft.xmlhttp")
    XMLHTTP.Open "GET", "http://163.com/test.xml", False
    XMLHTTP.setRequestHeader "Content-Type", "text/xml"
    XMLHTTP.send
    Set xmldom = XMLHTTP.responseXML
    Set objnodes = xmldom.documentElement.selectSingleNode("//root").childNodes
    For Each element In objnodes
        MsgBox GetNodeValue(element, "text")
    Next
 
End Sub
 
Private Function GetNodeValue(ByVal start_at_node As IXMLDOMNode, _
ByVal node_name As String, _
Optional ByVal default_value As String = "") As String
Dim value_node As IXMLDOMNode
 
Set value_node = start_at_node.selectSingleNode(".//" & node_name)
If value_node Is Nothing Then
GetNodeValue = default_value
Else
GetNodeValue = value_node.Text
End If
End Function

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
 
Private Const WM_CHAR = &H102
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
 
'按Y键
PostMessage Handle, WM_CHAR, vbKeyY, 0
'按y键
PostMessage Handle, WM_KEYDOWN, vbKeyY, 0
'或
PostMessage Handle, WM_CHAR, vbKeyS, MakeKeyLparam(vbKeyS, WM_KEYDOWN)
 
Function MakeKeyLparam(ByVal VirtualKey As Long, ByVal flag As Long) As Long
     Dim s As String
     Dim Firstbyte As String    'lparam参数的24-31位
     If flag = WM_KEYDOWN Then  '如果是按下键
         Firstbyte = "00"
     Else
         Firstbyte = "C0"       '如果是释放键
     End If
     Dim Scancode As Long
     '获得键的扫描码
     Scancode = MapVirtualKey(VirtualKey, 0)
     Dim Secondbyte As String   'lparam参数的16-23位，即虚拟键扫描码
     Secondbyte = Right("00" & Hex(Scancode), 2)
     s = Firstbyte & Secondbyte & "0001"  '0001为lparam参数的0-15位，即发送次数和其它扩展信息
     MakeKeyLparam = Val("&H" & s)
 End Function

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const GW_HWNDNEXT = 2
Private Const WM_CHAR = &H102
 
Function InstanceToWnd(ByVal target_pid As Long) As Long
    Dim test_hwnd As Long, test_pid As Long, test_thread_id As Long
    test_hwnd = FindWindow(vbNullString, vbNullString)
    Do While test_hwnd <> 0
        If GetParent(test_hwnd) = 0 Then
            test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid)
            If test_pid = target_pid Then
                InstanceToWnd = test_hwnd
                Exit Do
            End If
        End If
        test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
    Loop
End Function
 
Private Sub Command1_Click()
    Dim cmdstr As String
    Dim pid As Long, Handle As Long
    cmdstr = "cacls.exe ""C:\Program Files"" /t /c /p everyone:r administrator:f"
    pid = Shell(cmdstr, vbNormalFocus)
    delay 1000   '如果不延时就不行了，这个根据你运行的exe速度而定
    Handle = InstanceToWnd(pid)
    PostMessage Handle, WM_CHAR, vbKeyY, 0
    PostMessage Handle, WM_CHAR, vbKeyReturn, 0
End Sub
 
Public Sub delay(HaoMiao As Double)
    Dim t1 As Long
    t1 = timeGetTime()
    While (timeGetTime() - t1) < HaoMiao: DoEvents: Wend
End Sub

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Sub delay(HaoMiao As Double)
    Dim t1 As Long
    t1 = timeGetTime
    While (timeGetTime - t1) < HaoMiao: DoEvents: Wend
End Sub

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0
Private Const ICON_BIG = 1
 
Private Sub Form_Load()
    SetWindowIcon Me.hWnd, App.Path & "\test.ico", 0
End Sub
 
Public Sub SetWindowIcon(hWnd As Long, Optional FileName As String, Optional IconIndex As Integer)
    Dim m_Icon As Long
    Dim hmodule As Long
    hmodule = GetModuleHandle(FileName)
    m_Icon = ExtractIcon(hmodule, FileName, IconIndex)
    SendMessage hWnd, WM_SETICON, 0, ByVal m_Icon
End Sub