Url String Unencode

UnEncode the Search engine URLs.

Url String Unencode Module

The following snippet must be put in a module (for example: mUnEncode.bas).

'Option Explicit

Private OnBits(0 To 31) As Long

'decode string
Public Function Decode(ByVal sString As String, ByVal sEncode As String)

    If sEncode = "" Then
        sEncode = "ND"
    End If

        Select Case sEncode
        Case "UTF-8"
            Decode = DecodeUTF(sString)
        Case "SHIFT-JIS"
            Decode = DecodeShiftJis(sString)
        Case "EUC-JP"
            Decode = DecodeEUC(sString)
        Case "ND"
            Decode = DecodeUTF(sString)
            If Decode = "ERROR" Then
                Decode = DecodeEUC(sString)
                If Decode = "ERROR" Then
                    Decode = DecodeShiftJis(sString)
                End If
            End If
        Case Else
           Open App.Path & "/encode.txt" For Append As #3
            Print #3, sEncode
            Close #3
            'try to decode
            Decode = DecodeUTF(sString)
            If Decode = "ERROR" Then
                Decode = DecodeEUC(sString)
                If Decode = "ERROR" Then
                    Decode = DecodeShiftJis(sString)
                End If
            End If
        End Select

End Function

'===== URL エンコードモジュール =====
'(C)1999-2002 けるべ
'MAIL : NULL
'HOME : http://www.geocities.co.jp/SilkRoad/4511/
'----- UrlDecode 関数 Ver 1.02 -----
'URL エンコードされた文字列をデコードし、デコードされた
'文字列をバイト型配列に格納します。
'
'引数 strEncoded
'   URL エンコードされている文字列を指定します。
'
'引数 bytResult()
'   URL デコードされた文字コードを格納するバイト型配列を指定します。
'   関数を呼び出すプロシージャで動的配列として宣言して指定して下さい。
'
'戻り値
'   バイト型配列 bytResult() に格納したサイズを返します。
'   関数が失敗した場合は 0 が返ります。
'
'デコード結果を文字列型ではなくバイト型配列に格納する仕様にしたのは、
'EUC や JIS を URL エンコードした文字列も扱えるようにするためです。
'バイト型配列に格納した文字列をVBで扱うためには、Unicode に
'変換する必要があります。文字コードが Shift-JIS であれば
'StrConv 関数で Unicode に変換できますが、EUC や JIS の場合は
'NKF32.DLL などでいったん Shift-JIS に変換してやる必要があります。
'
'なんかやたらと長いコードになってしまいましたが、7 割方は
'URL エンコードされた文字列として不適切な文字が含まれていた場合の
'処理であり、処理速度には影響ないと思うのでご安心を(^^;
'
Private Function UrlDecode _
    (ByRef strEncoded As String, _
     ByRef bytResult() As Byte) As Long

 Dim lngLength As Long                                                          '文字列の長さを格納する
 Dim strSingle As String                                                        '抜き出した 1 文字を格納する
 Dim strHex As String                                                           '"&H??" の 16 進表記文字コードを格納する
 Dim lngReadCount As Long                                                       '文字列読み込み位置カウンタ
 Dim lngWriteCount As Long                                                      'バッファ書き込み位置カウンタ
 Dim lngAsc As Long                                                             '1 文字分の文字コードを格納

    lngLength = Len(strEncoded)                                                 'URL エンコードされている文字列の長さを得る
    If Not CBool(lngLength) Then Exit Function                                  '0 文字の場合、関数を抜ける
    ReDim bytResult(lngLength - 1)                                              'デコード結果格納バッファ領域を確保
    strHex = "&H00"                                                             '16 進表記文字コードを格納する領域を確保
    lngReadCount = 1                                                            '読み込みカウンタは 1 から開始

    Do                                                                          '文字列の終端までループ
        strSingle = Mid$(strEncoded, lngReadCount, 1)                           '1 文字を抜き出す
        If strSingle = "%" Then                                                 '"%" であった場合
            If (lngReadCount + 2) <= lngLength Then                             '文字列の終端に達していない場合(残り 2 文字)
                Mid(strHex, 3, 2) = Mid$(strEncoded, lngReadCount + 1, 2)       '"%" の次の 2 文字を抜き出し "&H??" にする
                If IsNumeric(strHex) Then                                       '"&H??" が数値として評価できる場合
                    bytResult(lngWriteCount) = CByte(strHex)                    '"&H??" を数値に変換し配列に代入
                    lngReadCount = lngReadCount + 3                             '読み込みカウンタを 3 増やす
                    lngWriteCount = lngWriteCount + 1                           '書き込みカウンタをインクリメント
                Else                                                            '"&H??" が数値として評価できなかった場合
                    If IsNumeric(Left$(strHex, 3)) Then                         '"&H?" が数値として評価できる場合
                        bytResult(lngWriteCount) = CByte(Left$(strHex, 3))      '"&H?" を数値に変換し配列に代入
                        lngReadCount = lngReadCount + 2                         '読み込みカウンタを 2 増やす
                        lngWriteCount = lngWriteCount + 1                       '書き込みカウンタをインクリメント
                    Else                                                        '"&H?" が数値として評価できない場合
                        bytResult(lngWriteCount) = &H25                         '"%" だけを配列に代入
                        lngReadCount = lngReadCount + 1                         '読み込みカウンタをインクリメント
                        lngWriteCount = lngWriteCount + 1                       '書き込みカウンタをインクリメント
                    End If
                End If
            ElseIf (lngReadCount + 1) = lngLength Then                          '文字列の終端に達していない場合(残り 1 文字)
                Mid(strHex, 3, 1) = Mid$(strEncoded, lngReadCount + 1, 1)       '"%" の次の 1 文字を抜き出し "&H??" にする
                If IsNumeric(Left$(strHex, 3)) Then                             '"&H?" が数値として評価できる場合
                    bytResult(lngWriteCount) = CByte(Left$(strHex, 3))          '"&H?" を数値に変換し配列に代入
                    lngReadCount = lngReadCount + 2                             '読み込みカウンタを 2 増やす
                    lngWriteCount = lngWriteCount + 1                           '書き込みカウンタをインクリメント
                Else                                                            '"&H?" が数値として評価できない場合
                    bytResult(lngWriteCount) = &H25                             '"%" だけを配列に代入
                    lngReadCount = lngReadCount + 1                             '読み込みカウンタをインクリメント
                    lngWriteCount = lngWriteCount + 1                           '書き込みカウンタをインクリメント
                End If
            Else                                                                '文字列の終端に達していた場合
                bytResult(lngWriteCount) = &H25                                 '"%" だけを配列に代入
                lngReadCount = lngReadCount + 1                                 '読み込みカウンタをインクリメント
                lngWriteCount = lngWriteCount + 1                               '書き込みカウンタをインクリメント
            End If
        ElseIf strSingle = "+" Then                                             '"+" であった場合
            bytResult(lngWriteCount) = &H20                                     '半角スペース(" ")を代わりに入れる
            lngReadCount = lngReadCount + 1                                     '読み込みカウンタをインクリメント
            lngWriteCount = lngWriteCount + 1                                   '書き込みカウンタをインクリメント
        Else                                                                    'その他の文字であった場合
            lngAsc = CLng(Asc(strSingle)) And &HFFFF&                           '文字コードを符号無し長整数型(嘘)にキャスト
            If lngAsc <= &HFF& Then                                             '"&HFF" 以下であった場合
                bytResult(lngWriteCount) = CByte(lngAsc)                        'バイト型にキャストし、配列に代入
                lngReadCount = lngReadCount + 1                                 '読み込みカウンタをインクリメント
                lngWriteCount = lngWriteCount + 1                               '書き込みカウンタをインクリメント
            Else                                                                'その他の文字(マルチバイト文字)の場合
                lngReadCount = lngReadCount + 1                                 '読み込みカウンタをインクリメント
            End If
        End If
    Loop Until lngReadCount > lngLength

    If lngWriteCount Then                                                       '実際にバッファに書き込まれた場合
        ReDim Preserve bytResult(lngWriteCount - 1)                             'バッファサイズを実際のサイズに削る
        UrlDecode = lngWriteCount                                               '書き込んだサイズを返す
    Else                                                                        'バッファに何も書き込まれなかった場合
        Erase bytResult                                                         '配列を消去
    End If

End Function

Private Function DecodeShiftJis(ByVal sTemp As String)

    Dim bytResult() As Byte

    Call UrlDecode(sTemp, bytResult)
    DecodeShiftJis = StrConv(bytResult, vbUnicode)

End Function

Private Function DecodeUTF(ByVal Source As String)
On Error Resume Next

    sTmp = ""
    iCount = 1
    lSrcLen = Len(Source)
    Do Until iCount > lSrcLen
        sChr = Mid(Source, iCount, 1)
        iCount = iCount + 1
        If sChr = "+" Then
            sChr = " "
        ElseIf sChr = "%" Then
            sHex = Mid(Source, iCount, 2)
            iCount = iCount + 2
            iAsc = CByte("&H" & sHex)
                'test first bit
                If (0 <= iAsc And iAsc <= 127) Then
'                    MsgBox ("one bit")
                    sChr = Chr(iAsc)
                ElseIf (128 <= iAsc And iAsc <= 193) Then
                    DecodeUTF = "ERROR"
                    Exit Function
                ElseIf (194 <= iAsc And iAsc <= 223) Then
'                    MsgBox ("two bit")

                    code1 = iAsc

                    sHex = Mid(Source, iCount + 1, 2)
                    iCount = iCount + 2
                    code2 = CByte("&H" & sHex)
                    iCount = iCount + 1

                    bit1 = LShiftLong(CInt("&H" & code1 And &H1F), 6)
                    bit2 = CInt("&H" & code2 And &H3F)
                    sChr = ChrW((bit1 Or bit2 Or bit3))
                '3 bit char
                ElseIf (224 <= iAsc And iAsc <= 239) Then
'                    MsgBox ("three bit")
                    temp = Mid(Source, iCount - 2, 8)
                    vTemp = Split(temp, "%")
                    bit1 = LShiftLong(CInt("&H" & vTemp(0) And &HF), 12)
                    bit2 = LShiftLong(CInt("&H" & vTemp(1) And &H3F), 6)
                    bit3 = CInt("&H" & vTemp(2) And &H3F)
                    sChr = ChrW((bit1 Or bit2 Or bit3))
                    iCount = iCount + 6
                ElseIf (240 <= iAsc And iAsc <= 244) Then
                    'MsgBox ("four bit")
                End If
        End If
        sTmp = sTmp & sChr
    Loop
    DecodeUTF = sTmp
End Function

Private Function LShiftLong(ByVal Value As Long, _
    ByVal Shift As Integer) As Long

    MakeOnBits

    If (Value And (2 ^ (31 - Shift))) Then GoTo OverFlow

    LShiftLong = ((Value And OnBits(31 - Shift)) * (2 ^ Shift))

    Exit Function

OverFlow:

    LShiftLong = ((Value And OnBits(31 - (Shift + 1))) * _
       (2 ^ (Shift))) Or &H80000000

End Function

Private Function RShiftLong(ByVal Value As Long, _
   ByVal Shift As Integer) As Long
    Dim hi As Long
    MakeOnBits
    If (Value And &H80000000) Then hi = &H40000000

    RShiftLong = (Value And &H7FFFFFFE) \ (2 ^ Shift)
    RShiftLong = (RShiftLong Or (hi \ (2 ^ (Shift - 1))))
End Function

Private Sub MakeOnBits()
    Dim j As Integer, _
        v As Long

    For j = 0 To 30

        v = v + (2 ^ j)
        OnBits(j) = v

    Next j

    OnBits(j) = v + &H80000000

End Sub

Private Function DecodeEUC(ByVal sString As String)
On Error GoTo ErrHandler

Dim code
Dim code1
Dim code2

DecodeEUC = ""
iCount = 1
Do Until iCount > LenB(sString)

    sChr = Mid(sString, iCount, 1)
    iCount = iCount + 1
    If sChr = "+" Then
        sChr = " "
    ElseIf sChr = "%" Then
        sHex = Mid(sString, iCount, 2)
        iCount = iCount + 2
        code = CByte("&H" & sHex)

        'code = AscB(MidB(sString, k, 1))
        If code < &H80 Then
            euc2sjis = euc2sjis & Chr(code)
        ElseIf code = &H8E Then

            sHex = Mid(sString, iCount, 2)
            iCount = iCount + 2
            code = CByte("&H" & sHex)

            euc2sjis = euc2sjis & Chr(code)
        Else
            code1 = code

            sHex = Mid(sString, iCount + 1, 2)
            iCount = iCount + 2
            code2 = CByte("&H" & sHex)
            iCount = iCount + 1
            code = jis2sjis((code1 And &H7F) * 256 + (code2 And &H7F))
            If code Then
                DecodeEUC = DecodeEUC & Chr(code)
            Else
                'StdOut.Write "%" & Right(Hex(code1 + 256), 2) & "%" & Right(Hex(code2 + 256), 2)
                'MsgBox ("Invalid EUC code : " & Right(Hex(code1 + 256), 2) & Right(Hex(code2 + 256), 2))
                DecodeEUC = "ERROR"
                Exit Function
            End If
        End If
    Else
        DecodeEUC = DecodeEUC & sChr
    End If
Loop

Exit Function
ErrHandler:
    DecodeEUC = "ERROR"

End Function

Private Function jis2sjis(j)
Dim s
Dim a
Dim b

a = j \ 256
b = j Mod 256
If 33 <= a And a <= 94 Then
  If a Mod 2 Then
    If 33 <= b And b <= 95 Then
      s = a * 128 + b + 28831
    ElseIf 96 <= b And b <= 126 Then
      s = a * 128 + b + 28832
    Else
      s = 0
    End If
  Else
    If 33 <= b And b <= 126 Then
      s = a * 128 + b + 28798
    Else
      s = 0
    End If
  End If
ElseIf 95 <= a And a <= 126 Then
  If a Mod 2 Then
    If 33 <= b And b <= 95 Then
      s = a * 128 + b + 45215
    ElseIf 96 <= b And b <= 126 Then
      s = a * 128 + b + 45216
    Else
      s = 0
    End If
  ElseIf 33 <= b And b <= 126 Then
    s = a * 128 + b + 45182
  Else
    s = 0
  End If
Else
  s = 0
End If
If s = 0 Then
  'MsgBox ("Invalid JIS Code : " & Right(Hex(a + 256), 2) & Right(Hex(b + 256), 2))
  s = "ERROR"
End If
jis2sjis = s
End Function

Search Engine Encode Detection

The function below will analize an URL from a search engine and return an array

'function to deal with search engines

'vParam(0) URL
'vParam(1) Search string
'vParam(2) Encoding
Function GetParam(ByVal sURL As String) As String()
'after http://
    Dim vParam(3) As String

    sURL = Mid(sURL, 8, Len(sURL) - 7)
    vParam(0) = "http://" & LCase(Left(sURL, InStr(sURL, "/")))

    'GOOGLE
    If InStr(vParam(0), "google") > 0 Then
        iStart = InStr(sURL, "?q=") + InStr(sURL, "&q=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        iStart = InStr(sURL, "ie=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(2) = UCase(sTemp)
        Else
            vParam(2) = ""
        End If

    End If

    'MSN
    If InStr(vParam(0), "msn.co") > 0 Then
        iStart = InStr(sURL, "?q=") + InStr(sURL, "&q=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        'TODO: find msn encoding
        vParam(2) = ""
    End If

    'LIVE
    If InStr(vParam(0), "live.co") > 0 Then
        iStart = InStr(sURL, "?q=") + InStr(sURL, "&q=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        'TODO: find live encoding
        vParam(2) = ""
    End If

    'YAHOO
    If InStr(vParam(0), "yahoo") > 0 Then
        iStart = InStr(sURL, "?p=") + InStr(sURL, "&p=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        iStart = InStr(sURL, "ei=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(2) = UCase(sTemp)
        Else
            vParam(2) = ""
        End If

    End If

    'GOO
    If InStr(vParam(0), "goo.ne") > 0 Then
        iStart = InStr(sURL, "MT=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        iStart = InStr(sURL, "IE=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(2) = UCase(sTemp)
        Else
            vParam(2) = ""
        End If

    End If

    'NIFTY
    If InStr(vParam(0), "nifty") > 0 Then
        iStart = InStr(sURL, "Text=")
        If iStart > 0 Then
            iStart = iStart + 5
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        iStart = InStr(sURL, "ie=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(2) = UCase(sTemp)
        Else
            vParam(2) = ""
        End If

    End If

    'INFOSEEK
    If InStr(vParam(0), "infoseek") > 0 Then
        iStart = InStr(sURL, "qt=")
        If iStart > 0 Then
            iStart = iStart + 3
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        'TODO: find infoseek encoding
        vParam(2) = ""

    End If

    'BIGLOBE
    If InStr(vParam(0), "biglobe") > 0 Then
        iStart = InStr(sURL, "q=")
        If iStart > 0 Then
            iStart = iStart + 2
            sTemp = Mid(sURL, iStart, Len(sURL))
            iEnd = InStr(sTemp, "&") - 1
            If iEnd > 0 Then
                sTemp = Left(sTemp, iEnd)
            End If
            vParam(1) = sTemp
        Else
            vParam(1) = ""
        End If

        'TODO: find infoseek encoding
        vParam(2) = ""

    End If

    'fix encode
    If vParam(2) = "SHIFTJIS" Or vParam(2) = "SHIFT_JIS" Or vParam(2) = "S-JIS" Or vParam(2) = "X-SJIS" Or vParam(2) = "SJIS" Then
        vParam(2) = "SHIFT-JIS"
    End If
    If vParam(2) = "UTF8" Then
        vParam(2) = "UTF-8"
    End If
    If vParam(2) = "EUCJP" Then
        vParam(2) = "EUC-JP"
    End If
    'Return array
    GetParam = vParam

End Function
Unless otherwise stated, the content of this page is licensed under Creative Commons Attribution-ShareAlike 3.0 License