Option Private Module
'---------------------------------------------------------------------
' HTTP通信用定義。
'---------------------------------------------------------------------
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リクエストをするIXMLHTTPRequestオブジェクト。
'文字列変換｡指定した数だけ繰り返した文字列を取得｡階差有り｡
'--------------------------------------------
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
'---------------------------------------------------------------------
'500000回実行したら、プログラムは終了（一旦ファイルを閉じる。）
'--------------------------------------------
For i = 1 To 500000
If objXMLHttp.readyState = 4 Then Exit For
DoEvents
If i = 500000 Then MsgBox "ネット接続がありません": Exit Sub
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)
'---------------------------------------------------------------------
'見回りを止めて文字列を返す場合を定義。tmp・・・一時的に値を格納。
'--------------------------------------------
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
'---------------------------------------------------------------------
'表示されるフォームの設定。
'--------------------------------------------
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
'---------------------------------------------------------------------
'今後、htmlなどを省略する。
'---------------------------------------------------------------------
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
'---------------------------------------------------------------------
'開始文字で分ける準備。十、百、千は次の文字列を探す。
'--------------------------------------------
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
'---------------------------------------------------------------------
'別のファイルからExcelファイルに格納する。法令検索APIから「1」の法令を取得。
'--------------------------------------------
TmpRng.Value = ""
ArtUrl = encodeURL(ArtStr)
E_URL = "https://elaws.e-gov.go.jp/api/1/articles;lawNum=" & LawUrl & ";article=" & ArtUrl
End Function
'---------------------------------------------------------------------
'UTF-8をサポートする。
'--------------------------------------------
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
#pdfminer. Pdfinterp.converter. ・・・pdfファイルからテキストを抽出する。#PDFResourceManager・・・抽出したテキストを管理。LAParams・・・pdfファイルの構造を保持する機能を提供。PDFPage・・・1ページずつ取得。
from pdfminer.pdfinterp import PDFResourceManager, PDFPageInterpreter
from pdfminer.converter import TextConverter
from pdfminer.layout import LAParams
from pdfminer.pdfpage import PDFPage
＃input_path =‘ファイル名．pdf’。pdfファイルを入れる。
input_path = 'page000001_00269.pdf'
#result.textという名前のファイル・拡張子でアウトプットする。
output_path = 'result.txt'
manager = PDFResourceManager()
#テキストへの変換のため、TextConverterを使用。for文でPDFに1ページずつアクセスしながら、テキストを抽出。
with open(output_path, "wb") as output:
with open(input_path, 'rb') as input:
with TextConverter(manager, output, codec='utf-8', laparams=LAParams()) as conv:
interpreter = PDFPageInterpreter(manager, conv)
for page in PDFPage.get_pages(input):
interpreter.process_page(page)
・中身
Sub StrDifEmphasis()
Const Str1StartSetCell As String = "A2" ' 文字列1の開始セルの設定セルを指定
Const TargetCountSetCell As String = "B2" ' 対象行数の設定セルを指定
Dim Str1StartCell As String '文字列1の開始セル
Dim targetCount As Integer '対象行数
Str1StartCell = ActiveSheet.Range(Str1StartSetCell).Value '文字列1の開始セルを取得
targetCount = ActiveSheet.Range(TargetCountSetCell).Value '対象行数を取得
Dim rowCount As Integer ' 行数のカウンター
' 対象行走査ループ。文字列1の開始セルから終了セル（対象行数分下）までループ
For rowCount = 1 To targetCount
' 頻繁に使用する箇所を変数化(コードを短く且つ冗長性を排除するため)
Dim str1cell As Range ' 文字列1セル
Dim str2cell As Range ' 文字列2セル
Dim resultCell As Range ' 結果セル
Dim str1 As String ' 文字列1の値
Dim str2 As String ' 文字列2の値
'セルを取得
Set str1cell = ActiveSheet.Range(Str1StartCell).Offset(rowCount - 1, 0)
Set str2cell = ActiveSheet.Range(Str1StartCell).Offset(rowCount - 1, 1)
Set resultCell = ActiveSheet.Range(Str1StartCell).Offset(rowCount - 1, 2)
'文字列1と2の値を取得
str1 = str1cell.Value
str2 = str2cell.Value
'セルの状態を初期化。文字列セルを黒文字に、結果を空白にする
resultCell.Value = ""
str1cell.Font.Color = vbBlack
str2cell.Font.Color = vbBlack
' 2つの文字列が異なる場合にのみ処理を行う
If str1 <> str2 Then
' 結果セルにメッセージを設定
resultCell.Value = "改正"
Dim maxLen As Integer ' 2つの文字列の長い方の文字数
' 2つの文字列の長い方の文字数を設定
If Len(str1) > Len(str2) Then
' 文字列1の方が長いため、文字列1の文字数を設定
maxLen = Len(str1)
Else
' 文字列2の方が長いため、文字列1の文字数を設定
' (文字数が同じ場合もこの処理。str1で行っても同じ)
maxLen = Len(str2)
End If
Dim charCount As Integer ' 比較用文字数カウンター
' 文字比較ループ。大きいほうの文字列の文字数だけループ
For charCount = 1 To maxLen
Dim char1 As String '文字列1から抽出した1文字
Dim char2 As String '文字列2から抽出した1文字
Dim isChar1Under As Boolean ' 文字列1の文字数内か否か
Dim isChar2Under As Boolean ' 文字列2の文字数内か否か
'文字列1から1文字抽出
If charCount <= Len(str1) Then
'charCountが文字数内に収まっているため1文字抽出
char1 = Mid(str1, charCount, 1)
isChar1Under = True
Else
'文字数内に収まっていないため空白文字とする
char1 = ""
isChar1Under = False
End If
'文字列2から1文字抽出
If charCount <= Len(str2) Then
'charCountが文字数内に収まっているため1文字抽出
char2 = Mid(str2, charCount, 1)
isChar2Under = True
Else
'文字数内に収まっていないため空白文字とする
char2 = ""
isChar2Under = False
End If
' 相違している文字を赤色に変更
If char1 <> char2 Then
If isChar1Under Then
str1cell.Characters(Start:=charCount, Length:=1).Font.Color = vbRed
End If
If isChar2Under Then
str2cell.Characters(Start:=charCount, Length:=1).Font.Color = vbRed
End If
End If
Next
End If
Next
MsgBox ("終了")
End Sub
・中身
'---------------------------------------
法人番号という名前で何かを作る。
'---------------------------------------
Sub 法人番号()
'---------------------------------------
文字列型で処理する。iは、長い整数として、箱に入れます。
'---------------------------------------
Dim CorpName As String
Dim i As Long
Dim arr As Variant
'---------------------------------------
1行目から最終行まで処理する。エラーが発生した場合、次のVBAコードに進む。
会社名（商号）は、リクエストする際のURLに格納する。
'---------------------------------------
For i = 2 To ThisWorkbook.Sheets(2).Cells(Rows.Count, 2).End(xlUp).Row
CorpName = Cells(i, 2)
On Error Resume Next
arr = CorpCode(URL_Encode(CorpName))
'---------------------------------------
法人番号は、法人名を入力したセルから３つ離れたセルへ出力、法人の正式名称（商号）は、法人名を入力したセルから３つ離れたセルへ出力など。
'---------------------------------------
Cells(i, 3) = arr(4)
Cells(i, 4) = arr(9)
Cells(i, 5) = arr(12)
Cells(i, 6) = arr(13)
Cells(i, 7) = arr(14)
Next i
End Sub
'---------------------------------------
国税庁法人番号公表サイトに対して、リクエストを送信。
'---------------------------------------
Function CorpCode(CorpName As String) As String()
Dim objXMLHttp As Object
Dim tmp
Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
objXMLHttp.Open "GET", "https://api.houjin-bangou.nta.go.jp/4/name?id=■■■ID■■■&type=02&mode=2&name=" & CorpName, False
objXMLHttp.Send
'---------------------------------------
返ってきた情報を、区分に従って区切る。
'---------------------------------------
tmp = Split(Replace(objXMLHttp.responseText, """", ""), ",")
CorpCode = tmp
'---------------------------------------
End Function
'---------------------------------------
このリクエストはJScript で書かれている。UTF-8に基づいて文字列を出力する。
'---------------------------------------
Function URL_Encode(ByVal strOrg As String) As String
With CreateObject("ScriptControl")
.Language = "JScript"
URL_Encode = .CodeObject.encodeURI(strOrg)
End With
End Function
一般の社会生活において現代の日本語を書き表すための漢字使用の目安である常用漢字は約２千文字です。一方で、約２千文字では専門的な内容を伝えにくい等の社会の要請があります。そこで、これまで文字の JIS 規格が整備されてきており、現在は、１万字程度となっています。これは、日常的に用いられるパソコン、スマートフォン、タブレット等において標準的に扱える文字になります。
IPAmj明朝フォントは、人名の表記等で、細かな字形の差異を特別に使い分ける必要のある業務等での活用を想定したフォントです。また、同フォントを十分に活用するためには、対応したアプリケーションソフトが必要となります。通常の文書作成等では、JIS X 0213:2012に準拠したIPAexフォントのご利用をお勧めします。
