2019/08/17

丸付き数字から丸囲み数字(丸数字)に変換

洋々亭にて、様々なVBAコードが公開されている。

この中に含まれている、丸付き数字(「○2」など)を丸囲み数字(「②」など)に変換する関数を、⓪~㊿まで対応できるように改造した。

ちなみになんでこんな関数が必要かというと、一部の法令(児童福祉法など)は、項番号に丸数字を使用していることがある。

ところが、コンピュータ上、丸数字は機種依存文字(環境依存文字)なので、丸数字が正しく表示されないコンピュータが存在する恐れがあったので、e-Govなどでは「○2」と表記している。

現在ではほとんどの機種(環境)で丸数字が表示できるようになった。これを一括変換したいという要望があったので、洋々亭のコードを拝借し、かつ範囲を広げた。

'---------------------------------------------------------------------------------------------------
' 丸付き数字置換関数
' ◆機能の説明
'   ・「○3」形式の表記を「③」に変換する
'   ・一部文字列はUnicode文字に変換する
'   ・一定数を超える数字の場合は丸囲み数字が使用できないため、角かっこで囲む(○51→[51])
'   ※項番号を上記の方法で表記している法令があるための対処(児童福祉法等)。
' オリジナル:洋々亭 2006
'---------------------------------------------------------------------------------------------------
Private Function ToCircledNum(ByRef srcStr As String) As String
    
    Dim srcLen As Long      '引数の文字列長(○を含む)
    Dim tmpAsc As String    '引数から○を除去し半角英数に変換した文字列
    Dim chrNum As Long      '変換後の数字
    Dim i As Long           'イテレータ
    
    'まず全角数字を半角数字に置き換え、次に半角数字を丸数字に置き換える。
    Let srcLen = Len(srcStr)
    If srcLen < 2 Then
        Exit Function
    End If
    Let tmpAsc = String$(srcLen - 1, vbNullChar)
    For i = 2 To srcLen
        Mid(tmpAsc, i - 1, 1) = Mid$("0123456789", CLng(InStr("0123456789", Mid$(srcStr, i, 1))), 1)
    Next i
    Let chrNum = CLng(tmpAsc)
    Select Case chrNum
    Case Is < 0                                 '0未満は非対応([]で括る)
        Let ToCircledNum = "[" & tmpAsc & "]"
    Case 0                                      '丸0  = U+24EA( 9450) chrNum=0のためそのまま
        Let ToCircledNum = ChrW(9450)
    Case Is < 21                                '1~20は普通に丸囲み数字が使用できる
        Let ToCircledNum = Mid$("①②③④⑤⑥⑦⑧⑨⑩⑪⑫⑬⑭⑮⑯⑰⑱⑲⑳", chrNum, 1)
    Case Is < 36                                '丸21 = U+3251(12881) 21から始まるため 12881 - 21 = 12860
        Let ToCircledNum = ChrW(12860 + chrNum)
    Case Is < 51                                '丸36 = U+32B1(12977) 36から始まるため 12977 - 36 = 12941
        Let ToCircledNum = ChrW(12941 + chrNum)
    Case Else                                   '51以上も非対応([]で括る)
        Let ToCircledNum = "[" & tmpAsc & "]"
    End Select
End Function

「引数には丸記号+全角英数字の組み合わせの文字列しか来ない」という前提で作ってる関数なので、呼び出し前に正規表現やLikeマッチングでのふるい落としが必要。簡単な判定は19行目でやってるけど(引数が1文字以下なら何も返さず終了)。

やってることは洋々亭のmarumoji関数と一緒。まず全角英数字を半角英数字に置き換え(22~25行目)、整数型に変換(26行目)。あとはSelect Case文で0未満と50超は対応する丸数字がないため[]で括る、⓪と㉑~㊿はChrW関数で文字コードから文字を取得。①~⑳は文字を並べてMid関数で対応する数字の位置に該当する文字を取得。

①~⑳もChr関数を使えば取得できるが、文字を並べてMid関数で取得した方がちょっとだけ早い。

Public Sub SpeedTest()
    Dim testNums(2000000) As Long
    Dim dummyStr As String
    Dim procTime As Single
    Dim i As Long
    For i = LBound(testNums) To UBound(testNums)
        Let testNums(i) = RandomLong(1, 20)
    Next i
    Let procTime = Timer
    For i = LBound(testNums) To UBound(testNums)
        Let dummyStr = Mid$("①②③④⑤⑥⑦⑧⑨⑩⑪⑫⑬⑭⑮⑯⑰⑱⑲⑳", testNums(i), 1)
    Next i
    Debug.Print "Test1: " & Timer - procTime        'Test1: 0.140625
    Let procTime = Timer
    For i = LBound(testNums) To UBound(testNums)
        Let dummyStr = Chr(34623 + testNums(i))
    Next i
    Debug.Print "Test2: " & Timer - procTime        'Test2: 0.171875
End Sub

Private Function RandomLong(ByRef minVal As Long, ByRef maxVal As Long, Optional ByRef doRandomize As Boolean = True) As Long
    If doRandomize Then
        Randomize
    End If
    Let RandomLong = Int(Rnd * (maxVal - minVal + 1)) + minVal
End Function

⓪~㊿を全部並べてMid関数で取得した方が分かりやすいしできるならそうしたいんだけど、VBAは内部的にUnicode文字列を使用しているものの、VBEはUnicode文字をサポートしていない

ChrW関数などを使用してUnicode文字をサポートしている出力先(例えばWord文書など)に出力すること自体は可能なので、こういった書き方になった。もっとスマートな方法はないだろうか。

2019/08/12

highlight.jsを導入してみる

別になんてこたないんだけどね。

highlightjs.orgというサイトで公開されているライブラリを使用すれば、ブログ記事とかにプログラムのコードを貼り付けると自動的にシンタックスハイライトをしてくれるらしい。

blosxomのプラグインとしてコードをシンタックスハイライトする奴を作ろうかなー、とか思ってたけど既にあったわ。という話。

というわけで、ちょっと実験。

Option Explicit

'---------------------------------------------------------------------------------------------------
' クイックソート関数(SourceArray   <配列>)
'   説明: 渡された配列の要素をクイックソート(非安定ソート)で昇順に並び替える。
'---------------------------------------------------------------------------------------------------
Public Function QuickSort(ByVal SourceArray As Variant) As Variant

    Dim valSwap As Variant      'バッファ(値交換用)
    Dim valLEnd As Variant      '左端の値
    Dim valREnd As Variant      '右端の値
    Dim valMed As Variant       '中央値
    Dim bndLEnd As Long         '左端の位置
    Dim bndREnd As Long         '右端の位置
    Dim stackSize As Long       'スタック配列のサイズ(最大添字)
    Dim stackBottom As Long     'スタック配列の最小添字
    Dim bndLEnds() As Long      '左端の位置を記憶するスタック(配列)
    Dim bndREnds() As Long      '右端の位置を記憶するスタック(配列)
    Dim ptrStack As Long        'スタック(配列)のポインタ
    Dim ptrLtoR As Long         '左端から右に向かって探索するポインタ(Lポインタと呼称)
    Dim ptrRtoL As Long         '右端から左に向かって探索するポインタ(Rポインタと呼称)

    If Not IsArray(SourceArray) Then
        Exit Function
    End If

    '初期処理
    Let bndLEnd = LBound(SourceArray)   '引数の左端と右端の位置(スタックサイズ計算・スタック積み上げに使用)
    Let bndREnd = UBound(SourceArray)
    Let stackBottom = LBound(Array())   'スタックの最小添字(底のスタックポインタ)
    Let stackSize = Int(Log(bndREnd - bndLEnd + 1) / Log(2)) + stackBottom  'スタックサイズはLog2(n)個で足りる
    ReDim bndLEnds(stackSize)           'スタック確保
    ReDim bndREnds(stackSize)
    Let ptrStack = stackBottom          '全体の範囲をスタックの底に積み上げ
    Let bndLEnds(ptrStack) = bndLEnd
    Let bndREnds(ptrStack) = bndREnd

    'メイン処理
    Do Until ptrStack < stackBottom     'すべてのスタックが処理されるまで繰り返す

        'スタック・値取り出し
        Let bndLEnd = bndLEnds(ptrStack)    'スタックから両端の位置を取り出す
        Let bndREnd = bndREnds(ptrStack)
        Let ptrLtoR = bndLEnd               '両端の位置をLポインタ・Rポインタにそれぞれセット
        Let ptrRtoL = bndREnd
        Let valLEnd = SourceArray(ptrLtoR)  '両端の値と中間位置の値を取り出す
        Let valREnd = SourceArray(ptrRtoL)
        Let valMed = SourceArray(ptrLtoR + Int((ptrRtoL - ptrLtoR) / 2))

        '中央値取得(左端の値・右端の値・中間位置の値、の3値から中央値を求める)
        If valLEnd > valMed Then
            If valREnd > valLEnd Then
                Let valMed = valLEnd
            ElseIf valREnd > valMed Then
                Let valMed = valREnd
            End If
        ElseIf valLEnd > valREnd Then
            Let valMed = valLEnd
        ElseIf valMed > valREnd Then
            Let valMed = valREnd
        End If

        'スタック範囲内探索・値交換
        Do Until ptrLtoR > ptrRtoL          'LポインタとRポインタの位置が逆転するまで繰り返す
            Do Until SourceArray(ptrLtoR) >= valMed
                Let ptrLtoR = ptrLtoR + 1   '左から右へ、中央値以上の値の位置を探索する
            Loop
            Do Until SourceArray(ptrRtoL) <= valMed
                Let ptrRtoL = ptrRtoL - 1   '右から左へ、中央値以下の値の位置を探索する
            Loop
            If ptrLtoR <= ptrRtoL Then
                If ptrLtoR < ptrRtoL Then               'Lポインタ<Rポインタ であれば、左の値と右の値を交換する
                    Let valSwap = SourceArray(ptrLtoR)  '(左の値は中央値以上、右の値は中央値以下になっている)
                    Let SourceArray(ptrLtoR) = SourceArray(ptrRtoL)
                    Let SourceArray(ptrRtoL) = valSwap
                End If
                Let ptrLtoR = ptrLtoR + 1   'Lポインタ≦Rポインタ であれば、範囲を1つずつ狭める
                Let ptrRtoL = ptrRtoL - 1
            Else
                Exit Do                     'LポインタとRポインタの位置が逆転したら探索・交換を終了する
            End If
        Loop

        '探索範囲の分割・交換(左範囲[左端~交差したRポインタ] 右範囲[交差したLポインタ~右端])
        If ptrRtoL - bndLEnd < bndREnd - ptrLtoR Then   '※ポインタの間に要素がある場合、その要素の位置は確定
            Let ptrLtoR = ptrLtoR Xor bndLEnd   '右範囲の方が広い場合、左端とLポインタ、右端とRポインタの
            Let bndLEnd = ptrLtoR Xor bndLEnd   '位置情報を交換し(Xor交換)、広い右範囲を先にスタックする
            Let ptrLtoR = ptrLtoR Xor bndLEnd   '(左範囲の方が広い場合は左範囲を先にスタックする)
            Let ptrRtoL = ptrRtoL Xor bndREnd   'スタック順は広→狭、処理順は狭→広となり、スタックのサイズを
            Let bndREnd = ptrRtoL Xor bndREnd   'Log2(n)以下に抑えられる
            Let ptrRtoL = ptrRtoL Xor bndREnd
        End If

        'スタックへ積み上げ(広い方の範囲)
        If bndLEnd < ptrRtoL Then               '範囲内の要素が2以上あればスタックに積み上げる
            Let bndLEnds(ptrStack) = bndLEnd    '(1つしかない場合はその要素の位置が確定したためスタックしない)
            Let bndREnds(ptrStack) = ptrRtoL    '現在処理中のスタックは上書きされる(実質的にPOPと同じ動作)
            Let ptrStack = ptrStack + 1         'スタックポインタに1加算=次の空きスタックへ移動
        End If

        'スタックへ積み上げ(狭い方の範囲)
        If ptrLtoR < bndREnd Then               '上記と同じ処理
            Let bndLEnds(ptrStack) = ptrLtoR
            Let bndREnds(ptrStack) = bndREnd
            Let ptrStack = ptrStack + 1
        End If
        Let ptrStack = ptrStack - 1     '次に処理すべきスタックへ移動
    Loop
    Let QuickSort = SourceArray
End Function

コードは前に何かで使ったクイックソート。さて、どうかな?

Search

Option

Document

Comment

カテゴリ名変更&新しい楽器がふえたよ
02/14 : そうこ
06/26 : 室井
08/20 : そうこ
09/22 : そうこ
春よ、来い
05/08 : simuzy
05/08 : simuzy
05/12 : そうこ
Google Chrome Extensions
08/15 : Menow
08/19 : そうこ

Tackback

リタリンの処方が打ち切られた
03/27 : ノビじいの鬱々日記
foreshortenedプラグイン改造
01/23 : ISO TANK!

Log

2019年
8月
2016年
11月
2014年
2月 1月
2013年
1月
2012年
7月 2月
2011年
6月 3月 2月
2010年
12月 11月 6月 4月 3月 1月
2009年
12月 11月 10月 9月 8月 6月 2月 1月
2008年
12月 11月 10月 9月 8月 6月 5月 4月 3月 2月 1月
2007年
12月 11月 10月 9月 8月 7月 6月 5月 4月 3月 2月 1月
2006年
12月 11月 10月 9月 8月 7月 6月 5月 4月 3月 2月 1月
2005年
12月 11月 10月 9月 8月 7月

Link