1

VBA で URL のパラメーターを解析しようとしています。例えば：

https://www.google.com/webhp?q=vba+url+parameters&utf_source=stackoverflow

「vba + url +パラメータ」へのqマッピングと「stackoverflow」へのutf_sourceマッピングを備えたハッシュテーブルのようなものを取得しようとしています。

このための既存のデータ構造/関数はありますか? それとも、自分で解析するために何かを構築する必要がありますか? 私は MSHTML ライブラリを調べましたが、明らかなものは何も見つかりません。MSHTML.HTMLAnchorElement.href 属性は単に文字列を返します。

4

2 に答える 2

8

接続文字列、URL、およびその他のキー値タイプの文字列で機能する汎用の解析関数を作成しました。仕組みは次のとおりです。

Sub TestParse()
Dim s As String

    s = "https://www.google.com/webhp?q=vba+url+parameters&utf_source=stackoverflow"
    Debug.Print Parse(s, "q", vbString, "=", "&")
    Debug.Print Parse(s, "utf_source", vbString, "=", "&")

End Sub

出力：

vba+url+parameters
stackoverflow

そして、これが機能です：

'---------------------------------------------------------------------------------------
' Procedure : Parse
' DateTime  : 7/16/2009 11:32
' Author    : Mike
' Purpose   : Parse a string of keys and values (such as a connection string) and return
'               the value of a specific key.
' Usage     - Use to pass multiple arguments to forms via OpenArgs in MS Access
'           - Keep multiple arguments in the Tag property of forms and controls.
'           - Use to parse a user-entered search string.
' Notes     - Defaults to using connection string formatted key-value pairs.
'           - Specifying a ReturnType guarantees the type of the result and allows the
'               function to be safely called in certain situations.
'  7/23/09  : Modified to allow the use of a literal space as a delimiter while allowing
'               values to have spaces as well. 
'---------------------------------------------------------------------------------------
'
Function Parse(Txt As Variant, Key As String, _
               Optional ReturnType As VbVarType = vbVariant, _
               Optional AssignChar As String = "=", _
               Optional Delimiter As String = ";") As Variant    
Dim StartPos As Integer, EndPos As Integer, Result As Variant
    Result = Null
    If IsNull(Txt) Then
        Parse = Null
    ElseIf Len(Key) = 0 Then
        EndPos = InStr(Txt, AssignChar)
        If EndPos = 0 Then
            Result = Trim(Txt)
        Else
            If InStrRev(Txt, " ", EndPos) = EndPos - 1 Then
                EndPos = InStrRev(Txt, Delimiter, EndPos - 2)
            Else
                EndPos = InStrRev(Txt, Delimiter, EndPos)
            End If
            Result = Trim(Left(Txt, EndPos))
        End If
    Else
        StartPos = InStr(Txt, Key & AssignChar)
        'Allow for space between Key and Assignment Character
        If StartPos = 0 Then
            StartPos = InStr(Txt, Key & " " & AssignChar)
            If StartPos > 0 Then StartPos = StartPos + Len(Key & " " & AssignChar)
        Else
            StartPos = StartPos + Len(Key & AssignChar)
        End If
        If StartPos = 0 Then
            Parse = Null
        Else
            EndPos = InStr(StartPos, Txt, AssignChar)
            If EndPos = 0 Then
                If Right(Txt, Len(Delimiter)) = Delimiter Then
                    Result = Trim(Mid(Txt, StartPos, _
                                      Len(Txt) - Len(Delimiter) - StartPos + 1))
                Else
                    Result = Trim(Mid(Txt, StartPos))
                End If
            Else
                If InStrRev(Txt, Delimiter, EndPos) = EndPos - 1 Then
                    EndPos = InStrRev(Txt, Delimiter, EndPos - 2)
                Else
                    EndPos = InStrRev(Txt, Delimiter, EndPos)
                End If
                If EndPos < StartPos Then
                    Result = Trim(Mid(Txt, StartPos))
                Else
                    Result = Trim(Mid(Txt, StartPos, EndPos - StartPos))
                End If
            End If

        End If
    End If
    Select Case ReturnType
    Case vbBoolean
        If IsNull(Result) Or Len(Result) = 0 Or Result = "False" Then
            Parse = False
        Else
            Parse = True
            If IsNumeric(Result) Then
                If Val(Result) = 0 Then Parse = False
            End If
        End If

    Case vbCurrency, vbDecimal, vbDouble, vbInteger, vbLong, vbSingle
        If IsNumeric(Result) Then
            Select Case ReturnType
            Case vbCurrency: Parse = CCur(Result)
            Case vbDecimal: Parse = CDec(Result)
            Case vbDouble: Parse = CDbl(Result)
            Case vbInteger: Parse = CInt(Result)
            Case vbLong: Parse = CLng(Result)
            Case vbSingle: Parse = CSng(Result)
            End Select
        Else
            Select Case ReturnType
            Case vbCurrency: Parse = CCur(0)
            Case vbDecimal: Parse = CDec(0)
            Case vbDouble: Parse = CDbl(0)
            Case vbInteger: Parse = CInt(0)
            Case vbLong: Parse = CLng(0)
            Case vbSingle: Parse = CSng(0)
            End Select
        End If

    Case vbDate
        If IsDate(Result) Then
            Parse = CDate(Result)
        ElseIf IsNull(Result) Then
            Parse = 0
        ElseIf IsDate(Replace(Result, "#", "")) Then
            Parse = CDate(Replace(Result, "#", ""))
        Else
            Parse = 0
        End If

    Case vbString
        Parse = Nz(Result, vbNullString)

    Case Else
        If IsNull(Txt) Then
            Parse = Null
        ElseIf Result = "True" Then
            Parse = True
        ElseIf Result = "False" Then
            Parse = False
        ElseIf IsNumeric(Result) Then
            Parse = Val(Result)
        Else
            Parse = Result
        End If
    End Select
End Function
于 2012-07-26T18:25:42.930 に答える
1

あなたが欲しいのはDictionaryオブジェクトだと思います。

疑問符の右側のすべてを抽出し、値を辞書に追加できます。

于 2012-07-26T18:16:50.217 に答える