VB6通过ASP网页实现C/S模式

C/S模式一般都是用winsock来相互通信，实现双方互动。

用ASP网页来连接（不能称之为通信），只能C对S发送信息或请求一些信息，

S是不能主动来连接C，发信息给C。

一、C端

既然是要访问ASP页，这里有二种方式。

1、API写的访问模块

Option Explicit

''<API 宣告,API 常数>
Public Declare Function InternetOpen Lib "wininet.dll" _
Alias "InternetOpenA" _
(ByVal lpszCallerName As String,_
ByVal dwAccessType As Long,_
ByVal lpszProxyName As String,_
ByVal lpszProxyBypass As String,_
ByVal dwFlags As Long) As Long

Public Declare Function InternetConnect Lib "wininet.dll" _
Alias "InternetConnectA" _
(ByVal hInternetSession As Long,_
ByVal lpszServerName As String,_
ByVal nProxyPort As Integer,_
ByVal lpszUsername As String,_
ByVal lpszPassword As String,_
ByVal dwService As Long,_
ByVal dwFlags As Long,_
ByVal dwContext As Long) As Long

Public Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long,_
ByVal sBuffer As String,_
ByVal lNumBytesToRead As Long,_
lNumberOfBytesRead As Long) As Integer

Public Declare Function HttpOpenRequest Lib "wininet.dll" _
Alias "HttpOpenRequestA" _
(ByVal hInternetSession As Long,_
ByVal lpszVerb As String,_
ByVal lpszObjectName As String,_
ByVal lpszVersion As String,_
ByVal lpszReferer As String,_
ByVal lpszAcceptTypes As Long,_
ByVal dwContext As Long) As Long

Public Declare Function HttpSendRequest Lib "wininet.dll" _
Alias "HttpSendRequestA" _
(ByVal hHttpRequest As Long,_
ByVal sHeaders As String,_
ByVal lHeadersLength As Long,_
ByVal sOptional As String,_
ByVal lOptionalLength As Long) As Boolean

Public Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInternetHandle As Long) As Boolean

Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" _
Alias "HttpAddRequestHeadersA" _
(ByVal hHttpRequest As Long,_
ByVal lModifiers As Long) As Integer

Public Function PostInfo(ByVal WebServerAddress As String,_
ByVal Port As String,_
ByVal WebPageName As String,_
ByVal CommandString As String,_
Optional ByVal PostData As String = "") As String

Dim hInternetOpen As Long
Dim hInternetConnect As Long
Dim hHttpOpenRequest As Long
Dim bRet As Boolean

hInternetOpen = 0
hInternetConnect = 0
hHttpOpenRequest = 0

'Use registry access settings.
Const INTERNET_OPEN_TYPE_PRECONFIG = 0

hInternetOpen = InternetOpen("http generic",_
INTERNET_OPEN_TYPE_PRECONFIG,_
vbNullString,_
0)

If hInternetOpen <> 0 Then
'Type of service to access.
Const INTERNET_SERVICE_HTTP = 3
Const INTERNET_DEFAULT_HTTP_PORT = 80
'Change the server to your server name
hInternetConnect = InternetConnect(hInternetOpen,_
WebServerAddress,_
Port,_
"HTTP/1.0",_
INTERNET_SERVICE_HTTP,_
0,_
0)

If hInternetConnect <> 0 Then
'Brings the data across the wire even if it locally cached.
Const INTERNET_FLAG_RELOAD = &H80000000
hHttpOpenRequest = HttpOpenRequest(hInternetConnect,_
"POST",_
WebPageName & CommandString,_
INTERNET_FLAG_RELOAD,_
0)

If hHttpOpenRequest <> 0 Then
Dim sHeader As String
Const HTTP_ADDREQ_FLAG_ADD = &H20000000
Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000
sHeader = "Content-Type: application/x-www-form-urlencoded" & vbCrLf
'sHeader = "Content-Type: multipart/form-data" & vbCrLf
bRet = HttpAddRequestHeaders(hHttpOpenRequest,_
sHeader,Len(sHeader),HTTP_ADDREQ_FLAG_REPLACE _
Or HTTP_ADDREQ_FLAG_ADD)

Dim lpszPostData As String
Dim lPostDataLen As Long

lpszPostData = PostData
'lPostDataLen = Len(lpszPostData)
lPostDataLen = LenB(StrConv(lpszPostData,vbFromUnicode))
bRet = HttpSendRequest(hHttpOpenRequest,_
lpszPostData,_
lPostDataLen)

Dim bDoLoop As Boolean
Dim sReadBuffer As String * 4096
Dim lNumberOfBytesRead As Long
Dim sBuffer As String
bDoLoop = True
While bDoLoop
sReadBuffer = vbNullString
bDoLoop = InternetReadFile(hHttpOpenRequest,_
sReadBuffer,Len(sReadBuffer),lNumberOfBytesRead)
sBuffer = sBuffer & _
Left(sReadBuffer,lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
PostInfo = sBuffer
bRet = InternetCloseHandle(hHttpOpenRequest)
End If
bRet = InternetCloseHandle(hInternetConnect)
End If
bRet = InternetCloseHandle(hInternetOpen)
End If
PostInfo = sBuffer
End Function

Public Sub SplitAddr(ByVal addr$,srv$,script$)
'Inputs: The full url including http://
' Two variables that will be changed
'
'Returns: Splits the addr$ var into the server name
' and the script path

Dim i%

i = InStr(addr$,"/")
srv$ = Mid(addr$,i + 2,Len(addr$) - (i + 1))
i = InStr(srv$,"/")
script$ = Mid(srv$,i,Len(srv$) + 1 - i)
srv$ = Left$(srv$,i - 1)

End Sub
以上代码可以在网上搜索到，我修改了一下，支持中文传输。

把以上代码放到一个模块中即可。

调用PostInfo时，给出正确的参数即可。

这个函数的返回值就是你得到的信息，一个字符串，由S端生成。

2、可以用XMLHTTP来访问，我给出一个我实际用的upload file的函数

Public Function UploadFile() As Boolean
On Error GoTo UploadFile_Error

m_UploadMessage = ""
If Len(m_sFileName) = 0 Then
m_UploadMessage = "未设置上传的文件。"
UploadFile = False
Exit Function
End If

Dim XMLDocument As New DOMDocument
Dim ADOStream As New Stream
Dim DOMElement As IXMLDOMElement
Dim MyXMLHttp As New XMLHTTP

XMLDocument.loadXML ("<?xml version=""1.0"" ?> <root/>")
XMLDocument.documentElement.setAttribute "xmlns:dt","urn:schemas-microsoft-com:datatypes"
Set DOMElement = XMLDocument.createElement("File")
DOMElement.dataType = "bin.base64"
ADOStream.Type = adTypeBinary
ADOStream.Open
ADOStream.LoadFromFile m_sFileName
DOMElement.nodeTypedValue = ADOStream.Read
ADOStream.Close
XMLDocument.documentElement.appendChild DOMElement

MyXMLHttp.Open "POST",m_sWebPage,False,m_sUserName,m_sPassWord
MyXMLHttp.send XMLDocument
m_UploadMessage = MyXMLHttp.responseText
If m_UploadMessage = "OK" Then
m_UploadMessage = ""
UploadFile = True
Else
UploadFile = False
End If

UploadFile_Exit:
m_sFileName = ""
Set XMLDocument = Nothing
Set ADOStream = Nothing
Set DOMElement = Nothing
Set MyXMLHttp = Nothing
Exit Function

UploadFile_Error:
UploadFile = False
Debug.Print CStr(Now()) & "--->" & vbCrLf & _
"ErrAddress: VanFileTransfer->VanFileDownLoad->UploadFile" & vbCrLf & _
"ErrNumber: " & Err.Number & vbCrLf & _
"Description: " & Err.Description & vbCrLf
Err.Clear
Resume UploadFile_Exit

End Function

同样，代码中的m_UploadMessage就是返回来的信息．

二、接着说S端

需要引用microsoft active server pages object library

1、添加ASP页的接口类

Private gMyServer As Server
Private gMySession As Session
Private gMyApplication As Application
Private gMyRequest As Request
Private gMyResponse As Response

这几个是ASP的对象，会ASP的人一看就知道。

Public Function OnStartPage(MyScriptingContext As ScriptingContext)
Set gMyServer = MyScriptingContext.Server
Set gMySession = MyScriptingContext.Session
Set gMyApplication = MyScriptingContext.Application
Set gMyRequest = MyScriptingContext.Request
Set gMyResponse = MyScriptingContext.Response
End Function

Public Function OnEndPage()
Set gMyServer = Nothing
Set gMySession = Nothing
Set gMyApplication = Nothing
Set gMyRequest = Nothing
Set gMyResponse = Nothing
End Function
这二个是ASP加载时和关闭时事件。我们用来得到对象实例和释放对象。

下面就是入口函数

public function MySubMain()

'gMyRequest中就是C给过来的一些数据，处理他

gMyResponse.Write “返回给C的数据”

end function

三、ASP页内容

<%
setMyObject = server.createobject("工程名.接口类名")
MyObject.MySubMain
set MyObject = nothing
%>

把ASP页架起来就OK了。

C/S就可以通信了。

PS：如果有兴趣的朋友，可以向我索要最简单的完整实例。