Если требуется добавить в URL новый GET-параметр, или заменить значение имеющегося, - можно воспользоваться этой функцией.
Sub ПримерИспользования() URL$ = "http://market.yandex.ru/model.xml?modelid=968028&np=0" URL$ = URL_SetParameter(URL$, "how", "aprice") ' такого параметра нет - он добавляется URL$ = URL_SetParameter(URL$, "np", "1") ' такой параметр есть - он заменяется Debug.Print URL$ ' на выходе получаем ссылку ' <a href="http://market.yandex.ru/model.xml?modelid=968028&hid=512743&how=aprice&np=1 End" title="http://market.yandex.ru/model.xml?modelid=968028&hid=512743&how=aprice&np=1 End">http://market.yandex.ru/model.xml?modelid=968028&hid=512743&how=aprice&n...</a> Sub
Код функции:
Function URL_SetParameter(ByVal URL$, ByVal Param$, ByVal ParamValue$) As String ' в качестве параметра принимает исходную ссылку, название GET-параметра, и его значение ' находит в ссылке значение GET-параметра, и заменяет на новое ' если в ссылке нет GET-параметра Param$ - добавляет его ' Возвращает новую ссылку On Error Resume Next Dim sep$, arr, suffix$ Select Case True Case InStr(1, URL$, "?" & Param$ & "=", vbTextCompare) > 0: sep$ = "?" & Param$ & "=" Case InStr(1, URL$, "&" & Param$ & "=", vbTextCompare) > 0: sep$ = "&" & Param$ & "=" Case Else: sep$ = "" End Select If Len(sep$) Then ' GET-параметр Param$ присутствует в URL - меняем его значение arr = Split(URL$, sep$) If UBound(arr) > 1 Then URL_SetParameter = arr(0) & sep$ & ParamValue$ ' ошибочная ссылка - 2 одинаковых параметра Else ' корректная исходная ссылка If arr(1) Like "*&*" Then suffix$ = "&" & Split(arr(1), "&", 2)(1) URL_SetParameter = arr(0) & sep$ & ParamValue$ & suffix$ End If Else ' GET-параметр Param$ отсутствует в URL - добавляем его If URL$ Like "*[?]*=*" Then URL_SetParameter = URL$ & "&" & Param$ & "=" & ParamValue$ Else URL_SetParameter = URL$ & "?" & Param$ & "=" & ParamValue$ End If End If End Function
Комментарии
Отправить комментарий