【VBA】相対URLを絶対URLに変換したい

お世話になります

題名の件ですが、PHPのコードを
PHPで相対パスとなっているURLを絶対パスに変換する方法
VBAに直したいのですが上手く動作しません

PHPはド素人は文法も知らないド素人です
VBAも見苦しいコードになっております

詳しい方ご教示願います

VBA
1Private Function 相対URL変換(w_Base_URL As String, w_Link As String)
2
3      相対URL変換 = ""
4
5      If LTrim(InStr(w_Link, "http")) = 1 Then
6          相対URL変換 = w_Link
7          Exit Function
8      End If
9      
10      Dim tmp As Variant
11      
12      w_url = ""
13           
14      scheme = 0
15      host = 1
16      Path = 2
17      Query = 3
18      
19      Dim Base_URL(0 To 3)
20      Dim Link(0 To 3)
21      
22      Base_URL(scheme) = get_scheme(w_Base_URL)
23      Base_URL(host) = URLEncode(get_host(w_Base_URL))
24      Base_URL(Path) = get_path1(w_Base_URL)
25      Base_URL(Query) = get_query(w_Base_URL)
26      Link(scheme) = get_scheme(w_Link)
27      Link(host) = URLEncode(get_host(w_Link))
28      Link(Path) = get_path1(w_Link)
29      Link(Query) = get_query(w_Link)
30      
31      
32      If Link(host) <> "" Then
33         
34         w_url = Link(scheme) + "://" + Link(host) + Link(Path)
35         If Link(Query) <> "" Then
36            w_url = w_url + "?" + Link(Query)
37         End If
38         
39      ElseIf Link(Path) <> "" Then
40      
41         If Len(Link(Path)) > 2 And (Left(Link(Path), 2) = "./" Or Left(Link(Path), 2) = "..") Then
42             
43            tmp = Split(Link(Path), "/")
44         End If
45    
46         If Base_URL(Path) <> "" Then
47            BasePath = Base_URL(Path)
48         Else
49            BasePath = ""
50         End If
51         Debug.Print BasePath
52 
53         If InStr((BasePath), ".") > 0 Then
54            BasePath = Left(BasePath, InStr((BasePath), ".") - 1)
55         End If
56         
57         If IsEmpty(tmp) = False Then
58            For Each va In tmp
59               If va = ".." Then
60                 
61                  BasePath = Left(BasePath, InStrRev(BasePath, "/"))
62               Else
63                  If InStr(BasePath, "/") > 0 Or InStr(BasePath, "\") > 0 Then
64                     BasePath = ""
65                     Exit For
66                  End If
67               End If
68            Next va
69         End If
70      
71         Lk = Replace(w_Link, "../", "")
72         Lk = Replace(Lk, "./", "")
73         w_url = Base_URL(scheme) + "://" + Base_URL(host) + BasePath + "/" + Lk
74      
75      ElseIf Left(Link(Path), 1) = "/" Then
76         w_url = Base_URL(scheme) + "://" + Base_URL(host) + w_Link
77      Else
78         If Base_URL(Path) = "" Then
79            BasePath = ""
80         Else
81            BasePath = Base_URL(Path)
82         End If
83         
84         If InStr((BasePath), ".") > 0 Then
85            BasePath = Left(BasePath, InStr((BasePath), ".") - 1)
86         End If
87         
88         w_url = Base_URL(scheme) + "://" + Base_URL(host) + BasePath + "/" + Lk
89       
90      End If
91      
92          
93      
94      相対URL変換 = DecodeUTF8(w_url)
95      
96      
97End Function
98
99Private Function get_scheme(URL)
100
101      get_scheme = ""
102      On Error Resume Next
103      get_scheme = Mid(URL, 1, InStr(URL, ":") - 1)
104      On Error GoTo 0
105
106
107End Function
108
109Private Function get_host(URL)
110 
111     Dim RE, reMatch
112     Dim strPattern As String
113     Dim i As Long
114     Dim msg As String
115     Dim matchString As String
116
117     Set RE = CreateObject("VBScript.RegExp")
118
119     strPattern = "https?://([^/]+)/"     '検索パターン：ドメイン名の部分を（）でグルーピング化
120
121     With RE
122        .Pattern = strPattern
123        .IgnoreCase = True   '大文字と小文字を区別する
124        .Global = False       '1回目のマッチで終了
125      
126        Set reMatch = .Execute(URL)   'A列で検索実行
127        If reMatch.Count > 0 Then             'マ
128           matchString = reMatch(0).Submatches(0) '検索パターンのグルーピング化[（）内]
129           'msg = msg & matchString & vbCrLf
130           msg = msg & matchString
131        End If
132   
133    End With
134    
135    
136    get_host = msg
137    Set reMatch = Nothing
138    Set RE = Nothing
139
140End Function
141
142Private Function get_path1(URL)
143
144    get_path1 = ""
145    
146    If InStr(URL, get_scheme(URL)) = 1 Then
147        wk = Replace(URL, (get_scheme(URL) + "://" + get_host(URL)), "")
148    
149        
150       If wk = "/" Or wk = "" Then
151          wk = ""
152       Else
153         If Left(wk, 1) <> "/" Then
154            wk = "/" + wk
155         End If
156    
157         If InStr(wk, "?") > 0 Then
158            wk = Left(wk, InStr(wk, "?") - 1)
159         End If
160    
161       End If
162    Else
163       wk = URL
164    End If
165    get_path1 = wk
166    Debug.Print "wk  = :" + wk
167
168End Function
169
170Private Function get_query(URL)
171   
172    get_query = ""
173    
174    If InStr(URL, "?") > 0 Then
175    
176       get_query = Mid(URL, InStr(URL, "?") + 1)
177    End If
178   
179End Function
180
181
182
183Function DecodeUTF8(ByVal Source As String) As String
184    Dim oHtmlFile As Object
185    Dim oElement As Object
186
187    Source = Replace(Source, "\", "\")
188    Source = Replace(Source, "'", "\'")
189
190    Set oHtmlFile = CreateObject("htmlfile")
191    Set oElement = oHtmlFile.createElement("span")
192    oElement.setAttribute "id", "response"
193    oHtmlFile.appendChild oElement
194    oHtmlFile.parentWindow.execScript _
195                "document.getElementById('response').innerText " _
196                & "= decodeURIComponent('" & Source & "');", "JScript"
197    DecodeUTF8 = oElement.innerText
198End Function
199
200Public Function URLEncode( _
201   StringVal As String, _
202   Optional SpaceAsPlus As Boolean = False _
203) As String
204  Dim bytes() As Byte, b As Byte, i As Integer, space As String
205
206  If SpaceAsPlus Then space = "+" Else space = "%20"
207
208  If Len(StringVal) > 0 Then
209    With New ADODB.Stream
210      .Mode = adModeReadWrite
211      .Type = adTypeText
212      .Charset = "UTF-8"
213      .Open
214      .WriteText StringVal
215      .Position = 0
216      .Type = adTypeBinary
217      .Position = 3 ' skip BOM
218      bytes = .Read
219    End With
220
221    ReDim result(UBound(bytes)) As String
222
223    For i = UBound(bytes) To 0 Step -1
224      b = bytes(i)
225      Select Case b
226        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
227          result(i) = Chr(b)
228        Case 32
229          result(i) = space
230        Case 0 To 15
231          result(i) = "%0" & Hex(b)
232        Case Else
233          result(i) = "%" & Hex(b)
234      End Select
235    Next i
236
237    URLEncode = Join(result, "")
238  End If
239End Function

(目的をほぼ満たしたため) ttyp03さんのコードに追記して解決とします　
回答いただいた皆様ありがとうございました
※ 加筆したコードが正解かどうかは別ですが

VBA
1Private Function 相対URL変換2(w_Base_URL As String, w_Link As String)
2    Dim bcols() As String
3    Dim lcols() As String
4    Dim bcol As Variant
5    Dim lcol As Variant
6    
7    If Left(w_Link, 1) = "#" Then
8          相対URL変換2 = ""
9          Exit Function
10    End If
11    
12    If InStr(w_Link, "http") = 1 Then
13          相対URL変換2 = w_Link
14          Exit Function
15    End If
16    
17    If Right(w_Base_URL, 1) = "/" Then
18       w_Base_URL = Left(w_Base_URL, Len(w_Base_URL) - 1)
19      ' MsgBox (w_Base_URL)
20    End If
21    
22    If InStr(w_Base_URL, "/#") > 0 Then
23       w_Base_URL = Left(w_Base_URL, InStr(w_Base_URL, "/#") - 1)
24    End If
25    
26    If Right(w_Base_URL, 4) = ".htm" Then
27       w_Base_URL = Left(w_Base_URL, InStrRev(w_Base_URL, "/") - 1)
28    End If
29    
30    If Right(w_Base_URL, 5) = ".html" Then
31       w_Base_URL = Left(w_Base_URL, InStrRev(w_Base_URL, "/") - 1)
32    End If
33
34    bcols = Split(w_Base_URL, "/")
35    lcols = Split(w_Link, "/")
36
37    If Left(w_Link, 1) = "/" Then
38        ReDim Preserve bcols(3)
39        bcols(3) = Mid(w_Link, 2)
40    Else
41        For Each lcol In lcols
42            Select Case lcol
43                Case "."
44                Case ".."
45                    ReDim Preserve bcols(UBound(bcols) - 1)
46                Case Else
47                    ReDim Preserve bcols(UBound(bcols) + 1)
48                    bcols(UBound(bcols)) = lcol
49            End Select
50        Next
51    End If
52    
53    相対URL変換2 = Join(bcols, "/")
54    
55    If InStr(相対URL変換2, "#") > 0 Then
56       相対URL変換2 = ""
57    End If
58    
59End Function

ku__ra__ge

2019/06/28 07:04

どのような結果を想定していて、実際にはどのような結果になるのか。問題はどこにあると推測しているのか。その問題を解決するために調査したことはなにか。を書いてください。

otn

2019/06/28 09:22

VBAがわかるなら、PHPのコードなど無視して、自分で作れば良いのでは？と思ったけど、出だしから、 If LTrim(InStr(w_Link, "http")) = 1 Then ということは、VBAも知らないのでしょうか？それでは無理だと思います。

行動規範の内容に同意します

回答2件

ベストアンサー

暇だったので作ってみました。
厳密にはダメなパターンもあるかもしれません。
リンク先にあるhttpで始まるやつ以外は対応できていると思います。

VBA
1Sub t()
2    Debug.Print 相対URL変換("http://example.com/dir1/dir2", "../../about")
3    Debug.Print 相対URL変換("http://example.com/dir1/dir2", "./")
4    Debug.Print 相対URL変換("http://example.com/dir1/dir2", "../")
5    Debug.Print 相対URL変換("http://example.com/dir1/dir2", "../../files/test.pdf")
6    Debug.Print 相対URL変換("http://example.com/dir1/dir2", "/contact")
7End Sub
8
9Private Function 相対URL変換(w_Base_URL As String, w_Link As String)
10    Dim bcols() As String
11    Dim lcols() As String
12    Dim bcol As Variant
13    Dim lcol As Variant
14    
15    bcols = Split(w_Base_URL, "/")
16    lcols = Split(w_Link, "/")
17    
18    If Left(w_Link, 1) = "/" Then
19        ReDim Preserve bcols(3)
20        bcols(3) = Mid(w_Link, 2)
21    Else
22        For Each lcol In lcols
23            Select Case lcol
24                Case "."
25                Case ".."
26                    ReDim Preserve bcols(UBound(bcols) - 1)
27                Case Else
28                    ReDim Preserve bcols(UBound(bcols) + 1)
29                    bcols(UBound(bcols)) = lcol
30            End Select
31        Next
32    End If
33    相対URL変換 = Join(bcols, "/")
34End Function
35
36結果
37http://example.com/about
38http://example.com/dir1/dir2/
39http://example.com/dir1/
40http://example.com/files/test.pdf
41http://example.com/contact