您所在位置：主题：[原创]vb与网站进行交互，从应用程序提交数据到网站（附代码）
sungfeng21
[专家分：330] 发布于 2007-07-06 06:44:00
[color=FF0000][b]本人在第9楼发布新代码了(此句2007年7月10日新加)[/b]
程序中大多用了配置文件用INI方式，建议现在用XML方式
[/color]
程序思路：利用ASP的GET方法提交数据，并用INI文件方式获取数据和提交状态
实现方法：利用相关函数获取特定html源代码，从而也调用了此页面
利用获取http://123.com/123.asp?id=123
这样既获取了 http://123.com/123.asp?id=123的代码 又在内存中打开了http://123.com/123.asp?id=123这个网页 从而现实了GET方式提交数据
在窗体上添加一个 按钮和2个textbox
代码:
Option Explicit
'强制声明变量
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
'读取INI文件函数，作用：获取数据提交结果
Dim httpurl As String '用来存放提交地址
Dim htmlcode As String '用来存放提交结果与获取HTML代码
Private Sub Command1_Click()
Dim urlstr As String
If Trim(Text1.Text) = "" Then MsgBox "数据1不能为空": Exit Sub
If Trim(Text2.Text) = "" Then MsgBox "数据2不能为空": Exit Sub
'判断数据是否为空
urlstr = httpurl & "?date1=" & Text1.Text & "&date2=" & Text2.Text & "&md5=" & _
MD5.MD5(Text1.Text & "_" & Text2.Text)
'MD5是为了验证数据，防止非应用软件来源数据 可以改成 MD5.MD5("111111111" & Text1.Text & "_" & Text2.Text) 格式从而不可破解
'用ASP GET 方式提交表单
htmlcode = gethtm.getHTTPPage(urlstr)
htmlcode = Trim(htmlcode)
If Left(htmlcode, 7) = "连接服务器失败" Then MsgBox htmlcode, 16, "数据提交程序": Exit Sub
'当无法连接服务器时，程序给出处理
Dim savName As String, savText As String, filename As String
savName = App.Path & "/temp.ini"
Open savName For Output As #1
savText = htmlcode
'如果用write写文件，文本的内容会有双引号
Print #1, savText
Close #1
'将获取的网页HTMK文件（含提交状态）写入临时文件
Dim ret As Long
Dim buff As String
'------------------------------
buff = String(255, 0)
ret = GetPrivateProfileString("数据提交程序", "state", "发生未知错误，或无法连接到指定地址！", buff, 256, App.Path & "/temp.ini")
buff = del34(buff)
MsgBox buff, vbInformation, "『数据提交程序』数据提交程序"
'提示提交状态
Kill App.Path & "/temp.ini"
'删除临时文件
If buff = "数据提交成功！" Or buff = "数据提交成功!" Then
Text1.Text = ""
Text2.Text = ""
End If
'如果提交成功，则清空textbox中的数据
End Sub
Private Sub Form_Load()
httpurl = "http://127.0.0.1/123.asp" '指定提交地址
End Sub
Function del34(a As String) As String '函数作用：去除INI获取的无效字符
Dim i As Integer
del34 = ""
For i = 1 To Len(a)
If Asc(Mid(a, i, 1)) <> 0 Then del34 = del34 & Mid(a, i, 1)
Next
End Function
gethtm模块函数代码：
Function getHTTPPage(url)
On Error GoTo e:
Dim Http
Set Http = CreateObject("MSXML2.XMLHTTP")
Http.Open "GET", url, False
Http.send
If Http.ReadyState <> 4 Then
Exit Function
End If
getHTTPPage = BytesToBstr(Http.responseBody, "GB2312")
Set Http = Nothing
If Err.Number <> 0 Then Err.Clear
Exit Function
e:
If Err.Number = -2146697211 Then
getHTTPPage = "连接服务器失败，请检查网络连接！"
Else
getHTTPPage = "未预期的错误！"
End If
End Function
Function BytesToBstr(body, Cset)
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function
MD5模块代码和ASP代码请自主下载
程序中大多用了配置文件用INI方式，建议现在用XML方式
[/color]
程序思路：利用ASP的GET方法提交数据，并用INI文件方式获取数据和提交状态
实现方法：利用相关函数获取特定html源代码，从而也调用了此页面
利用获取http://123.com/123.asp?id=123
这样既获取了 http://123.com/123.asp?id=123的代码 又在内存中打开了http://123.com/123.asp?id=123这个网页 从而现实了GET方式提交数据
在窗体上添加一个 按钮和2个textbox
代码:
Option Explicit
'强制声明变量
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
'读取INI文件函数，作用：获取数据提交结果
Dim httpurl As String '用来存放提交地址
Dim htmlcode As String '用来存放提交结果与获取HTML代码
Private Sub Command1_Click()
Dim urlstr As String
If Trim(Text1.Text) = "" Then MsgBox "数据1不能为空": Exit Sub
If Trim(Text2.Text) = "" Then MsgBox "数据2不能为空": Exit Sub
'判断数据是否为空
urlstr = httpurl & "?date1=" & Text1.Text & "&date2=" & Text2.Text & "&md5=" & _
MD5.MD5(Text1.Text & "_" & Text2.Text)
'MD5是为了验证数据，防止非应用软件来源数据 可以改成 MD5.MD5("111111111" & Text1.Text & "_" & Text2.Text) 格式从而不可破解
'用ASP GET 方式提交表单
htmlcode = gethtm.getHTTPPage(urlstr)
htmlcode = Trim(htmlcode)
If Left(htmlcode, 7) = "连接服务器失败" Then MsgBox htmlcode, 16, "数据提交程序": Exit Sub
'当无法连接服务器时，程序给出处理
Dim savName As String, savText As String, filename As String
savName = App.Path & "/temp.ini"
Open savName For Output As #1
savText = htmlcode
'如果用write写文件，文本的内容会有双引号
Print #1, savText
Close #1
'将获取的网页HTMK文件（含提交状态）写入临时文件
Dim ret As Long
Dim buff As String
'------------------------------
buff = String(255, 0)
ret = GetPrivateProfileString("数据提交程序", "state", "发生未知错误，或无法连接到指定地址！", buff, 256, App.Path & "/temp.ini")
buff = del34(buff)
MsgBox buff, vbInformation, "『数据提交程序』数据提交程序"
'提示提交状态
Kill App.Path & "/temp.ini"
'删除临时文件
If buff = "数据提交成功！" Or buff = "数据提交成功!" Then
Text1.Text = ""
Text2.Text = ""
End If
'如果提交成功，则清空textbox中的数据
End Sub
Private Sub Form_Load()
httpurl = "http://127.0.0.1/123.asp" '指定提交地址
End Sub
Function del34(a As String) As String '函数作用：去除INI获取的无效字符
Dim i As Integer
del34 = ""
For i = 1 To Len(a)
If Asc(Mid(a, i, 1)) <> 0 Then del34 = del34 & Mid(a, i, 1)
Next
End Function
gethtm模块函数代码：
Function getHTTPPage(url)
On Error GoTo e:
Dim Http
Set Http = CreateObject("MSXML2.XMLHTTP")
Http.Open "GET", url, False
Http.send
If Http.ReadyState <> 4 Then
Exit Function
End If
getHTTPPage = BytesToBstr(Http.responseBody, "GB2312")
Set Http = Nothing
If Err.Number <> 0 Then Err.Clear
Exit Function
e:
If Err.Number = -2146697211 Then
getHTTPPage = "连接服务器失败，请检查网络连接！"
Else
getHTTPPage = "未预期的错误！"
End If
End Function
Function BytesToBstr(body, Cset)
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function
MD5模块代码和ASP代码请自主下载
