This repository has been archived by the owner on Apr 29, 2022. It is now read-only.
/
XMLHTTP.bas
executable file
·128 lines (118 loc) · 3.19 KB
/
XMLHTTP.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
Attribute VB_Name = "XMLHTTP"
'Visual Basic 6 XMLHTTP Script
'https://www.jb51.net/article/53060.htm
Public Enum DataEnum
ResponseText = 1
ResponseBody = 2
End Enum
Public Function GetData(ByVal Url As String, ByVal DataStic As DataEnum) As Variant
On Error GoTo ERR:
Dim XMLHTTP As Object
Dim DataS As String
Dim DataB() As Byte
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
XMLHTTP.Open "get", Url, True
XMLHTTP.send
While XMLHTTP.ReadyState <> 4
DoEvents
Wend
Select Case DataStic
Case ResponseText
DataS = XMLHTTP.ResponseText
GetData = DataS
Case ResponseBody
DataB = XMLHTTP.ResponseBody
GetData = DataB
Case ResponseBody + ResponseText
DataS = BytesToStr(XMLHTTP.ResponseBody)
GetData = DataS
Case Else
GetData = ""
End Select
Set XMLHTTP = Nothing
Exit Function
ERR:
GetData = ""
End Function
Public Function PostData(ByVal StrUrl As String, ByVal StrData As String, ByVal DataStic As DataEnum) As Variant
On Error GoTo ERR:
Dim XMLHTTP As Object
Dim DataS As String
Dim DataB() As Byte
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
XMLHTTP.Open "POST", StrUrl, True
'XMLHTTP.setRequestHeader "Content-Length", Len(PostData)
' XMLHTTP.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
XMLHTTP.send (StrData)
Do Until XMLHTTP.ReadyState = 4
DoEvents
Sleep (10)
Loop
'Select Case DataStic
' Case ResponseText
' DataS = XMLHTTP.ResponseText
' PostData = DataS
'DataB = XMLHTTP.ResponseBody
' PostData = DataB
'Case ResponseBody
' Case ResponseBody + ResponseText
'DataS = BytesToStr(XMLHTTP.ResponseBody)
' PostData = DataS
'Case Else
'PostData = ""
'End Select
DataS = XMLHTTP.ResponseText
PostData = DataS
Set XMLHTTP = Nothing
Exit Function
ERR:
PostData = ""
End Function
Public Function GetDataSWE(ByVal Url As String) As String
On Error GoTo ERR:
Dim XMLHTTP As Object
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
XMLHTTP.Open "GET", Url, True
XMLHTTP.send
While XMLHTTP.ReadyState <> 4
Sleep 10
DoEvents
Wend
GetDataSWE = XMLHTTP.ResponseText
Set XMLHTTP = Nothing
Exit Function
ERR:
GetDataSWE = ""
End Function
Public Function PostDataSWE(ByVal StrUrl As String, ByVal StrData As String) As String
On Error GoTo ERR:
Dim XMLHTTP As Object
Dim DataS As String
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
XMLHTTP.Open "POST", StrUrl, True
XMLHTTP.send (StrData)
Do Until XMLHTTP.ReadyState = 4
DoEvents
Sleep (10)
Loop
DataS = XMLHTTP.ResponseText
PostDataSWE = DataS
Set XMLHTTP = Nothing
Exit Function
ERR:
PostDataSWE = ""
End Function
Public Function BytesToStr(ByVal vIn) As String
strReturn = ""
For I = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn, I, 1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn, I + 1, 1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
I = I + 1
End If
Next
BytesToStr = strReturn
End Function