Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

MSN contact list grabber

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • MSN contact list grabber

    Here goes, right out the oven.

    ' Compiler: PB 8.04 (Can be tweaked to work also with PBCC)

    Code:
    #COMPILE EXE
    #DIM ALL
    #INCLUDE "WIN32API.INC"
    
    ' This took me lots and lots of time, not because it was hard,
    ' But because of my lack of knowledge about COM.
    '
    ' Thanx goes to, Paul Franks and David Roberts,
    
    
    MACRO CreateObject(id) = NEW DISPATCH IN id
    
    
    ' ==== Ask the nexus server to wich server should i connect===============
    FUNCTION WriteNEXUS() AS STRING
    
    
      LOCAL v1 AS VARIANT, v2 AS VARIANT
    
      DIM objXMLHTTP AS DISPATCH
      'SET objXMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")   '<--- This one is better supported in TrustedWebHost
      SET objXMLHTTP = CreateObject("Msxml2.xmlhttp.4.0")
    
      v1 ="GET "
      v2 = "https://nexus.passport.com:443/rdr/pprdr.asp"
    
      OBJECT CALL objXMLHTTP.open(v1, v2)
    
      v1 = ""
      OBJECT CALL objXMLHTTP.send(v1)
    
      OBJECT GET objXMLHTTP.getAllResponseHeaders TO v1
    
      FUNCTION = VARIANT$(v1)
    
      SET objXMLHTTP        = NOTHING
    
    END FUNCTION
    '============================================================================
    
    
    '==Send The Autentication Code to the server=================================
    FUNCTION WriteLOGIN1(LoginURL AS STRING, AuthPolicy AS STRING, EmailAddress AS STRING, Password AS STRING) AS STRING
    
    
      LOCAL v1 AS VARIANT, v2 AS VARIANT
    
      DIM objXMLHTTP AS DISPATCH
      'SET objXMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")   '<--- This one is better supported in TrustedWebHost
      SET objXMLHTTP = CreateObject("Msxml2.xmlhttp.4.0")
    
      v1 ="GET"
      LoginURL = LCASE$(LoginURL)
      REPLACE ".com/" WITH ".com:443/" IN LoginURL
      REPLACE ".net/" WITH ".net:443/" IN LoginURL
      v2 = "https://" & LoginURL
    
      OBJECT CALL objXMLHTTP.open(v1, v2)
    
      v1 = "Authorization"
      v2 = "Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=" & EmailAddress & ",pwd=" & Password & "," & _
           AuthPolicy
    
      OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
    
      v1 = "User-Agent"
      v2 = "MSMSGS"
      OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
    
      v1 = "Host"
      v2 = PARSE$(LoginUrl, ANY ":/", 1)
      OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
    
      v1 = "Connection"
      v2 = "Keep-Alive"
      OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
    
      v1 = "Cache-Control"
      v2 = "no-cache"
      OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
    
      v1 = ""
      OBJECT CALL objXMLHTTP.send(v1)
    
      OBJECT GET objXMLHTTP.getAllResponseHeaders TO v1
    
      FUNCTION = VARIANT$(v1)
    
      SET objXMLHTTP = NOTHING
    
    END FUNCTION
    '=====================================================================================
    
    '==Send a message to the MSN server and wait for an answer============================
    FUNCTION WriteMsnPort(FF AS LONG, TCPLine AS STRING, AsIs AS LONG, SleepTime AS LONG) AS STRING
     STATIC CurTran AS LONG
     LOCAL Index    AS LONG
     LOCAL Buffer   AS STRING
     LOCAL Answer   AS STRING
     ERRCLEAR
     IF INSTR(TCPLine, "%TRN") THEN
      INCR CurTran
      REPLACE "%TRN" WITH FORMAT$(CurTran) IN TCPLine
     END IF
     IF INSTR(TCPLine, "%TR2") THEN
      INCR CurTran
      REPLACE "%TR2" WITH FORMAT$(CurTran) IN TCPLine
     END IF
     IF ISTRUE(VARPTR(AsIs)) THEN
      IF AsIs THEN
       TCP SEND #FF, TCPLine & $CRLF
      ELSE
       GOTO ByParts
      END IF
     ELSE
      ByParts:
      TcpLine = TcpLine & $CRLF
      FOR Index = 1 TO PARSECOUNT(Tcpline, $CRLF)
       IF ISTRUE(LEN(PARSE$(TCPLine, $CRLF, Index))) THEN
        TCP PRINT #FF, (TRIM$(PARSE$(TCPLine, $CRLF, Index)) & " ")
       END IF
      NEXT Index
     END IF
    
    
    KeepReading:
     Buffer = SPACE$(2048)
     TCP RECV #FF, 2048, Buffer
     Answer = (Answer & Buffer)
     IF ISFALSE(EOF(FF)) THEN
      SLEEP SleepTime
      GOTO KeepReading
     END IF
    
     ReceiveDone:
    
     FUNCTION = Answer
    
    END FUNCTION
    '=====================================================================================
    FUNCTION GetMoreText(FF AS LONG) AS STRING
    
     LOCAL Buffer   AS STRING
     LOCAL Answer   AS STRING
    
     KeepReading:
     TCP LINE #FF, Buffer
     Answer = Answer & Buffer & $CRLF
     IF ISFALSE(EOF(FF)) THEN GOTO KeepReading
    
     FUNCTION = TRIM$(Answer, ANY $CRLF)
    
    END FUNCTION
    
    '=====================================================================================
    '==Replace character codes with apropriate character (Needs to be added more chars)===
    FUNCTION FixFormatting(MyString AS STRING) AS STRING
    
    LOCAL targetstring AS STRING
    
    TargetString = MyString
    
    REPLACE "%20" WITH " " IN TargetString
    
    FUNCTION = TargetString
    
    END FUNCTION
    
    '=====================================================================================
    
    
    '==Easy-To-Call Function to retrieve the contact list=================================
    FUNCTION RetrieveContactList(EmailAddress AS STRING, Password AS STRING, List() AS STRING) AS LONG
    
    LOCAL Hserver1   AS LONG
    LOCAL HServer2   AS LONG
    LOCAL FF1        AS LONG
    LOCAL FF2        AS LONG
    LOCAL NextServer AS STRING
    LOCAL Result     AS STRING
    LOCAL XML        AS STRING
    LOCAL AuthPolicy        AS STRING
    LOCAL Policy     AS STRING
    LOCAL Pos1       AS LONG
    LOCAL Pos2       AS LONG
    
    LOCAL Index      AS LONG
    LOCAL Index1     AS LONG
    LOCAL Index2     AS LONG
    LOCAL Index3     AS LONG
    
     IF ISFALSE(LEN(Password)) THEN
      MSGBOX "Please edit the code to include your account and password.",,"Please enter required data."
      EXIT FUNCTION
     END IF
    
    CLOSE
    
    FF1 = FREEFILE
    ERRCLEAR
    TCP OPEN PORT 1863 AT "207.46.96.153" AS #FF1
    
    ' First Part, ask the main server wich server should we connect to.
    Result      = WriteMsnPort(FF1, "VER %TRN MSNP8 CVR0", 0, 100)
    Result      = WriteMsnPort(FF1, "CVR %TRN 0x0409 win 4.10 i386 MSNMSGR 6.2.0137 MSMSGS " & EmailAddress, 0, 100)
    NextServer  = WriteMsnPort(FF1, "USR %TRN TWN I " & EmailAddress, 0, 100)
    TCP CLOSE #FF1
    NextServer  = PARSE$(NextServer, " ", 4)
    
    
    ' Part 2, Ask the second server wich server has our information, and as for an autentication code.
    ERRCLEAR
    FF1 = FREEFILE
    TCP OPEN PORT VAL(PARSE$(NextServer, ":", 2)) AT PARSE$(NextServer, ":", 1) AS #FF1
    Result      = WriteMsnPort(FF1, "VER %TRN MSNP8 CVR0", 0, 100)
    Result      = WriteMsnPort(FF1, "CVR %TRN 0x0409 win 4.10 i386 MSNMSGR 6.2.0137 MSMSGS " & EmailAddress, 0, 100)
    AuthPolicy  = WriteMsnPort(FF1, "USR %TRN TWN I " & EmailAddress, 0, 100)
    AuthPolicy  = PARSE$(AuthPolicy, " ", 5)
    
    
    ' Now that we have the autentication code, lets atenticate our log in.
    Result = WriteNEXUS()
    LOCAL TextLine   AS STRING
    LOCAL TextMember AS STRING
    FOR Index1 = 1 TO PARSECOUNT(Result, $CRLF)
     TextLine = PARSE$(Result, $CRLF, Index1)
     IF UCASE$(TRIM$(PARSE$(TextLine, ":", 1))) = UCASE$("PassportURLs") THEN
      TextLine = TRIM$(PARSE$(TextLine, " ", 2))
      FOR Index2 = 1 TO PARSECOUNT(Result, ",")
       TextMember = TRIM$(PARSE$(TextLine, ",", Index2))
       IF UCASE$(TRIM$(PARSE$(TextMember, "=", 1))) = UCASE$("DALogin") THEN
        TextMember = TRIM$(PARSE$(TextMember, "=", 2))
        GOTO GotServer
       END IF
      NEXT Index2
     END IF
    NEXT Index1
    GotServer:
    
    ' The Nexus server replies with another autentication code, wich we now send to the first server.
    Result = WriteLOGIN1(TextMember, AuthPolicy, EmailAddress, Password)
    
    ' We check if we succeeded or failed.
    IF INSTR(UCASE$(Result), UCASE$("status=failed")) THEN FUNCTION = 0 : TCP CLOSE #FF1 : EXIT FUNCTION
    IF ISFALSE(INSTR(UCASE$(Result), UCASE$("='t="))) THEN FUNCTION = 0 : TCP CLOSE #FF1 : EXIT FUNCTION
    
    
    ' We succeded, now the last part is to send the last autentication code to the first server.
    FOR Index1 = 1 TO PARSECOUNT(Result, $CRLF)
     TextLine = PARSE$(Result, $CRLF, Index1)
     IF UCASE$(TRIM$(PARSE$(TextLine, ":", 1))) = UCASE$("Authentication-Info") THEN
      Pos1 = (INSTR(TextLine, "='t=") + 1)
      TextLine = RIGHT$(TextLine, LEN(TextLine)-Pos1)
      TextLine = TRIM$(PARSE$(TextLine, "'", 1))
      GOTO GotAuth
     END IF
    NEXT Index1
    GotAuth:
    
    'We send the autentication code!!
    Result      = WriteMsnPort(FF1, "USR %TRN TWN S " & TextLine, 0, 200)
    
    
    ' We ask for the contact list...
    Result      = WriteMsnPort(FF1, "SYN %TRN 0", 0, 200)
    
    ' We wait a bit so more info comes.
    SLEEP 2000
    
    ' And we pick our list of contacts!
    Result = GetMoreText(FF1)
    
    ' Finally we parse it into a tidy array
    LOCAL Contact AS LONG
    LOCAL ThisContact AS STRING
    Contact = 1
    FOR Index = 1 TO PARSECOUNT(Result, $CRLF)
     ThisContact = TRIM$(PARSE$(Result, $CRLF, Index))
     IF UCASE$(PARSE$(ThisContact, " ", 1)) = "LST" THEN
      List(Contact) = PARSE$(ThisContact, " ", 2) '& FixFormatting(TRIM$(PARSE$(ThisContact, " ", 3))) ' Un REM This if you also want the nicknames.
      INCR Contact
      REDIM PRESERVE List(1 TO Contact)
     END IF
    NEXT Index
    
    IF Contact > 1 THEN REDIM PRESERVE List(1 TO (Contact-1))
    
    FUNCTION = 1
    
    TCP CLOSE #FF1
    TCP CLOSE #FF2
    
    END FUNCTION
    
    
    '=================================================================
    
    FUNCTION PBMAIN () AS LONG
    
    LOCAL Result       AS LONG
    LOCAL EmailAddress AS STRING
    LOCAL Password     AS STRING
    DIM   List(1 TO 1)      AS LOCAL STRING
    
    EmailAddress = "[email protected]"
    Password     = ""  '<- Your Password Here.
    
    Result = RetrieveContactList(EmailAddress, Password, List())
    
    IF Result THEN
     LOCAL Index AS LONG
     LOCAL COntacts AS STRING
     FOR Index = LBOUND(List()) TO UBOUND(List())
      Contacts = Contacts & List(Index) & $CRLF
     NEXT Index
     MSGBOX Contacts,,"SUCCESS!!"
    ELSE
     MSGBOX "The function failed due to unknown error." & $CRLF & _
            "Verify the address and Password, also remember" & $CRLF & _
            "that server some times rejects requests.",,"FAILURE!!"
    END IF
    
    END FUNCTION
Working...
X