如何解析VBA中的URL参数？

Question

我想解析VBA中的URL中的参数。例如：

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

我期待得到的东西如哈希表符合Q映射到“VBA +网址+参数”和utf_source映射到“计算器”。

是否有一个现有的数据结构/功能呢？或者我需要建立一些东西来解析它自己？我浏览过MSHTML库，找不到任何明显的东西，而MSHTML.HTMLAnchorElement.href属性只是返回一个字符串。

Answer 1

我想你想要的是Dictionary对象。

您可以提取问号右侧的所有内容，并将这些值添加到字典中。

Answer 2

我写了一个通用的Parse函数，它可以处理连接字符串，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