Attribute VB_Name = "Module1"
Option Explicit
Const strCryptKey As String = "YOUR KEY GOES HERE"
'These functions can also be modified to send binary data, multiple variables, etc...
'**************************************************************************************
'This function sends an Execute query to the server, alerting the user to any errors
'**************************************************************************************
Public Sub sendQuery(strSQL As String, strAddress As String)
'**************************************************************************************
'special thanks to Klemens Schmid - http://www.schmidks.de/ for the XMLHTTP30 usage code
'and mime formatting
'**************************************************************************************
Dim strBody As String
Dim rc As New clsRC4
Dim resp As String
Dim oHttp As XMLHTTP30
'make use of the XMLHTTPRequest object contained in msxml.dll
Set oHttp = New XMLHTTP30
'fire of an http request
oHttp.Open "POST", strAddress, False
oHttp.setRequestHeader "Content-Type", "multipart/form-data, boundary=AaB03x"
'assemble the body. send one field and one file
strBody = _
"--AaB03x" & vbCrLf & _
"content-disposition: form-data; name=""query""" & vbCrLf & vbCrLf & _
URLEncode(rc.EncryptString(strSQL, strCryptKey)) & vbCrLf & _
"--AaB03x"
'send it
oHttp.send (strBody)
'check the feedback
If oHttp.responseText = vbNullString Then
MsgBox "No response from server"
Exit Sub
End If
resp = rc.DecryptString(URLDecode(oHttp.responseText), strCryptKey)
If resp <> "Query Executed!" Then MsgBox resp
End Sub
'**************************************************************************************
'This function is used to send a SELECT type query to the server, returning the result of that query
'in a collection object
'**************************************************************************************
Public Function getQuery(strSQL As String, strAddress As String) As String()
'**************************************************************************************
'special thanks to Klemens Schmid - http://www.schmidks.de/ for the XMLHTTP30 usage code
'and mime formatting
'**************************************************************************************
Dim strBody As String
Dim rc As New clsRC4
Dim resp As String
Dim oHttp As XMLHTTP30
'make use of the XMLHTTPRequest object contained in msxml.dll
Set oHttp = New XMLHTTP30
'fire of an http request
oHttp.Open "POST", strAddress, False
oHttp.setRequestHeader "Content-Type", "multipart/form-data, boundary=AaB03x"
'assemble the body. send one field and one file
strBody = _
"--AaB03x" & vbCrLf & _
"content-disposition: form-data; name=""rquery""" & vbCrLf & vbCrLf & _
URLEncode(rc.EncryptString(strSQL, strCryptKey)) & vbCrLf & _
"--AaB03x"
'send it
oHttp.send (strBody)
'check the feedback
If oHttp.responseText = vbNullString Then
MsgBox "No response from server"
Exit Function
End If
resp = rc.DecryptString(URLDecode(oHttp.responseText), strCryptKey)
If Left(resp, 5) = "#ERR#" Then
MsgBox Right(resp, Len(resp) - 5)
Else
getQuery = DecodeResponse(resp)
End If
End Function
'****************************************************************************
'This function takes the response from sql-link.php (in string form)
'and converts it to a two dimensional array of strings
'****************************************************************************
Private Function DecodeResponse(strResponse As String) As String()
Dim intLength
'number of rows in response
Dim intWidth
'number of columns in response
Dim strRow As String
Dim strField As String
'placeholders for row and field strings
Dim intRow As Integer
'row count
Dim intField As Integer
'column count
Dim strData As String
'strResponse is copied into strData for processing
Dim resp() As String
'return value
strData = strResponse
intLength = Val(nextItem(strData, Chr(10)))
'reads # of rows from response
If intLength = 0 Then Exit Function
intWidth = Val(nextItem(strData, Chr(10)))
'reads # of columns
ReDim resp(0 To intLength - 1, 0 To intWidth - 1)
'set size of return value
For intRow = 0 To intLength - 1
For intField = 0 To intWidth - 1
strField = DecodeNext(strData)
resp(intRow, intField) = strField
Next
Next
DecodeResponse = resp
End Function
'***********************************************************************
'URL Encode function
'***********************************************************************
Private Function URLEncode(str As String) As String
Dim strTemp, strChar As String
strTemp = ""
strChar = ""
Dim nTemp, nAsciiVal As Integer
For nTemp = 1 To Len(str)
nAsciiVal = Asc(Mid(str, nTemp, 1))
If ((nAsciiVal < 123) And (nAsciiVal > 96)) Then
strTemp = strTemp & Chr(nAsciiVal)
ElseIf ((nAsciiVal < 91) And (nAsciiVal > 64)) Then
strTemp = strTemp & Chr(nAsciiVal)
ElseIf ((nAsciiVal < 58) And (nAsciiVal > 47)) Then
strTemp = strTemp & Chr(nAsciiVal)
Else
strChar = Trim(Hex(nAsciiVal))
If nAsciiVal < 16 Then
strTemp = strTemp & "%0" & strChar
Else
strTemp = strTemp & "%" & strChar
End If
End If
Next
URLEncode = strTemp
End Function
Private Function URLDecode(str As String) As String
Dim strTemp As String: strTemp = ""
Dim strChar As String: strChar = ""
Dim strHex As String:
Dim strDec As String:
Dim lngCurrent As Long: lngCurrent = 1
Dim nAsciiVal As Integer
Dim bDone As Boolean: bDone = False
While Not bDone
If Mid(str, lngCurrent, 1) = "+" Then
strTemp = strTemp & " "
lngCurrent = lngCurrent + 1
ElseIf Mid(str, lngCurrent, 1) = "%" Then
strHex = Mid(str, lngCurrent + 1, 2)
If strHex <> "" Then
strDec = Chr(Val("&H" & strHex))
strTemp = strTemp & strDec
lngCurrent = lngCurrent + 3
End If
Else
strTemp = strTemp & Mid(str, lngCurrent, 1)
lngCurrent = lngCurrent + 1
End If
If lngCurrent > Len(str) Then
bDone = True
End If
Wend
URLDecode = strTemp
End Function
'*************************************************************
'Quotesafe - replaces single and double quotes with ‘ and ” -
'making them safe for use in db queries
'*************************************************************
Function QuoteSafe(strIn As String) As String
QuoteSafe = Replace(strIn, Chr(34), Chr(148))
QuoteSafe = Replace(QuoteSafe, Chr(39), Chr(145))
End Function
'********************************************************************
'equivalent to strtok in c
'********************************************************************
Function nextItem(ByRef strData As String, strDelimiter As String)
If strData = vbNullString Then
nextItem = vbNullString
Exit Function
End If
Dim i As Integer
i = InStr(1, strData, strDelimiter, vbTextCompare)
If i = 0 Then
nextItem = strData
strData = vbNullString
Else
nextItem = Left(strData, i - 1)
strData = Trim(Right(strData, Len(strData) - i))
End If
End Function
'**********************************************************************
'This function parses output, replacing '\\' with '\' and '\|' with '|'
'This is necessary because the delimiter here is '|', and if a '|' shows up in a DB field
'it is represented by '\|'
'the alternative here is to use an XML implementation - but that would greatly increase the
'amount of text that has to be transfered via http, slowing down the system
'**********************************************************************
Function DecodeNext(strData As String) As String
Dim strDelimiter As String
strDelimiter = "|"
If strData = vbNullString Then
DecodeNext = vbNullString
Exit Function
End If
Dim i As Integer
i = InStr(1, strData, strDelimiter, vbTextCompare)
If i = 0 Then
DecodeNext = strData
strData = vbNullString
Else
'now step through, one char at a time...
Dim strStack As String
Dim fin As Boolean
Dim cur As Integer
cur = 1
fin = False
Do While (Not fin)
Select Case Left(strData, 1)
Case "\"
If strStack = "\" Then
DecodeNext = DecodeNext & "\"
strStack = vbNullString
Else
If strStack = vbNullString Then strStack = "\"
End If
Case "|"
If strStack = "\" Then
DecodeNext = DecodeNext & "|"
strStack = vbNullString
Else
If strStack = vbNullString Then
strData = Right(strData, Len(strData) - 1)
Exit Function
End If
End If
Case Else
DecodeNext = DecodeNext & Left(strData, 1)
End Select
strData = Right(strData, Len(strData) - 1)
If Len(strData) = 0 Then fin = True
Loop
End If
End Function
|
Download
