winHttp post登陆的问题

VBA万岁

浮华、缠绕指尖 发表于 2015-1-29 17:46
唉，还是扔个附件吧。。

学习了，多谢分享！
登录商都.zip (52.8 KB, 下载次数: 80)

2015-1-30 12:33 上传

点击文件名下载附件

VBA万岁

VBA万岁 发表于 2015-1-30 12:34
学习了，多谢分享！

奇怪，在另一台电脑上下载第10、11楼的附件，居然提示“有病毒”，遂贴出全部代码，看看是否有人帮忙诊断一下：
模块代码：
Sub test()
    MainFrm.Show
End Sub

Sub test2()
    LoginFrm.Show
End Sub


窗体MainFrm代码：
Option Explicit
Dim winHttp, temp

Private Sub btnLogin_Click()
    If Me.txtPassword = "" Or Me.txtUserName = "" Or Me.txtCheck = "" Then
        MsgBox "参数不全，无法登陆", vbCritical, "温馨提示"
    Else
        With winHttp
            .Open "POST", "http://bbss.shangdu.com/Login/login.jsp", False
            .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .send "backurl=http%3A%2F%2Fbbss.shangdu.com%2FLogin%2Fchecklogin.jsp&action=newlogin&loginby=0&logintype=0&txtNAME=" & Me.txtUserName.Text & "&txtPassword=" & Me.txtPassword.Text & "&safecode=&randomcode=" & Me.txtCheck & "&x=44&y=14"
            If InStr(.responsetext, Me.txtUserName.Text) Then
                MsgBox "登录成功"
            Else
                MsgBox "登录失败"
            End If
        End With
    End If
End Sub
Private Sub Image1_Click()
    RefreshPicture
End Sub
Private Sub UserForm_Initialize()
    Me.txtUserName.Text = "seo123www": Me.txtPassword.Text = "qazwsx123"
    RefreshPicture
End Sub
Sub RefreshPicture()
    Set winHttp = CreateObject("winhttp.winhttprequest.5.1")
    temp = ThisWorkbook.Path & "\" & "tem.jpg"
    With winHttp
        .Open "GET", "http://bbss.shangdu.com/Login/randomcode.jsp?r=" & Int(1000 * Rnd), False
            .send
        ByteToFile .responsebody, temp
    End With
    Me.Image1.Picture = LoadPicture(temp)
    Me.Repaint: Kill temp
End Sub
Sub ByteToFile(ByVal arrByte, ByVal strFileName As String)
    With CreateObject("Adodb.Stream")
        .Type = 1 'adTypeBinary
        .Open
        .Write arrByte
        .SaveToFile strFileName, 2 'adSaveCreateOverWrite
        .Close
    End With
End Sub


窗体LoginFrm代码：
Option Explicit
Dim winHttp, temp

Private Sub UserForm_Initialize()
    Dim i&
    For i = 1 To 26
        ComboBox1.AddItem Sheets("原始数据").Cells(1, i).Value
    Next

    RefreshPicture
End Sub

Private Sub Image1_Click()
    RefreshPicture
    txtCheck.Value = ""
    txtCheck.SetFocus
End Sub

Sub RefreshPicture()
    Set winHttp = CreateObject("winhttp.winhttprequest.5.1")
    temp = ThisWorkbook.Path & "\" & "tem.jpg"
    With winHttp
        .Open "GET", "......", False
            .send
        ByteToFile .responsebody, temp
    End With
    Me.Image1.Picture = LoadPicture(temp)
    Me.Repaint: Kill temp
End Sub

Sub ByteToFile(ByVal arrByte, ByVal strFileName As String)
    With CreateObject("Adodb.Stream")
        .Type = 1 'adTypeBinary
        .Open
        .Write arrByte
        .SaveToFile strFileName, 2 'adSaveCreateOverWrite
        .Close
    End With
End Sub

Private Sub ComboBox1_Change()
    Dim i%, j%
    ComboBox2.Clear
    For i = 1 To 26
        If Sheets("原始数据").Cells(1, i).Value = ComboBox1.Value Then Exit For
    Next i
    For j = 2 To Sheets("原始数据").Cells(100, i).End(xlUp).Row
        ComboBox2.AddItem Sheets("原始数据").Cells(j, i).Value
    Next j
End Sub

Private Sub ComboBox2_Change()
    txtUserName.Text = pinyin(ComboBox2.Value, "", 2)
End Sub

Private Sub btnLogin_Click()
Dim URL, t
If txtUserName = "" Or Me.txtCheck = "" Then
    MsgBox "参数不全，无法登陆", vbCritical, "温馨提示"
Else
    With winHttp
        .Open "POST", "......", False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send "Role=7&Account=" & txtUserName.Text & "&Password=......&CheckCode=" & txtCheck.Value
        URL = Split(Split(.responsetext, "CDATA[")(1), "]]")(0)
    End With
   
    On Error Resume Next
    Dim i As Long, j%, r
    i = ActiveSheet.UsedRange.Rows.Count
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate URL
        Do Until .ReadyState = 4
            DoEvents
        Loop
   
        .Navigate "......"
        Do Until .ReadyState = 4
            DoEvents
        Loop
        Set r = .document.all.tags("table")(0).Rows
        If Cells(i, 1) = r(0).Cells(1).innerText Then .Navigate URL: Exit Sub
        For j = 0 To r.Length - 1
            Cells(i + 1, j * 2 + 1) = "'" & r(j).Cells(1).innerText
            Cells(i + 1, j * 2 + 2) = "'" & r(j).Cells(3).innerText
        Next
        .Navigate URL
        .Quit
    End With
End If
End Sub

KGB的愤怒

VBA万岁 发表于 2015-2-2 08:44
奇怪，在另一台电脑上下载第10、11楼的附件，居然提示“有病毒”，遂贴出全部代码，看看是否有人帮忙诊 ...

窗体MainFrm代码：
验证码的获取用了一个winHttp，登录网址又用了一个winHttp，两个winHttp的Cookie不一样