<ole>
Du kan også bruge wininet ... skriv dette i et modul:
Option Explicit
Private 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
Private 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
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private 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 dwFlags As Long, ByVal dwContext As Long) As Long
Private 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
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInternetHandle As Long) As Boolean
Private Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lModifiers As Long) As Integer
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_SERVICE_HTTP As Long = 3
Private Const INTERNET_DEFAULT_HTTP_PORT As Long = 80
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const HTTP_ADDREQ_FLAG_ADD As Long = &H20000000
Private Const HTTP_ADDREQ_FLAG_REPLACE As Long = &H80000000
Private Const HTTP_USER_AGENT As String = "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
Public Function POSTForm(ByVal strServer As String, _
ByVal strScript As String, _
ByVal strPost As String) As String
Dim blnLoop As Boolean
Dim intFree As Integer
Dim strRead As String * 2048
Dim strHeader As String
Dim strResult As String
Dim lngOfRead As Long
Dim strBoundary As String
Dim hInternetOpen As Long
Dim hInternetConnect As Long
Dim hHttpOpenRequest As Long
hInternetOpen = InternetOpen(HTTP_USER_AGENT, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
If Not hInternetOpen = 0 Then
hInternetConnect = InternetConnect(hInternetOpen, strServer, INTERNET_DEFAULT_HTTP_PORT, vbNullString, "HTTP/1.0", INTERNET_SERVICE_HTTP, 0&, 0&)
If Not hInternetConnect = 0 Then
hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "POST", URLPathEncode(strScript), "HTTP/1.0", vbNullString, 0&, INTERNET_FLAG_RELOAD, 0&)
If Not hHttpOpenRequest = 0 Then
strHeader = "Content-Type: application/x-www-form-urlencoded" & vbCrLf
Call HttpSendRequest(hHttpOpenRequest, strHeader, Len(strHeader), strPost, Len(strPost))
Do
strRead = vbNullString
blnLoop = InternetReadFile(hHttpOpenRequest, strRead, Len(strRead), lngOfRead)
strResult = (strResult & PHP2CRLF(Left$(strRead, lngOfRead)))
If Not CBool(lngOfRead) Or Not blnLoop Then Exit Do
Loop
Call InternetCloseHandle(hInternetOpen)
Call InternetCloseHandle(hInternetConnect)
Call InternetCloseHandle(hHttpOpenRequest)
End If
End If
End If
POSTForm = strResult
End Function
Private Function PHP2CRLF(ByVal strText As String) As String
Dim i As Long
Dim strOut As String
Dim intAsc As Integer
For i = 1 To Len(strText)
intAsc = Asc(Mid$(strText, i, 1))
Select Case intAsc
Case 13
Case 10
strOut = (strOut & vbCrLf)
Case Else
strOut = (strOut & Chr$(intAsc))
End Select
Next
PHP2CRLF = strOut
End Function
Public Function URLEncode(ByVal bstrIn As String) As String
Dim i As Long
Dim Char As String
For i = Len(bstrIn) To 1 Step -1
Char = Mid$(bstrIn, i, 1)
Select Case Asc(UCase$(Char))
Case vbKey0 To vbKey9, vbKeyA To vbKeyZ
Case 32
Mid$(bstrIn, i, 1) = "+"
Case Else
bstrIn = Left$(bstrIn, i - 1) & "%" & Hex2(Asc(Char)) & Mid$(bstrIn, i + 1)
End Select
Next i
URLEncode = bstrIn
End Function
Private Function URLPathEncode(ByVal bstrIn As String) As String
Const ValidChars = "!#$&*+-./:?@_~"
Dim i As Long
Dim Char As String
For i = Len(bstrIn) To 1 Step -1
Char = Mid$(bstrIn, i, 1)
Select Case Asc(UCase$(Char))
Case vbKey0 To vbKey9, vbKeyA To vbKeyZ
Case Else
If InStr(ValidChars, Char) = 0 Then
bstrIn = Left$(bstrIn, i - 1) & "%" & Hex2(Asc(Char)) & Mid$(bstrIn, i + 1)
End If
End Select
Next i
URLPathEncode = bstrIn
End Function
'Hex2 for URLPathEncode, URLEncode
Private Function Hex2(ByVal n As Long) As String
If n And &HF0& Then
Hex2 = Hex$(n)
Else
Hex2 = "0" & Hex$(n)
End If
End Function
' ------------------- modul slut ---------------------
Opret så en form med to textBox'e: 'txtNavn' og 'txtEmail', en multiLine textBox: 'txtReturn' - og en knap: 'cmdPost':
Option Explicit
Private Sub cmdPost_Click()
Dim strPost As String
' Husk at bruge URLEncode() så alle tegn bliver rigtige.
strPost = "navn=" & URLEncode(txtNavn.Text) & "&"
strPost = strPost & "email=" & URLEncode(txtEmail.Text)
'MsgBox strPost
' POSTForm(server navn eller IP, path og script, post string)
txtReturn.Text = POSTForm("
www.domain.dk", "sti/til/vbPostForm.php", strPost)
End Sub
' ------------------- form slut ---------------------
Testfilen 'vbPostForm.php' kunne se sådan sådan ud:
Informationer er modtaget:
<?=$_POST["navn"]."\n"?>
<?=$_POST["email"]."\n"?>
' ------------------- phpfil slut ---------------------
/mvh
</bole>
