VB Post与Get的方法和调用WebService、WCF
VB使用XMLHTTP实现Post与Get的方法
以下信息均来自网络
'==========================================================
'| 模 块 名 | XMLHTTP
'| 说 明 | 替代Inet控件，实现数据通讯
'|主要模块代码如下：
'==========================================================
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
Loop
'-----------------------------函数返回
Select Case DataStic
Case ResponseText
'--------------------------------直接返回字符串
DataS = XMLHTTP.ResponseText
PostData = DataS
Case ResponseBody
'--------------------------------直接返回二进制
DataB = XMLHTTP.ResponseBody
PostData = DataB
Case ResponseBody + ResponseText
'---------------------------二进制转字符串[直接返回字串出现乱码时尝试]
DataS = BytesToStr(XMLHTTP.ResponseBody)
PostData = DataS
Case Else
'--------------------------------无效的返回
PostData = ""
End Select
'------------------------------------释放空间
Set XMLHTTP = Nothing
Exit Function
ERR:
PostData = ""
End Function
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
VB GET-POST
'=======GET方式获取网页源代码================
Function GetCode(Url As String, CodeBase As String)
'第一个参数是地址,第二个参数是设置编码方式(GB2312或UTF-8).
Dim xmlHTTP1
Set xmlHTTP1 = CreateObject("Microsoft.XMLHTTP")
xmlHTTP1.Open "get", Url, True
xmlHTTP1.send
While xmlHTTP1.readyState <> 4
DoEvents
Wend
GetCode = xmlHTTP1.responseBody
If CStr(GetCode) <> "" Then GetCode = BytesToBstr(GetCode, CodeBase)
Set xmlHTTP1 = Nothing
End Function
Function BytesToBstr(strBody, ByVal CodeBase As String)
Dim ObjStream
Set ObjStream = CreateObject("Adodb.Stream")
With ObjStream
.Type = 1
.Mode = 3
.Open
.write strBody
.Position = 0
.Type = 2
.Charset = CodeBase
BytesToBstr = .ReadText
.Close
End With
Set ObjStream = Nothing
End Function
'=======POST方式获取网页源代码================
'先引用Microsoft XML, V3.0
Function PostData(url As String, strData As String)
Dim xml As New XMLHTTP
Dim str1 As String
'url = "http://www.0575.com/"
'strData = "a=1&b=1"
xml.Open "POST", url, False
xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xml.send strData
If xml.Status = 200 Then
str1 = StrConv(xml.responseBody, vbUnicode) '返回的内容
End If
PostData = str1
End Function
'==========新方法获取网页源码===============
'需要Inet
'新获取网页源码方法Inet
Function getHtmlFrom(u)
Dim BinBuff() As Byte
Dim StrUrl As String
StrUrl = u
BinBuff = Inet1.OpenURL(StrUrl, icByteArray)
getHtmlFrom = Utf8ToUnicode(BinBuff)
End Function
'下面这是个模块
'utf- 8转换UNICODE代码
Option Explicit
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8 = 65001
Function Utf8ToUnicode(ByRef Utf() As Byte) As String
Dim lRet As Long
Dim lLength As Long
Dim lBufferSize As Long
lLength = UBound(Utf) - LBound(Utf) + 1
If lLength <= 0 Then Exit Function
lBufferSize = lLength * 2
Utf8ToUnicode = String$(lBufferSize, Chr(0))
lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize)
If lRet <> 0 Then
Utf8ToUnicode = Left(Utf8ToUnicode, lRet)
Else
Utf8ToUnicode = ""
End If
End Function
VB返回记录集结果到HTML表格的方法
'这篇文章主要介绍了VB返回记录集结果到HTML表格的方法,实例分析了VB获取记录集与HTML表格生成的相关技巧,需要的朋友可以参考下
'本文实例讲述了VB返回记录集结果到HTML表格的方法。分享给大家供大家参考。具体实现方法如下：
function ReturnHTMLTable(query)
set rs = cn.Execute(query)
rs.MoveFirst
response.Write "<table class=""data"" cols=""" & rs.Fields.Count & """>"
response.Write "<tr>"
For Each oField In rs.Fields
response.Write "<th>" & oField.Name & "</th>"
Next
response.Write "</tr>"
Do While Not rs.EOF
response.Write "<tr>"
For Each oField In rs.Fields
response.Write "<td>"
If IsNull(oField) Then
response.Write " "
Else
response.Write oField.Value
End If
response.Write "</td>"
Next
rs.MoveNext
response.Write "</tr>"
Loop
response.Write "</table>"
end function
VBA中连接SQLSERVER数据库例子
'这篇文章主要介绍了VBA中连接SQLSERVER数据库例子,VBA是指Visual Basic for Applications,是Visual Basic的一种宏语言,需要的朋友可以参考下
'我们在使用excel编程时，很多时候都需要使用数据库。
'那么如何连接数据库然后从数据库读取数据呢？
'VBA 连接 SQL SERVER 数据库 实例:
Dim strConn As String, strSQL As String
Dim conn As ADODB.Connection
Dim ds As ADODB.Recordset
Dim col As Integer
'连接数据库的字符串
strConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=[user];Password=[password];Initial Catalog=[database];Data Source=[数据库IP地址或数据库服务器名称];Connect Timeout=720; "
'查询语句，如果sql语句很长可以用strSQL=strSQL+来连接分成多段的语句，如果语句很短可以只写在一行上。
strSQL = "select * from Hy_KPI_Shop_Dept_WeekRpt "
strSQL = strSQL+"where sdate='2014-01-01' order by sdate,shopid "
Set conn = New ADODB.Connection
Set ds = New ADODB.Recordset
'打开数据库连接
conn.Open strConn
'该句和数据库连接字符串处的Connect Timeout=720，表示说如果语句运行时间很长，这两句可以延长vba的等待时间，没有这两句，vba往往会报查询超时。
conn.CommandTimeout = 720
With ds
'根据查询语句获得数据
.Open strSQL, conn
'自动控制加入所有列标题
For col = 0 To ds.Fields.Count - 1
'请注意Offset(0, col)中的参数一定要正确，该句表示标题将会写在第一行，从A1单元格开始，如果不想写入标题行，可将下面这句注释掉。
Worksheets("门店各课KPI周报").Range("A1").Offset(0, col).Value = ds.Fields(col).Name
Next
'加入所有行数据，该句表示查询结果将会写在第一行，从A1单元格开始，但是由于标题行写在第一行了，所以实际这一行从标题下的一行写入。
Worksheets("sheet1").Range("A1").Offset(1, 0).CopyFromRecordset ds
End With
'关闭数据库连接和清空资源
Set ds = Nothing
conn.Close
Set conn = Nothing
VB XMLHTTP使用方法
'VB判断地址是否存在的XMLHTTP方法
Private Function IsHearOK(URL As String) As Boolean
Dim XMLObject As Object, ReturnType As String
Set XMLObject = CreateObject("Microsoft.XMLHTTP")
XMLObject.Open "GET", URL, False
XMLObject.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
XMLObject.setRequestHeader "Range", "bytes=1-255"
XMLObject.Send
If XMLObject.Status = 200 Or XMLObject.Status = 206 Then
ReturnType = XMLObject.getResponseHeader("CONTENT-TYPE")
If UCase(ReturnType) <> "TEXT/HTML" Then
IsHearOK = True
Else
IsHearOK = False
End If
Else
IsHearOK = False
End If
Set XMLObject = Nothing
End Function
Private Sub Command1_Click()
If IsHearOK("https://www.jb51.net/test.exe") Then
MsgBox "ok"
Else
MsgBox "no"
End If
End Sub
vb Post XML 对象
'先引入Microsoft XML,v4.0
Function PostXML(url As String, xml As String) As String
Dim I As Integer
'xml = "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "utf-8" & Chr(34) & "?>"
Dim h As MSXML2.ServerXMLHTTP40
Dim X As MSXML2.DOMDocument40
Set X = New MSXML2.DOMDocument40
X.loadXML xml
Set h = New MSXML2.ServerXMLHTTP40
h.Open "POST", url, False
h.setRequestHeader "Content-Type", "text/xml"
h.send (xml)
While h.readyState <> 4
'不断循环，吓死你
Wend
PostXML = h.responseText
End Function
VB6调用WebService、WCF
'调用webservice。需要安装SoapToolkit30.EXE,并在工程中引用Microsoft Soap Type Library v3.0
Sub CallWebService()
Dim m_spClient As New SoapClient30 'SoapClient30对象实例化
m_spClient.MSSoapInit "http://localhost/MCISWebService/vbtest.asmx?WSDL" '引用webservice
MsgBox m_spClient.HelloWorld '调用webservice方法
End Sub
'http方式调用WCF
Sub CallHTTPWCFService()
Dim mexMonikerString As String
Dim mexServiceMoniker As Object
'---------------------------------------------------------------
' MEX service moniker example
'---------------------------------------------------------------
' Create a string for the service moniker specifying the address
' to retrieve the service metadata from
mexMonikerString = "service:mexAddress='http://localhost:55242/Service1.svc/mex'"
mexMonikerString = mexMonikerString + ", address='http://localhost:55242/Service1.svc'"
mexMonikerString = mexMonikerString + ", binding=WSHttpBinding_IService1, bindingNamespace='http://tempuri.org/'"
mexMonikerString = mexMonikerString + ", contract=IService1, contractNamespace='http://tempuri.org/'"
' Create the service moniker object
Set mexServiceMoniker = GetObject(mexMonikerString)
' Call the service operations using the moniker object
MsgBox mexServiceMoniker.SayHello("China!")
Set mexServiceMoniker = Nothing
End Sub
'TCP方式调用WCF
Sub CallTCPWCFService()
Dim mexMonikerString As String
Dim mexServiceMoniker As Object
' Create a string for the service moniker specifying the address
' to retrieve the service metadata from
mexMonikerString = "service:mexAddress='http://192.168.1.110:12345/Binding/mex'"
mexMonikerString = mexMonikerString + ", address='net.tcp://192.168.1.110:54321/Binding/Hello'"
mexMonikerString = mexMonikerString + ", binding='NetTcpBinding_IHello', bindingNamespace='http://tempuri.org/'"
mexMonikerString = mexMonikerString + ", contract=IHello, contractNamespace='http://tempuri.org/'"
' Create the service moniker object
Set mexServiceMoniker = GetObject(mexMonikerString)
' Call the service operations using the moniker object
MsgBox mexServiceMoniker.SayHello("China!")
Set mexServiceMoniker = Nothing
End Sub
'当调用WCF 时候,要注意一些事项.由于WCF对外公布的都是接口,如果WCF里定义了多个接口,VB6.0如果没对全部实现的话是会报错的.我仲未知点解决...WCF定义返回的是Class类,VB6.0那接收时也会出错.
VB6.0 Call WCF
Sub CallWCFService_TypedContract()
Dim strMonikerString As String
Dim serviceMoniker As Object
'---------------------------------------------------------------
' Typed Contract service moniker example
'---------------------------------------------------------------
' Create a service moniker object using a strongly typed contract
' This references the address, a standard binding type and the
' locally registered COM-visible contract ID
monikerString = "service:address='http://localhost/WCFServiceMoniker/Service1.svc'"
monikerString = monikerString + ", binding=wsHttpBinding"
monikerString = monikerString + ", contract={4FBDA94E-8B89-32EC-BC28-2A0A5E9B7C74}"
' Create the service moniker object
Set serviceMoniker = GetObject(monikerString)
' Call the service operations using the moniker object
MsgBox serviceMoniker.SayHello("I am LazyBee, My blog is http://lazybee.cnblogs.com/ ")
Set serviceMoniker = Nothing
End Sub
浙公网安备 33010602011771号