JANコードからバーコードフォント用文字列を生成する

同人誌にバーコードを付ける。2の続き。

同人誌にバーコードを付ける。2 - DumBo さんの Homebrew 観察日記

前回から3年ぐらい経ってしまっているが
気にしないで公開。

ソースをVBS対応に修正。
久しぶりに読むチェックディジット算出処理は
正直見辛いと感じたが…手直しするの面倒なんでこのまま。

ExcelVBAなんかの標準モジュールに貼り付ければ
Officeでも使えますよーと。

バーコードフォント(サンプル版)
http://www.vector.co.jp/soft/data/writing/se293727.html
※記載のVBSを活用するのに必要

BarFontVer1.00.vbs

Option Explicit
'
'   BarFont(JAN)補助モジュール
'
'   version 1.00
'   2017/04/12
'
'   by REGEKATSU
'
'   release
'
'   version 1.00
'   同一コードによるVBA/VBScriptでの実行に対応
'
'   version 0.02
'   JANコード標準なら12~13桁、短絡なら7~8桁での入力に対応しています
'   (チェックディジットの計算機能が備わっています。)。
'
'   version 0.01
'   JANコード13桁のみ対応しています。12桁での入力には対応していません
'   (チェックディジットの計算機能はありません。)。
'

'VBAでは下記1行をコメントアウトすること
Call JanCodeToFontChar


'サブルーチン

'入力ボックスに指定されたJANコード標準13桁又は短絡8桁に対するバーコード表示用文字列を、
'同じく入力ボックスに出力します。
'入力無しかキャンセルボタンをクリックすることで、処理が終了します。
Sub JanCodeToFontChar()
    
    Dim RE
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^([0-9]{12,13}|[0-9]{7,8})$"
    
    Const DEFAULT_PROMPT = "JANコード標準13桁又は短絡8桁を入力してください。"
    Dim prompt
    prompt = DEFAULT_PROMPT
    Dim promptNoUseLongBar
    Dim inputNoUseLongBar
    Dim inputCode
    inputCode = ""
    
    Do
        inputCode = InputBox(prompt, "バーコードフォント、表示用変換マクロ", inputCode)
        If RE.Test(inputCode) Then
            prompt = DEFAULT_PROMPT & vbCrLf & vbCrLf & "前回入力JANコード: " & inputCode & vbCrLf
            If MsgBox("バーコードの高さを均一に揃えますか?" & vbCrLf & vbCrLf & _
                "はい(Y): 同サイズ, いいえ(N): ロング", vbYesNo Or vbQuestion, _
                "指定") = vbYes Then
                inputNoUseLongBar = True
                promptNoUseLongBar = "同サイズ"
            Else
                inputNoUseLongBar = False
                promptNoUseLongBar = "ロング"
            End If
            prompt = prompt & "前回バーコードサイズ: " & promptNoUseLongBar & vbCrLf
            inputCode = ConvertFontChar(inputCode, inputNoUseLongBar)
            prompt = prompt & "前回表示用文字列: " & inputCode
            'MsgBox "変換が完了しました。", vbInformation, "完了"
        ElseIf inputCode <> "" Then
            MsgBox "入力に誤りがあります。", vbCritical, "エラー"
        End If
    Loop While inputCode <> ""
    
    Set RE = Nothing
End Sub

'指定したJANコード標準13桁又は短絡8桁に対する、チェックディジットを返します。
'
'パラメータ janCode:        バーコードの文字列。
'                           標準なら12~13桁、短絡なら7~8桁で指定
'戻り値     チェックディジット1桁の文字列。
'           指定に誤りがあれば空白スペースを返す
'
Function CalcCheckDigit(janCode)
    Dim i, j
    Dim checkOdd
    Select Case Len(janCode)
        '短絡8桁の場合。
        Case 7, 8
            For i = 1 To 7
                '奇数桁が何文字目か調べる
                '(チェックデジットを除いた1番右側より奇数桁、右から2番目を偶数桁…と数える。)。
                If i Mod 2 = 1 Then
                    checkOdd = 1
                Else
                    checkOdd = 0
                End If
                '奇数桁の数を3倍に、偶数桁の数を1倍にして全てを合計する。
                j = j + (Asc(Mid(janCode, i, 1)) And &HF) * (1 + 2 * checkOdd)
            Next
            '合計の1の位を10から引いた数がチェックディジットなので、戻り値として返す。
            CalcCheckDigit = Chr(48 + (10 - (j Mod 10)) Mod 10)
        '標準13桁の場合。
        Case 12, 13
            For i = 1 To 12
                '奇数桁が何文字目か調べる
                '(チェックデジットを除いた1番右側より奇数桁、右から2番目を偶数桁…と数える。)。
                If i Mod 2 = 0 Then
                    checkOdd = 1
                Else
                    checkOdd = 0
                End If
                '奇数桁の数を3倍に、偶数桁の数を1倍にして全てを合計する。
                j = j + (Asc(Mid(janCode, i, 1)) And &HF) * (1 + 2 * checkOdd)
            Next
            '合計の1の位を10から引いた数がチェックディジットなので、戻り値として返す。
            CalcCheckDigit = Chr(48 + (10 - (j Mod 10)) Mod 10)
        '標準13桁又は短絡8桁以外の桁数だった場合。
        Case Else
            '指定に誤りがあるので空白スペースを、戻り値として返す。
            CalcCheckDigit = " "
    End Select
End Function

'BarFont(JAN)を利用した、バーコード描画関数です。
'指定したJANコード標準13桁又は短絡8桁、及びロングバーの有無に対する、
'バーコード表示用文字列を返します。
'
'JANコード標準なら12~13桁、短絡なら7~8桁での入力に対応しています
'(チェックディジットの計算機能が備わっています。)。
'
'パラメータ janCode:        バーコードの文字列。
'                           標準なら12~13桁、短絡なら7~8桁で指定
'           noUseLongBar:   ロングバーを使わない場合True
'戻り値     バーコードで表現される文字列
'           指定に誤りがあればNULL文字列を返す
'
Function ConvertFontChar(janCode, noUseLongBar)
    
    '変換文字列用変数。
    Dim janConv
    janConv = ""
    
    'JANコード13桁用、パリティビット算出用テーブル。
    'Dim combiTable(2 To 7)
    Dim combiTable(7)
    combiTable(2) = 32
    combiTable(3) = 16
    combiTable(4) = 8
    combiTable(5) = 4
    combiTable(6) = 2
    combiTable(7) = 1
    Dim prifixTable(9)
    prifixTable(0) = 0  '000000b
    prifixTable(1) = 11 '001011b
    prifixTable(2) = 13 '001101b
    prifixTable(3) = 14 '001110b
    prifixTable(4) = 19 '010011b
    prifixTable(5) = 25 '011001b
    prifixTable(6) = 28 '011100b
    prifixTable(7) = 21 '010101b
    prifixTable(8) = 22 '010110b
    prifixTable(9) = 26 '011010b
    
    '左ガイドバーをセットする。
    janConv = janConv & Chr(&H29 - noUseLongBar - 1)
    Dim i
    Select Case Len(janCode)
    '短絡8桁の場合。
    Case 7, 8
        janCode = Mid(janCode, 1, 7) & CalcCheckDigit(janCode)
        '左側4桁に対する、キャラクタをセットしていく。
        For i = 1 To 4
            janConv = janConv + Chr(Asc(Mid(janCode, i, 1)) + &H20)
        Next
        'センターバーをセットする。
        janConv = janConv & Chr(&H2B - noUseLongBar - 1)
        '右側6桁に対するキャラクタをセットする。
        janConv = janConv & Mid(janCode, 5, 4)
    '標準13桁の場合。
    Case 12, 13
        janCode = Mid(janCode, 1, 12) & CalcCheckDigit(janCode)
        '左側7桁に対する、パリティビットに基づいたキャラクタをセットしていく。
        Dim parityCheck, x
        '左1文字目を取得して、使用するパリティテーブルを決定する。
        x = Asc(Mid(janCode, 1, 1)) And &HF
        '使用するパリティテーブルに基づいて2~7文字目の、奇数または偶数パリティのキャラクタをセットしていく。
        For i = 2 To 7
            parityCheck = 0
            If (combiTable(i) And prifixTable(x)) = 0 Then parityCheck = 1
            janConv = janConv + Chr(Asc(Mid(janCode, i, 1)) + &H10 + (&H10 * parityCheck))
        Next
        'センターバーをセットする。
        janConv = janConv & Chr(&H2B - noUseLongBar - 1)
        '右側6桁に対するキャラクタをセットする。
        janConv = janConv & Mid(janCode, 8, 6)
    '指定に誤りがあった場合。
    Case Else
        janConv = ""
    End Select
    '右ガイドバーをセットする。
    If janConv <> "" Then janConv = janConv & Chr(&H29 - noUseLongBar - 1)
    
    '変換文字列を返す。
    ConvertFontChar = janConv
    
End Function