Login   Register  
PHP Classes
elePHPant
Icontem

File: Query.bas

Recommend this page to a friend!
Stumble It! Stumble It! Bookmark in del.icio.us Bookmark in del.icio.us
  Classes of Pablo Gazmuri  >  RemoteSQL  >  Query.bas  >  Download  
File: Query.bas
Role: Auxiliary script
Content type: text/plain
Description: Visual Basic Module
Class: RemoteSQL
Provides client-side access to server-side DB
Author: By
Last change: Minor Bug Fix
Date: 11 years ago
Size: 10,078 bytes
 

Contents

Class file image Download
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