条文を虫食いにする
<<第１回 <第５回 第７回>
 |
| ↑今回の成果ヽ(｀▽´)/ |
必要なもの：
・「無いものは作る」意思・自己責任を許容できる寛容な心
・プログラムをトライ＆エラーできる程度の時間と勇気
・LibreOffice５
・BASICのプログラム経験
・オブジェクト指向言語を触った経験があれば尚良
・OpenOffice/LibreOffice マクロ
したいこと：
・ 条文を登録単語で虫食い状にしたい
・ 単語を自由に登録したい
・ 登録した単語を次回に持ち越したい
したこと：
虫食い単語用のテキストフィールドと、それを保存するためのボタン「反映」を用意。
「反映」が押された時の処理
- 法律シートの該当条文IDXの10列目に、当テキストフィールドの内容が書き込む
- 法律シートの該当条文IDXの10列目を参照して、条文テキストフィールドの情報を書き直す
- 虫食い単語があれば、虫食い状態で表示する
- 虫食いの単語は半角カンマで区切る
〜能書き〜
法律の暗記用の穴埋め問題集的な感じになってきたのではないでしょうかｗ
より一層問題集に近づけるため、次回からは次のようなことを実装していきたいと思っています。
今後実装したいこと一覧
- 虫食いの適用/非適用をボタンでスイッチする
- 複数の法律を同時に指定
- 問題として表示する条文数を指定
- ランダムに条文をピックアップ
- 並べ替え（条文順、 閲覧日付順）
- メモを書き込めるようにする
- Libreからブラウザを起動して、判例を検索できるようにする
以下、現在のプログラム全部
コピペで動かせます。多分。
REM ***** BASIC *****
dim crntIDN as string
dim oDialog as object
dim HOURITUName as string
dim HOURITUSheet as object
dim sttpos,endpos as object
Function reformoneline(oneline as string)
oneline = oneline + chr(13) + chr(13) ' 条、項の後には改行を
' 号は桁を下げる
if instr(1, oneline, "一") = 1 or instr(1, oneline, "二") = 1 or instr(1, oneline, "三") =1 or instr(1, oneline, "四") =1 or instr(1, oneline, "五") =1 _
or instr(1, oneline, "六") =1 or instr(1, oneline, "七") =1 or instr(1, oneline, "八") =1 or instr(1, oneline, "九") =1 then
oneline = " " + oneline
end if
' イロハニ
if instr(1, oneline, "イ") = 1 or instr(1, oneline, "ロ") = 1 or instr(1, oneline, "ハ") =1 or instr(1, oneline, "ニ") =1 or instr(1, oneline, "ホ") =1 _
or instr(1, oneline, "ヘ") =1 or instr(1, oneline, "ト") =1 or instr(1, oneline, "チ") =1 or instr(1, oneline, "リ") =1 then
oneline = " " + oneline
end if
oneline = replace(oneline,"若しくは"," 若しくは ")
oneline = replace(oneline,"又は"," 又は ")
oneline = replace(oneline,"及び"," 及び ")
oneline = replace(oneline,"並びに"," 並びに ")
oneline = replace(oneline,"あつた", "あった")
oneline = replace(oneline,"かつた", "かった")
oneline = replace(oneline,"かつ"," かつ ")
oneline = reFMT(oneline,1) ' １条文中の漢数字をアラビア数字に変換
' 虫食い状態にする場合の処理
Dim items() as string
items = split(getMshikuiList(), ",")
For each itm in items
oneline = Replace(oneline, itm, "_____")
next itm
reformoneline = oneline
end function
sub changeMushikuiFld(mushilist as string)
oDialog.getControl("TextField2").text = mushilist
end sub
Sub changeJoubunField(someAjobun as string)
oDialog.getControl("TextField1").text = someAjobun
end sub
sub presHaneibtn
Dim idxPos(2) as integer
idnPos = getRowColbyIDN()
HOURITUSheet.getCellByPosition(idnpos(0) + 10, idnpos(1)).string = oDialog.getControl("TextField2").text
call changeJoubunField(getJOUBUN())
end sub
'指定した条文シートとcrntIDNから、その内容を返す
'HOURITUSheetシのcrntIDNをvlookupして次のIDが入っている行までをひとかたまりとして
'文字列を返す
'cntの数だけ前後した条文を返す
Function getJOUBUN()
Dim idxPos(2) as integer
idxPos = getRowColbyIDN
lowSet = ""
i=0
Do
Dim oneLine as string
oneLine = HOURITUSheet.getCellByPosition(idxpos(0)+1, idxpos(1)+i).string
lowSet = lowSet + reformoneline(oneLine)
i=i+1
loop while HOURITUSheet.getCellByPosition(idxpos(0), idxpos(1)+i).string =""
getJOUBUN = lowset
end function
' リストボックスのアイテムが選択されたら呼ばれるつもりのサブルーチン
Sub listboxselected
'選択されたアイテムを取得
'条文内容を取得-> call getJOUBUN(）
'テキストフィールドに書き出す
crntIDN=0
HOURITUName = oDialog.getcontrol("ListBox1").getSelectedItem()
call changeJoubunField( getJOUBUN() )
call changeMushikuiFld( getMshikuiList() )
end sub
function getMshikuiList
dim idnpos(2) as integer
idnpos = getRowColbyIDN
getMshikuiList = HOURITUSheet.getCellByPosition(idnpos(0) + 10, idnpos(1)).string
end function
sub moveRefIDX(cnt as integer)
dim idnpos(2) as integer
idnpos = getRowColbyIDN
if cnt > 0 then
for i = 0 to cnt-1
do
if HOURITUSheet.getCellByPosition(idnpos(0), idnpos(1)+1).string ="end" then
exit sub
end if
idnpos(1) = idnpos(1)+1
loop while HOURITUSheet.getCellByPosition(idnpos(0), idnpos(1)).string = ""
crntIDN = HOURITUSheet.getCellByPosition(idnpos(0), idnpos(1)).string
next i
elseif cnt < 0 then
for i = cnt+1 to 0
do
if HOURITUSheet.getCellByPosition(idnpos(0), idnpos(1)-1).string ="stt" then
exit sub
end if
idnpos(1) = idnpos(1)-1
loop while HOURITUSheet.getCellByPosition(idnpos(0), idnpos(1)).string = ""
crntIDN = HOURITUSheet.getCellByPosition(idnpos(0), idnpos(1)).string
next i
end if
end sub
Function getRowColbyIDN()
dim somecell as object
dim tgtRow, tgtCol as string
dim lowSet as string
dim idnpos(2) as integer
HOURITUSheet = ThisComponent.Sheets.getbyname(HOURITUName)
if crntIDN = 0 then
crntIDN = "stt"
endif
SFNC=createUnoService("com.sun.star.sheet.FunctionAccess")
adrsl = SFNC.callfunction("MATCH", array(crntIDN, HOURITUSheet.getCellRangeByname("A:A"), 0 ))
adrsg = SFNC.callfunction("ADDRESS", array(adrsl,1,4))
idnpos(1) = HOURITUSheet.getCellRangeByName(adrsg).CellAddress.Row
if crntIDN = "stt" then
idnpos(1) = idnpos(1)+1
end if
idnpos(0) = HOURITUSheet.getCellRangeByName(adrsg).CellAddress.Column
crntIDN = HOURITUSheet.getCellByPosition(idnpos(0), idnpos(1)).string
getRowColbyIDN = idnpos
end function
' 進む・戻るボタンが押されたら呼ばれるつもりのサブルーチン
sub forwardBtn
call moveRefIDX(1)
call changeJoubunField(getJOUBUN())
call changeMushikuiFld( getMshikuiList() )
end sub
sub backBtn
call moveRefIDX(-1)
call changeJoubunField(getJOUBUN())
call changeMushikuiFld( getMshikuiList() )
end sub
Sub ShowDiarog
dim oSheets as object
dim i as integer
crntIDN = 0
DialogLibraries.LoadLibrary("Standard")
oDialog=CreateUnoDialog(DialogLibraries.Standard.Dialog1)
oSheets = ThisComponent.Sheets
For i = 0 to oSheets.getCount()-1 'すべてのワークシートに対して繰り返す
oDialog.getControl("ListBox1").AddItem(oSheets(i).Name,i)
Next i
oDialog.Execute()
oDialog.Dispose()
End Sub
'各法律のN条に対してインデックスを振る
'空白で挟まれているものをひとかたまりでインデックスを振る
Sub AddIndex
Dim i,j,k as integer
Dim sttflag as integer
Dim flgchk as string
Dim Flags&
MsgBox "ID振り直します。お待ちください。ダイアログが出るまでお待ちください。"
dim oSheets as object
oSheets = ThisComponent.Sheets
For i = 0 to oSheets.getCount()-1 '一応すべてのワークシートに対して繰り返す
sttflag = 0
' 一度法条文シートのIDを消す
Flags=com.sun.star.sheet.CellFlags.STRING + _
com.sun.star.sheet.CellFlags.VALUE + _
com.sun.star.sheet.CellFlags.FORMULA
osheets(i).getcellrangebyname("A:A").clearContents(Flags)
'はじめに「第一編」「第一章」「第一条」のどれかが現れるまで読み飛ばすまでのフラグを入力していく
call addSttEndFlg(oSheets(i))
'以下、各シートの条番号（上下を空白行で挟まれた文に）インデックスをつけていく
' 以下、とりあえず各シート5000行サーチする
For j = 0 to 10000
Dim onesomestring as string
'空白で挟まれた部分を発見する
'正規表現を使って「第N条」「第N条のSの…」に反応させる
'（）書きは無視
'インデックスをつける
onesomestring = oSheets(i).getcellbyposition(1, j).string ' getcellbyposition(列、行)
flgchk = oSheets(i).getcellbyposition(0, j).string
' stt~endに挟まれた部分を判定して、bookに唯一のIDを振リ直す
if sttflag = 1 and onesomestring="" and flgchk = "end" then
exit for
elseif sttflag = 1 and onesomestring="" then
oSheets(i).getcellbyposition(0, j+1).string = i * 100000 + j
elseif sttflag = 0 and flgchk = "stt" then
sttflag = 1
oSheets(i).getcellbyposition(0, j+1).string = i * 100000 + j
j=j+1
end if
next j
Next i
MsgBox "ID振り直しが完了しました。 法条文シートをご確認ください。"
end sub
sub addSttEndFlg(sheet)
Dim precellstr, cellstr, postcellstr as string
Dim i,j,k as integer
Dim sttflg,endflg as integer
sttflg = 0
for i=0 to 10000
cellstr = sheet.getcellbyposition(1, i).string
'第一編、第一章という単語を含む文字列の前後の行が空白なら、本文スタートと判断して、sttフラグを入力
if sttflg = 0 and _
(instr(cellstr, "第一編") or _
instr(cellstr, "第一章")) then
precellstr = sheet.getcellbyposition(1, i-1).string
postcellstr = sheet.getcellbyposition(1, i+1).string
if precellstr = "" and postcellstr = "" then
sheet.getcellbyposition(0, i-1).string = "stt"
sttflg = 1
end if
end if
''二行空白が続けば終了と判断してendフラグを入力
if sttflg = 1 and cellstr = "" then
if sheet.getcellbyposition(1, i+1).string = "" then
sheet.getcellbyposition(0, i).string = "end"
exit for
end if
end if
next i
end sub
function reFMT(nKnj as string, sw as integer)
Dim nArb as string
Dim nLen as Integer
Dim tmp0 as integer
Dim tmp1 as integer
Dim tmp2 as integer
Dim tmp3 as integer
Dim total as integer
if nKnj = "" then
reFMT = ""
end if
nLen = len(nKnj)
for i=1 to nLen
if mid(nknj, i, 1) = "一" then
tmp0 = 1
elseif mid(nknj, i, 1) = "二" then
tmp0 = 2
elseif mid(nknj, i, 1) = "三" then
tmp0 = 3
elseif mid(nknj, i, 1) = "四" then
tmp0 = 4
elseif mid(nknj, i, 1) = "五" then
tmp0 = 5
elseif mid(nknj, i, 1) = "六" then
tmp0 = 6
elseif mid(nknj, i, 1) = "七" then
tmp0 = 7
elseif mid(nknj, i, 1) = "八" then
tmp0 = 8
elseif mid(nknj, i, 1) = "九" then
tmp0 = 9
elseif mid(nknj, i, 1) = "十" then
if tmp0>0 then
tmp1=tmp0*10
tmp0=0
else
tmp1=10
endif
elseif mid(nknj, i, 1) = "百" then
if tmp0>0 then
tmp2=tmp0*100
tmp0=0
else
tmp2=100
endif
elseif mid(nknj, i, 1) = "千" then
if tmp0>0 then
tmp3=tmp0*1000
tmp0=0
else
tmp3=1000
endif
else
total = tmp0 + tmp1 + tmp2 + tmp3
if total >0 then
nArb = nArb & total & mid(nknj, i, 1)
else
nArb = nArb & mid(nknj, i, 1)
end if
tmp0=0
tmp1=0
tmp2=0
tmp3=0
end if
next i
Dim nArbKnj as string
nLen = len(nArb)
for i = 1 to nLen
tmp = Mid(nArb, i, 1)
if tmp = "1" then
tmp="一"
elseif tmp = "2" then
tmp = "二"
elseif tmp = "3" then
tmp ="三"
elseif tmp = "4" then
tmp ="四"
elseif tmp = "5" then
tmp ="五"
elseif tmp = "6" then
tmp ="六"
elseif tmp = "7" then
tmp ="七"
elseif tmp = "8" then
tmp ="八"
elseif tmp = "9" then
tmp ="九"
elseif tmp = "0" then
tmp ="〇"
else
end if
nArbKnj=nArbKnj & tmp
next i
if sw = 1 then
reFMT = nArb
elseif sw = 0 then
reFMT = nArbKnj
end if
end function
Function ReplacePlural(strData, strReplace, avarFind) As String
'概要 : 文字列内を指定の複数の文字列で検索して一括置換する
'引数 : strData 置換対象の元の文字列
' strReplace 置換後の文字列
' avarFind 検索する文字列（任意の複数の文字列を指定可）
'返り値 : 置換後の文字列
Dim schar As Variant
Dim Result as String
Result = strData
For Each schar In avarFind
Result = Replace(Result, schar, strReplace)
Next schar
ReplacePlural = Result
End Function
Function Replace(Source As String, Search As String, NewPart As String)
Dim Result As String
Dim StartPos As Long
Dim CurrentPos As Long
Result = ""
StartPos = 1
CurrentPos = 1
If Search = "" Then
Result = Source
Else
Do While CurrentPos <> 0
CurrentPos = InStr(StartPos, Source, Search)
If CurrentPos <> 0 Then
Result = Result + Mid(Source, StartPos, _
CurrentPos - StartPos)
Result = Result + NewPart
StartPos = CurrentPos + Len(Search)
Else
Result = Result + Mid(Source, StartPos, Len(Source))
End If ' Position <> 0
Loop
End If
Replace = Result
End Function
