即时通补助,第一次做

Const HKEY_CURRENT_USER = &H80000001 
Const REG_DWORD = 4 
Const s = "Software\Yahoo\pager\Test" 



Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long 
Private Declare Sub RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) 
Private Declare Sub RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) 
Private Declare Sub RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 

Dim ch, rh As Boolean 
Dim ti As Integer 
Dim yahoo As New Messenger2 
Private Sub Combo1_Change() 
If Val(Combo1.Text) < 5 Or 100 < Val(Combo1.Text) Then 
ch = Not ch 
If ch = True Then 
MsgBox "范围错误", , "Error" 
Combo1.Text = "" 
End If 
End If 
End Sub 
Private Sub Command1_Click() 
If Check1.Value = 0 Then 
List1.AddItem 0 & Text1.Text 
Else 
List1.AddItem 1 & Text1.Text 
End If 
List1.ListIndex = List1.NewIndex 
End Sub 
Private Sub Command10_Click() 
Timer2.Interval = 200 
Timer2.Enabled = True 
Timer3.Interval = 5000 
Timer3.Enabled = True 
End Sub 
Private Sub Command11_Click() 
Label3.Caption = Text3 
End Sub 
Private Sub Command12_Click() 
MsgBox "输入帐号然后按锁定在按封锁 ! 就OK .", vbOKOnly, "说明" 
End Sub 
Private Sub Command2_Click() 
On Error GoTo f 
List1.RemoveItem List1.ListIndex 
f: 
End Sub 
Private Sub Command3_Click() 
Timer1.Interval = Val(Combo1.Text) * 1000 
Timer1.Enabled = True 
End Sub 
Private Sub Command4_Click() 
Timer1.Enabled = False 
End Sub 
Private Sub Command5_Click() 
    If List1.ListIndex = -1 Then 
        List1.ListIndex = List1.ListCount - 1 
        Exit Sub 
    End If 
    If List1.ListIndex = 0 Then 
        Exit Sub 
    End If 
    TmpStr = List1 
    TmpSqr = List1.ListIndex 
    List1.RemoveItem List1.ListIndex 
    List1.AddItem TmpStr, TmpSqr - 1 
    List1.ListIndex = TmpSqr - 1 
End Sub 
Private Sub Command6_Click() 
    If List1.ListIndex = -1 Then 
        List1.ListIndex = 0 
        Exit Sub 
    End If 
    If List1.ListIndex = List1.ListCount - 1 Then 
    Exit Sub 
End If 
    TmpStr = List1 
    TmpSqr = List1.ListIndex 
    List1.RemoveItem List1.ListIndex 
    List1.AddItem TmpStr, TmpSqr + 1 
    List1.ListIndex = TmpSqr + 1 
End Sub 
Private Sub Command7_Click() 
Dim h& 
    
    RegOpenKey HKEY_CURRENT_USER, s, h 
    RegSetValueEx h, "plural", 0, REG_DWORD, 1&, 4 
    RegCloseKey h 
End Sub 
Private Sub Command8_Click() 
Dim r&, h& 
    r = RegOpenKey(HKEY_CURRENT_USER, s, h) 
    If r = 0 Then RegDeleteValue h, "plural" 
    RegCloseKey h 
End Sub 
Private Sub Command9_Click() 
URL = "http://img.msg.yahoo.com/avatar.php?yids=" & Text2 
WebBrowser2.Navigate URL 
WebBrowser2.Visible = True 
URL2 = "[url=http://opi.yahoo.com/online?m=g&t=0&l=tw&u]http://opi.yahoo.com/online?m=g&t=0&l=tw&u[/url]=" & Text2 
WebBrowser1.Navigate URL2 
WebBrowser1.Visible = True 
End Sub 
Private Sub Form_Load() 
MsgBox "欢迎使用本程式 作者即时通:s9652387 ", 64, "(!)" 
Shell "explorer http://www.wretch.cc/blog/s9652387" 
WebBrowser3.Navigate "https://login.yahoo.com" 
WebBrowser2.Visible = False 
'WebBrowser2.Navigate "about:Tabs" 
WebBrowser1.Visible = False 
'WebBrowser1.Navigate "about:Tabs" 
Dim kbf As String 
rh = True 
On Error GoTo fff 
Dim a, b, c As String 
For i = 5 To 60 
Combo1.AddItem i 
Next 
If Dir(App.Path & "\save.ini") <> "" Then 
rh = False 
Open App.Path & "\save.ini" For Input As #3 
Line Input #3, a 
Close #3 
b = Mid(a, Len(a) - 1, 2) 
If b <> "00" Then 
Open App.Path & "\save.ini" For Input As #1 
For aa = 0 To b - 1 
Line Input #1, c 
kbf = Mid(c, 1, Len(c) - 2) 
List1.List(aa) = kbf 
Next 
Close #1 
End If 
End If 
fff: 
Close #1 
Close #3 
End Sub 
Private Sub Form_Unload(Cancel As Integer) 
Dim lic As String 
Select Case ListCount 
Case Is < 10 
lic = "0" & List1.ListCount 
End Select 
If Check2.Value = 1 Then 
Open App.Path & "\save.ini" For Output As #2 
For aa = 0 To List1.ListCount 
Print #2, List1.List(aa) & lic 
Next 
Close #2 
End If 
End Sub 
Private Sub Label1_Click() 
  Shell "Explorer http://www.wretch.cc/blog/s9652387", vbNormalFocus 
End Sub 
Private Sub Timer1_Timer() 
If ti >= List1.ListCount Then 
ti = 0 
Exit Sub 
End If 
NoReturn (yahoo.Me.Status.SetCustomStatus(Mid(List1.List(ti), 2, Len(List1.List(ti)) - 1), Mid(List1.List(ti), 1, 1), Null, Null)) 
ti = ti + 1 
End Sub 
Sub NoReturn(a) 
End Sub 
Private Sub Timer2_Timer() 
WebBrowser3.Document.getElementById("username").Value = Label3 
WebBrowser3.Document.getElementById("passwd").Value = Text4 
WebBrowser3.Document.All(".save").Click 
End Sub 
Private Sub Timer3_Timer() 
Label4.Caption = "以封锁" 
End Sub 
Private Sub WebBrowser2_DocumentComplete(ByVal pDisp As Object, URL As Variant) 
    If Not WebBrowser2.Document Is Nothing Then WebBrowser2.Document.body.Style.overflow = "hidden" 
End Sub 
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant) 
    If Not WebBrowser1.Document Is Nothing Then WebBrowser1.Document.body.Style.overflow = "hidden" 
End Sub