Attribute VB_Name = "Frm_Login"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim foo As WinHttp.WinHttpRequest
Dim mSSLIncomingWhenOnProtocol As String
Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0
Const HTTPREQUEST_SETCREDENTIALS_FOR_PROXY = 1
'Trasparenza Form
Dim g_nTransparency As Integer
Dim color As Long
Dim flag As Byte
Private Sub Form_Load()
progb.Value = 0.0001
Set foo = New WinHttp.WinHttpRequest
foo.Option(WinHttpRequestOption_EnableRedirects) = False
color = RGB(255, 0, 255)
flag = LWA_COLORKEY
g_nTransparency = 255
SetTranslucent Me.hwnd, color, g_nTransparency, flag
Dim Xini1 As New CINIFile
Xini1.LoadFile App.Path & "\Settings.ini"
txt_User.Text = Xini1.GetValue("Dati", "Username")
txt_Passwd.Text = Xini1.GetValue("Dati", "Password")
Xini1.Release
Set Xini1 = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set foo = Nothing
End Sub
Private Sub wskSock_Connect()
senddata "VER 1 MSNP9" & vbCrLf
End Sub
Public Sub senddata(ByVal sdata As String)
wskSock.senddata sdata
End Sub
Private Sub wskSock_DataArrival(ByVal bytesTotal As Long)
Dim x As String
Dim sdata As String
wskSock.GetData sdat
If Mid(sdata, 1, 3) = "VER" Then
senddata "CVR 2 0x0409 win 4.10 i386 MSNMSGR 5.0.0544 MSMSGS " & user & vbCrLf
ElseIf Mid(sdata, 1, 3) = "CVR" Then
senddata "USR 1 TWN I " & user & vbCrLf
progb.Value = 25
ElseIf Mid(sdata, 1, 3) = "XFR" Then
If Split(sdata, " ")(2) = "NS" Then
x = Split(sdata, " ")(3)
wskSock.Close
NewIP = Split(x, ":")(0)
NewPort = Split(x, ":")(1)
wskSock.Connect NewIP, NewPort
End If
ElseIf Mid(sdata, 1, 3) = "USR" Then
If Split(sdata, " ")(2) = "TWN" Then
mSSLIncomingWhenOnProtocol = Split(sdata, " ")(4)
ticket = Passport
senddata "USR 4 TWN S " & ticket & vbCrLf
progb.Value = 35
ElseIf Split(sdata, " ")(2) = "OK" Then
senddata "CHG 1 NLN" & vbCrLf
progb.Value = 50
End If
ElseIf Mid(sdata, 1, 3) = "CHG" Then
Unload Frm_Login
Load FrmPrincipal
End If
End Sub
Public Function Passport() As String
Dim sFirstResponse As String
Dim sSecondResponse As String
Dim sThirdResponse As String
Dim iDaLoginStart As Integer
Dim iDaLoginEnd As Integer
Dim sDaLogin As String
Dim iDaLocaStart As Integer
Dim iDaLocaEnd As Integer
Dim sDaLoca As String
Dim iDaKeyStart As Integer
Dim iDaKeyEnd As Integer
Dim sDaKey As String
'connect to the main server and get the next url
foo.Open "GET", "https://nexus.passport.com/rdr/pprdr.asp"
foo.Send
sFirstResponse = foo.GetAllResponseHeaders
iDaLoginStart = InStr(1, sFirstResponse, "DALogin=") + 8
iDaLoginEnd = InStr(iDaLoginStart, sFirstResponse, ",")
sDaLogin = Mid(sFirstResponse, iDaLoginStart, iDaLoginEnd - iDaLoginStart)
'connect to another server and attempt auth but get redirected
foo.Open "GET", "https://" & sDaLogin
foo.SetRequestHeader "Authorization", "Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=" & user & ",pwd=" & passwd & "," & mSSLIncomingWhenOnProtocol
foo.Send
sSecondResponse = foo.GetAllResponseHeaders
If InStr(1, sSecondResponse, "Location:") > 0 Then
iDaLocaStart = InStr(1, sSecondResponse, "Location: ") + 10
iDaLocaEnd = InStr(iDaLocaStart, sSecondResponse, vbCrLf)
sDaLoca = Mid(sSecondResponse, iDaLocaStart, iDaLocaEnd - iDaLocaStart)
'connect to 3rd and final server and get my key
foo.Open "GET", sDaLoca
foo.SetRequestHeader "Authorization", "Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=" & user & ",pwd=" & passwd & "," & mSSLIncomingWhenOnProtocol
foo.Send
sThirdResponse = foo.GetAllResponseHeaders
iDaKeyStart = InStr(1, sThirdResponse, "from-PP=") + 9
iDaKeyEnd = InStr(iDaKeyStart, sThirdResponse, "'")
sDaKey = Mid(sThirdResponse, iDaKeyStart, iDaKeyEnd - iDaKeyStart)
Passport = sDaKey
Else
iDaKeyStart = InStr(1, sSecondResponse, "from-PP=") + 9
iDaKeyEnd = InStr(iDaKeyStart, sSecondResponse, "'")
sDaKey = Mid(sSecondResponse, iDaKeyStart, iDaKeyEnd - iDaKeyStart)
Passport = sDaKey
End If
End Function
Private Sub xpcmdbutton1_Click()
user = txt_User
passwd = txt_Passwd
Dim Xini1 As New CINIFile
Xini1.LoadFile App.Path & "\Settings.ini"
Xini1.SetValue "Dati", "Username", user
Xini1.SetValue "Dati", "Password", passwd
Xini1.Save
Xini1.Release
Set Xini1 = Nothing
wskSock.Connect "messenger.hotmail.com", 1863
progb.Value = 10
End Sub
Private Sub xpcmdbutton2_Click()
wskSock.Close
Unload Me
End Sub