cildor666
Advanced Cheater
![]() Reputation: 0
Joined: 08 Mar 2008
Posts: 95
|
 Posted: Tue Oct 14, 2008 2:55 pm Post subject: VB6 Help needed! |
 |
|
I am making an MSN freezer, here is the code :
| Code: | Option Explicit
Private WithEvents oWinHTTP As WinHttp.WinHttpRequest
Private bGotAuthRedir As Boolean
Private sChallenge As String
Private sAuthLocation As String
Private dTransID As Double
Private bDeFreeze As Boolean
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 Declare Sub ReleaseCapture Lib "User32" ()
Private Sub Command1_Click()
End
End Sub
Private Sub Command2_Click()
If Me.WindowState <> vbMaximized Then
Me.WindowState = vbMinimized
Else
Me.WindowState = vbNormal
End If
End Sub
Private Sub cmdDeFreeze_Click(Index As Integer)
bDeFreeze = True
End Sub
Private Sub cmdFreeze_Click(Index As Integer)
Set oWinHTTP = New WinHttp.WinHttpRequest
sckMain.Close
sckMain.Connect "messenger.hotmail.com", 1863
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
If Button = vbLeftButton Then
ReleaseCapture
Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub Label1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
If Button = vbLeftButton Then
ReleaseCapture
Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub Label2_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
If Button = vbLeftButton Then
ReleaseCapture
Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Function TransactionID() As Double
If dTransID = 2 ^ 32 - 1 Then
dTransID = 1
End If
TransactionID = dTransID
dTransID = dTransID + 1
End Function
Private Sub Picture1_Click()
If Me.WindowState <> vbMaximized Then
Me.WindowState = vbMinimized
Else
Me.WindowState = vbNormal
End If
End Sub
Private Sub Picture2_Click()
End
End Sub
Private Sub sckMain_Connect()
Call SendData("VER " & TransactionID & " MSNP8" & vbCrLf)
End Sub
Private Sub SendData(data As String)
Call sckMain.SendData(data)
If Mid(data, Len(data) - 1) = vbCrLf Then
Debug.Print ("<<<: " & Mid(data, 1, Len(data) - 2))
Else
Debug.Print ("<<<: " & data)
End If
End Sub
Private Sub sckMain_DataArrival(ByVal bytesTotal As Long)
Dim sCommand As String, sData As String, sBuffer As String, sParams() As String
Dim i As Long
Do
Call sckMain.PeekData(sBuffer, vbString, bytesTotal)
If InStr(1, sBuffer, vbCrLf) = 0 Then
Exit Sub
End If
If InStr(1, sBuffer, " ") Then
sCommand = Mid$(sBuffer, 1, InStr(1, sBuffer, " ") - 1)
Else
sCommand = Mid$(sBuffer, 1, InStr(1, sBuffer, vbCrLf) - 1)
End If
If sCommand = "MSG" Or sCommand = "NOT" Then
i = InStr(1, sBuffer, vbCrLf)
sParams() = Split(Mid$(sBuffer, 1, i - 1), " ")
If CLng(Len(Mid$(sBuffer, i + 2))) < CLng(sParams(3)) Then
Exit Do
End If
sData = Mid(GetData(vbNullString, False, i + sParams(3) + 1), i + 2)
Else
sData = GetData(sBuffer)
sParams() = Split(sData, " ")
sData = vbNullString
End If
Call ProcessData(sParams, sData)
Loop While sckMain.BytesReceived <> 0
End Sub
Private Sub ProcessData(sParams() As String, sPayload As String)
Dim sSubParams() As String
Select Case sParams(0)
Case "VER"
Call SendData("CVR 2 0x0409 winnt 5.1 i386 MSNMSGR 6.0.0254 MSMSGS " & txtEmail & vbCrLf)
Case "CVR"
Call SendData("USR 3 TWN I " & txtEmail & vbCrLf)
Case "XFR"
sSubParams() = Split(sParams(3), ":")
Call sckMain.Close
Call sckMain.Connect(sSubParams(0), sSubParams(1))
Case "USR"
If sParams(2) = "OK" Then
Call SendData("SYN " & TransactionID & " 0" & vbCrLf)
ElseIf sParams(2) = "TWN" Then
sChallenge = sParams(4)
oWinHTTP.Option(WinHttpRequestOption_EnableRedirects) = False
If Not bGotAuthRedir Then
Call oWinHTTP.Open("GET", "https://nexus.passport.com/rdr/pprdr.asp", True)
Call oWinHTTP.Send
Else
Call oWinHTTP.Open("GET", sAuthLocation, True)
Call oWinHTTP.SetRequestHeader("Authorization", "Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=" & Replace(txtEmail, "@", "%40") & ",pwd=" & "freeze" & "," & sParams(4))
Call oWinHTTP.Send
End If
End If
End Select
End Sub
Private Function GetData(sBuffer As String, Optional bTrim As Boolean = True, Optional lLength As Long = 0) As String
Dim sData As String
Dim i As Long
If lLength = 0 Then
i = InStr(1, sBuffer, vbCrLf, vbTextCompare)
Call sckMain.GetData(sData, vbString, i + 1)
Else
Call sckMain.GetData(sData, vbString, lLength)
End If
If bTrim = True Then
GetData = Mid(sData, 1, Len(sData) - 2)
Else
GetData = sData
End If
Debug.Print ">>>: " & GetData
End Function
Private Sub oWinHTTP_OnResponseFinished()
On Error Resume Next
Dim i As Integer
If Not bGotAuthRedir Then
i = InStr(1, oWinHTTP.GetResponseHeader("PassportURLs"), "DALogin")
sAuthLocation = "https://" & Mid$(oWinHTTP.GetResponseHeader("PassportURLs"), i + 8, InStr(i + 1, oWinHTTP.GetResponseHeader("PassportURLs"), ",") - i - 8)
bGotAuthRedir = True
Call oWinHTTP.Open("GET", sAuthLocation, True)
Call oWinHTTP.SetRequestHeader("Authorization", "Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=" & Replace(txtEmail, "@", "%40") & ",pwd=" & "freeze" & "," & sChallenge)
Call oWinHTTP.Send
Else
If IsHeader("WWW-Authenticate") Then
If InStr(1, oWinHTTP.GetResponseHeader("WWW-Authenticate"), "Passport1.4 da-status=failed") Then
If bDeFreeze = True Then
sckMain.Close
bDeFreeze = False
Exit Sub
Else
Call cmdFreeze_Click
End If
End If
End If
End If
End Sub
Private Function IsHeader(sHeaderName As String) As Boolean
On Error Resume Next
Dim sValue As String
sValue = oWinHTTP.GetResponseHeader(sHeaderName)
If Err.Number = 0 Then
IsHeader = True
End If
End Function
|
Everytime i try and debug or make the EXE it highlights the code 'WithEvents oWinHTTP As WinHttp.WinHttpRequest' and says 'User-defined type not defined'.
Note : The winsock control is renamed 'sckMain'.
Any help is greatly appreciated.
|
|
FAQ
Search
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
Reputation: 2
