Excel_マクロ_法令検索API_条文
初めて、マクロ記録というものを試してみました。上のリンク先の記事のVBAを少し書き換えて、新しいExcelファイルで動くかどうか試してみました。
Option Private Module
Sub E_Gav(eType As Long, Article As Long, Plus As Long, Item As Long, f As UserForm)
Dim objXMLHttp As Object, XMLstr As String, str As String, tx As String, Bodystr As String, V(20), n(20)
'--------------------------------------------------------------------------------
' HTTP通信用定義。
'--------------------------------------------------------------------------------
Dim i As Long, num As Long, tmp As String, ArtStr As String, KakkoFlg As Long
Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
objXMLHttp.Open "GET", E_URL(eType, Article, Plus, ArtStr)
objXMLHttp.Send
'--------------------------------------------------------------------------------
'HTTPリクエストをするIXMLHTTPRequestオブジェクト。
'文字列変換｡指定した数だけ繰り返した文字列を取得｡階差有り｡
'--------------------------------------------
For i = 1 To 100000
If objXMLHttp.readyState = 4 Then Exit For
DoEvents
If i = 100000 Then MsgBox "終了": Exit Sub
'--------------------------------------------------------------------------------
'100000回実行したら、プログラムは終了（一旦ファイルを閉じる。）
'--------------------------------------------
Next
XMLstr = objXMLHttp.responseText
f.Title = E_StrSearch(XMLstr, "ArticleCaption")
For i = 1 To 20
n(i) = E_NoSearch(XMLstr, "Paragraph", i)
If n(i) = 0 Then n(i) = E_NoSearch(XMLstr, "Paragraph Hide=""false""", i)
If n(i) = 0 Then n(i) = Len(XMLstr)
'--------------------------------------------------------------------------------
'返す文字列の定義。条、項、号。
'--------------------------------------------
Next
For i = 1 To 20
If n(i + 1) = n(i) Then Exit For
For j = n(i) To n(i + 1)
tmp = Mid(XMLstr, j, 1)
If tmp = ">" Then
flg = True
ElseIf tmp = "<" Then
flg = False
End If
If flg And tmp <> ">" And tmp <> " " Then
V(i) = V(i) & tmp
End If
'--------------------------------------------------------------------------------
'見回りを止めて文字列を返す場合を定義。tmp・・・一時的に値を格納。
'--------------------------------------------
Next
V(i) = Replace(V(i), vbLf, "\")
V(i) = Replace(V(i), vbCrLf, "\")
V(i) = Replace(V(i), vbCr, "\")
V(i) = Replace(V(i), "\" & "\" & "\" & "\", "\")
V(i) = Replace(V(i), "\" & "\" & "\", "\")
V(i) = Replace(V(i), "\" & "\", "\")
If Left(V(i), 1) = "\" Then V(i) = Mid(V(i), 2)
If Right(V(i), 1) = "\" Then V(i) = Mid(V(i), 1, Len(V(i)) - 1)
If IsNumeric(Left(V(i), 1)) Then V(i) = Mid(V(i), 2)
If Left(V(i), 1) = "\" Then V(i) = Mid(V(i), 2)
V(i) = Replace(V(i), "\", "<Br>")
'--------------------------------------------------------------------------------
'置き換え。セル内・メッセージボックス改行。文字結合。
'--------------------------------------------
Next
tx = "<b>" & f.Controls("OptionButton" & eType).Caption & ArtStr & "</b><Br>"
For i = 1 To 20
If V(i) <> "" Then
If i = Item Then tx = tx & "<FONT COLOR=#0000DD>"
tx = tx & "<b>【第" & i & "項】</b>" & "<Br>" & V(i) & "<Br>"
If i = Item Then tx = tx & "</FONT>"
End If
'--------------------------------------------------------------------------------
'表示されるフォームの設定。
'--------------------------------------------
Next
KakkoFlg = 0
For j = 1 To Len(tx)
tmp = Mid(tx, j, 1)
If tmp = "（" Or tmp = "(" Then
Bodystr = Bodystr & "<FONT COLOR=#777777>（"
KakkoFlg = KakkoFlg + 1
ElseIf tmp = "）" Or tmp = ")" Then
Bodystr = Bodystr & "）</FONT>"
KakkoFlg = KakkoFlg - 1
ElseIf Mid(tx, j, 1) = "。" And KakkoFlg = 0 Then
Bodystr = Bodystr & "<b>。</b>"
ElseIf Mid(tx, j, 2) = "場合" Then
Bodystr = Bodystr & "<FONT COLOR=#009900>場合</FONT>"
j = j + 1
ElseIf Mid(tx, j, 2) = "とき" Then
Bodystr = Bodystr & "<FONT COLOR=#009900>とき</FONT>"
j = j + 1
ElseIf Mid(tx, j, 2) = "除く" Then
Bodystr = Bodystr & "<FONT COLOR=#FF3366>除く</FONT>"
j = j + 1
ElseIf Mid(tx, j, 2) = "及び" Then
Bodystr = Bodystr & "<FONT COLOR=#FF9900>および</FONT>"
j = j + 1
ElseIf Mid(tx, j, 3) = "並びに" Then
Bodystr = Bodystr & "<FONT COLOR=#FFCC00>並びに</FONT>"
j = j + 2
ElseIf Mid(tx, j, 2) = "又は" Then
Bodystr = Bodystr & "<FONT COLOR=#FF9900>又は</FONT>"
j = j + 1
ElseIf Mid(tx, j, 4) = "若しくは" Then
Bodystr = Bodystr & "<FONT COLOR=#FFCC00>若しくは</FONT>"
j = j + 3
ElseIf Mid(tx, j, 3) = "ただし" Then
Bodystr = Bodystr & "<FONT COLOR=#FF0000><b>ただし</b></FONT>"
j = j + 2
ElseIf InStr("一二三四五六七八九十百千", tmp) > 0 Then
num = E_number(num, tmp)
ElseIf num <> 0 Then
Bodystr = Bodystr & num & tmp
num = 0
Else
Bodystr = Bodystr & tmp
End If
'--------------------------------------------------------------------------------
'括弧書きフラグ。開始位置、場合、とき等の処理。
'--------------------------------------------
Next
With f.WebBrowser1
.Navigate "about:blank"
DoEvents
.Document.Write "<HTML>"
.Document.Write "<HEAD>"
.Document.Write "<font size=""3"" face=""Meiryo UI"">"
.Document.Write Replace(Bodystr, "_未", "<FONT COLOR=red>_未</FONT>")
.Document.Write "</BODY>"
.Document.Write "</HTML>"
.Document.Body.Style.overflow = "hidden"
End With
End Sub
'--------------------------------------------------------------------------------
'今後、htmlなどを省略する。
'--------------------------------------------
Function E_number(n As Long, tmp As String)
Select Case tmp
Case "一"
E_number = n + 1
Case "二"
E_number = n + 2
Case "三"
E_number = n + 3
Case "四"
E_number = n + 4
Case "五"
E_number = n + 5
Case "六"
E_number = n + 6
Case "七"
E_number = n + 7
Case "八"
E_number = n + 8
Case "九"
E_number = n + 9
Case "十"
buf = n Mod 10
If buf = 0 Then buf = 1
E_number = Int(n / 100) * 100 + buf * 10
Case "百"
buf = n Mod 10
If buf = 0 Then buf = 1
E_number = Int(n / 1000) * 1000 + buf * 100
Case "千"
buf = n Mod 10
If buf = 0 Then buf = 1
E_number = Int(n / 10000) * 10000 + buf * 1000
End Select
End Function
'--------------------------------------------------------------------------------
'開始文字で分ける準備。十、百、千は次の文字列を探す。
'--------------------------------------------
Function E_NoSearch(XMLstr As String, str As String, no As Long) As Long
E_NoSearch = InStr(XMLstr, "<" & str & " Num=""" & no & """>")
End Function
'--------------------------------------------------------------------------------
'<で始まり、>で終わらない文字列は検索から弾く。
'--------------------------------------------
Function E_StrSearch(XMLstr As String, str As String) As String
Dim wLen As Long, wStartPoint As Long, wEndPoint As Long
wLen = Len(str)
wStartPoint = InStr(XMLstr, "<" & str & "") + wLen + 2
wEndPoint = InStr(XMLstr, "</" & str & ">")
If wEndPoint - wStartPoint < 1 Then Exit Function
E_StrSearch = Mid(XMLstr, wStartPoint, wEndPoint - wStartPoint)
End Function
'--------------------------------------------------------------------------------
'<,/,>なども文字列として返す。
'--------------------------------------------
Function E_URL(Typ As Long, Article As Long, Plus As Long, ArtStr As String) As String
Dim ArtUrl As String, LawUrl As String, TmpRng As Range
Select Case Typ
Case 1
LawUrl = encodeURL("明治二十九年法律第八十九号")
Case 2
LawUrl = encodeURL("平成十六年法律第百二十三号")
Case 3
LawUrl = encodeURL("平成十六年政令第三百七十九号")
Case 4
LawUrl = encodeURL("平成十七年法務省令第十八号")
Case 5
LawUrl = encodeURL("平成十七年法律第八十六号")
Case 6
LawUrl = encodeURL("平成十七年法律第八十七号")
Case 7
LawUrl = encodeURL("平成十八年法務省令第十二号")
Case 8
LawUrl = encodeURL("昭和三十八年法律第百二十五号")
Case 9
LawUrl = encodeURL("昭和三十九年法務省令第二十三号")
Case 10
LawUrl = encodeURL("平成十九年法律第二十二号")
Case 11
LawUrl = encodeURL("昭和二十五年法律第百九十七号")
Case 12
LawUrl = encodeURL("昭和二十二年法律第二百二十四号")
Case 13
LawUrl = encodeURL("昭和二十二年司法省令第九十四号")
Case 14
LawUrl = encodeURL("平成十八年法律第百八号")
Case 15
LawUrl = encodeURL("平成十九年法務省令第四十一号")
Case 16
LawUrl = encodeURL("昭和三十二年法律第二十六号")
End Select
For i = 1 To 9999 'NUMBERSTRINGが関数としてしか動かないので空いてるセルを探して一時使用
If Cells(1, i) = "" Then Set TmpRng = Cells(1, i): Exit For
Next
TmpRng.FormulaR1C1 = "=NUMBERSTRING(" & Article & ",1)"
Calculate
ArtStr = "第" & TmpRng.Value & "条"
If Plus <> 0 Then
TmpRng.FormulaR1C1 = "=NUMBERSTRING(" & Plus & ",1)"
Calculate
ArtStr = ArtStr & "の" & TmpRng.Value
End If
TmpRng.Value = ""
ArtUrl = encodeURL(ArtStr)
E_URL = "https://elaws.e-gov.go.jp/api/1/articles;lawNum=" & LawUrl & ";article=" & ArtUrl
End Function
'--------------------------------------------------------------------------------
'別のファイルからExcelファイルに格納する。法令検索APIから「1」の法令を取得。
'--------------------------------------------
Function encodeURL(ByRef str As String) As String
For i = 1 To 9999
If Cells(i, 1) = "" Then Set TmpRng = Cells(i, 1): Exit For
Next
TmpRng.FormulaR1C1 = "=ENCODEURL(""" & str & """)"
Calculate
encodeURL = TmpRng.Value
TmpRng.Value = ""
End Function
'--------------------------------------------------------------------------------
'UTF-8をサポートする。
'--------------------------------------------
あ