Public dicProvin As Object
Public Sub hello(ByVal arrInfo)
Dim req As Object, strData As String, strCookie As String
Dim username As String, password As String, strResponse As String
Dim phone As String
[COLOR=#ff0000][SIZE=3][B]username = "your username"
password = "your password"[/B][/SIZE][/COLOR]
phone = arrInfo(1, 1)
fillProvin
Set req = CreateObject("Msxml2.ServerXMLHTTP.6.0")
If Not LOGIN(req, username, password, strCookie) Then
MsgBox "Dang nhap that bai"
Exit Sub
End If
If Not checkPhoneOK(req, strCookie, "84" & phone, username) Then
MsgBox "Khong the dang ky so : " & phone
Exit Sub
End If
MsgBox RegisterPhone(req, strCookie, arrInfo)
End Sub
Private Sub fillProvin()
If dicProvin Is Nothing Then
Dim arr, r As Long
Set dicProvin = CreateObject("scripting.Dictionary")
dicProvin.CompareMode = vbTextCompare
arr = [COLOR=#ff0000][SIZE=4][B]Sheet5.Range("A2:B64").Value[/B][/SIZE][/COLOR]
For r = 1 To UBound(arr) Step 1
dicProvin(arr(r, 1)) = arr(r, 2)
Next
End If
End Sub
Private Function RegisterPhone(req, strCookie As String, ByVal arrInfo) As String
Dim strResponse As String, strData As String, lPos As Long
arrInfo(1, 8) = WorksheetFunction.Trim(Replace(arrInfo(1, 8), "ca ", "", , , vbTextCompare))
If dicProvin.exists(arrInfo(1, 8)) Then arrInfo(1, 8) = dicProvin(arrInfo(1, 8)) Else arrInfo(1, 8) = "AGG"
With req
.Open "POST", "http://prepaid.vinaphone.com.vn/dms/dwr/exec/NEORemoting.getValue.dwr", False
strData = "callCount=1" & _
"&c0-scriptName=NEORemoting" & _
"&c0-methodName=getValue" & _
"&c0-id=" & RandomId & _
"&c0-param0=string:dms.pps_new.value_dangky_new(" & _
"'84" & arrInfo(1, 1) & "'" & _
"%2C'" & URLEncode(arrInfo(1, 3)) & "'" & _
"%2C'" & Format(arrInfo(1, 5), "dd%2FMM%2Fyyyy") & "'" & _
"%2C'" & arrInfo(1, 6) & WorksheetFunction.Rept("%20", 12 - Len(arrInfo(1, 6))) & "'" & _
"%2C'" & URLEncode(arrInfo(1, 4)) & "'" & _
"%2C''%2C''%2C'male'%2C'232'%2C''%2C'1'" & _
"%2C'" & arrInfo(1, 8) & "'" & _
"%2C'4'%2C''" & _
"%2C'" & Format(arrInfo(1, 7), "dd%2FMM%2Fyyyy") & "'" & _
"%2C'" & arrInfo(1, 2) & "'" & _
"%2C'')" & _
"&c0-param1=boolean:false" & _
"&xml=true"
.setRequestHeader "Content-Lenght", Len(strData)
.setRequestHeader "Cookie", strCookie
.send (strData)
strResponse = .responseText
lPos = InStr(strResponse, """")
RegisterPhone = Mid(strResponse, lPos + 1, InStr(lPos + 1, strResponse, """") - lPos - 1)
If RegisterPhone = "1" Then RegisterPhone = "XONG" Else RegisterPhone = "THAT' BAI." & Chr(10) & RegisterPhone
'saveFile strResponse
End With
End Function
Private Function LOGIN(req, username As String, password As String, _
outStrCookie As String) As Boolean
Dim strData
With req
.Open "POST", "http://prepaid.vinaphone.com.vn/dms/main", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
strData = "1iutlomLork=gjsot5pl{tizout" & _
"&1pl{tizout=tku4ysgxz{o4rgu{z4ykz[ykxVgxgskzkx./" & _
"&username=" & username & _
"&password=" & Left(password, 6) & _
"&options=" & Mid(password, 7)
.setRequestHeader "Content-Lenght", Len(strData)
.send (strData)
If .Status = 200 Then
LOGIN = (.responseText = "0")
outStrCookie = .getResponseHeader("Set-Cookie")
Else
LOGIN = False
End If
End With
End Function
Private Function checkPhoneOK(req, strCookie As String, ByVal phone As String, _
username As String) As Boolean
Dim strData As String, strResponse As String
With req
.Open "POST", "http://prepaid.vinaphone.com.vn/dms/dwr/exec/NEORemoting.getValue.dwr", False
.setRequestHeader "Content-Type", "text/plain"
strData = "callCount=1" & _
"&c0-scriptName=NEORemoting" & _
"&c0-methodName=getValue" & _
"&c0-id=" & RandomId & _
"&c0-param0=string:dms.pps_new.check_TB('" & phone & "')" & _
"&c0-param1=boolean:false" & _
"&xml=true"
.setRequestHeader "Content-Lenght", Len(strData)
.setRequestHeader "Cookie", strCookie
.send (strData)
strResponse = .responseText
strResponse = Mid(strResponse, InStr(strResponse, """"), 3)
checkPhoneOK = (strResponse = """1""")
If Not checkPhoneOK Then Exit Function
.Open "POST", "http://prepaid.vinaphone.com.vn/dms/dwr/exec/NEORemoting.getRec.dwr", False
strData = "callCount=1" & _
"&c0-scriptName=NEORemoting" & _
"&c0-methodName=getRec" & _
"&c0-id=" & RandomId & _
"&c0-param0=string:dms.pps_new.rec_laytt_thuebao('" & username & _
"'%2C'" & phone & "')" & _
"&c0-param1=boolean:false" & _
"&xml=true"
.setRequestHeader "Content-Lenght", Len(strData)
.setRequestHeader "Cookie", strCookie
.send (strData)
checkPhoneOK = (InStr(.responseText, "s1") = 0)
End With
End Function
Private Function RandomId() As String
Randomize
RandomId = (Int(7000 * Rnd) + 600) & "_" & _
WorksheetFunction.Round(((Date - #1/1/1970#) * 86400 + Timer) * 1000, 0)
End Function
Public Sub saveFile(response As String)
Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
fsT.Type = 2 'Specify stream type - we want To save text/string data.
fsT.Charset = "utf-8" 'Specify charset For the source text data.
fsT.Open 'Open the stream And write binary data To the object
fsT.WriteText response
fsT.SaveToFile ThisWorkbook.Path & "\data.html", 2 'Save binary data To disk
Set fsT = Nothing
End Sub
Public Function URLEncode(ByVal StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
Dim bytes() As Byte, b As Byte, i As Integer, space As String, adoStream As Object
If SpaceAsPlus Then space = "+" Else space = "%20"
If Len(StringVal) > 0 Then
Set adoStream = CreateObject("ADODB.Stream")
With adoStream
.Mode = 3 'adModeReadWrite
.Type = 2 'adTypeText
.Charset = "UTF-8"
.Open
.WriteText StringVal
.Position = 0
.Type = 1 ' adTypeBinary
.Position = 3 ' skip BOM
bytes = .Read
.Close
End With
Set adoStream = Nothing
ReDim result(UBound(bytes)) As String
For i = UBound(bytes) To 0 Step -1
b = bytes(i)
Select Case b
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Chr(b)
Case 32
result(i) = space
Case 0 To 15
result(i) = "%0" & Hex(b)
Case Else
result(i) = "%" & Hex(b)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
