バーコードフォントを使用してCODE-128のバーコードを作成する

バーコードリーダーを使って入力の手間を省きたいと思う。

Excelで印刷イメージを作成する場合、CODE39のバーコードフォントを使用したり、バーコードのオブジェクトを使用する方法が簡単である。

ただし、CODE39では取り扱える文字が限定されていたり、環境によりExcelのバーコードオブジェクトが使用できない、等の事情がある場合もある。

文字数が多いCODE128を、バーコードフォントを使用してい印刷する場合、いくらか工夫が必要になる。

・チェック文字の問題：　計算の必要がある。バーコードリーダーの設定が可能であれば、チェック文字を省くことで対応も可能

・フォントによる文字コードとパターンの対応の違い：　使用するフォントにより文字コードとパターンの対応が異なるため、使用するフォントに従って変換が必要。


チェック文字の計算や、文字コードの対応の違いなど、（コードセットB限定にすれば）Excelの関数(LET＋α）で対応が出来たが、VBAでの計算・変換も試してみた。

使用するフォントは、0～94のコードが、32～126までの文字のパターン、95～105が、195～205の文字のパターン、終端が206の文字のパターンに割り振られていることを想定している。


Option Explicit

' CODE-128 バーコード
'
' GS-1 制限：先頭にFNC1、最大データ容量48文字
'
'入力 ASCII
'    0-127
'
' EncodeCtrlAsc
' EncodeCtrlCode128
' EncodeCode128
' AddCheckSum
' FontCode
'
'
'encode  ASCII, Code128 系の文字列＞文字変換
'    FUNC = 195(#95 a127), 196-205,206(#96 - #105,ed)
'        $   Code128系特殊コード
'            $$  $
'            $96-$106    これが、196-206に変換される
'            $[STARTA]   $103    203
'            $[STARTB]   $104    204
'            $[STARTC]   $105    205
'            $[FNC1] $102    202
'            $[SHIFT]    $98     198
'        \   ASCII系特殊コード
'            \\  \
'            \00-\1F
'            \[NUL]  0
'            \[SOH]  1
'            \[STX]  2
'            \[ETX]  3
'            \[EOT]  4
'            \[ENQ]  5
'            \[ACK]  6
'            \[BEL]  7
'            \[BS]   8
'            \[HT]   9
'            \[LF]   10
'            \[VT]   11
'            \[FF]   12
'            \[CR]   13
'            \[SO]   14
'            \[SI]   15
'            \[DLE]  16
'            \[DC1]  17
'            \[DC2]  18
'            \[DC3]  19
'            \[DC4]  20
'            \[NAK]  21
'            \[SYN]  22
'            \[ETB]  23
'            \[CAN]  24
'            \[EM]   25
'            \[SUB]  26
'            \[ESC]  27
'            \[FS]   28
'            \[GS]   29
'            \[RS]   30
'            \[US]   31
'            \[DEL]  127
'
'Code128 -CODE変換
'1     文字ずつ取り出し､フォント文字へ変換していく
'        0-127 の　アスキー文字を　Code128コード（0-106または 195-206は95-106と同値）に変換
'        入力の　196-206 は Code128制御文字として扱う
'
'1     コードセットB を強要
'        32-126 までを 0-94 にマッピング
'        127 は 195にマッピング
'        先頭にSTARTBを追加
'
'2     短い形式
'        開始時
'            スタートのコードセット強制＋コードセット出力無しを可能にする・・・連結のため
'            先頭FNC1 を除き､数字2桁で始まる場合､STARTC
'            先頭FNC1 を除き、0-31の文字が、96-127 より先、 STARTA
'            以外はSTART -B
'        処理時
'            AまたはB からCへの移行
'                現在の文字=数字・次の文字数字
'                FNC1があれば除外
'                その次の文字・次の文字が数字
'                以上を満たせば､Cへ移行する
'            CからAまたはBへの移行
'                現在の文字 = 数字以外
'                0-31の文字が、96-127 より先、 A
'                以外 B
'            AからB
'                96-127が出てきた
'                以降の文字で0-31の文字が、96-127 より先、 SHIFT
'                以外は B
'            BからA
'                0-31が出てきた
'                以降の文字で0-31の文字が、96-127 より先、 A
'                以外は SHIFT
'            文字のマッピングA
'                0-30を64-94にマッピング
'                31 を 195 にマッピング
'                32-95を0-63にマッピング
'            文字のマッピングB
'                32-126 を 0-94 にマッピング
'                127 を 195 にマッピング
'            文字のマッピングC
'                ２桁の数字を0-99にマッピング
'95                以降は 100
'
'チェックサム計算
'        Code128-CODE(0-106)に対してチェックサムを計算し追加する
'
'
'フォントコード変換
'        フォントに対応する文字に変換する
'        0-94 は + 32
'        95-106は+100


'Public Function GetUC() As String
'    GetUC = ChrW(199)
'
'End Function


' ASC制御文字のエンコード
' 入力:ASC 出力:ASC
Public Function EncodeCtrlAsc(ByRef pi_sSrc As String, Optional pi_sPrefix As String = "\") As String
    Dim sTabSrc As String
    Dim nStepSrc As Long
    Dim sTabDst As String
    Dim nStepDst As Long
    
    Dim nSrcLen As Long
    Dim nPrefixLen As Long
    Dim nPtr As Long
    Dim sRet As String
    Dim nPtr2 As Long
    Dim nIdx As Long
    Dim sItem As String
    
    Dim nItemLen As Long

    nStepSrc = 5
    sTabSrc = "00   01   02   03   04   05   06   07   08   09   0A   0B   0C   0D   0E   0F   " & _
              "10   11   12   13   14   15   16   17   18   19   1A   1B   1C   1D   1E   1F   " & _
              "[NUL][SOH][STX][ETX][EOT][ENQ][ACK][BEL][BS] [HT] [LF] [VT] [FF] [CR] [SO] [SI] " & _
              "[DLE][DC1][DC2][DC3][DC4][NAK][STN][ETB][CAN][EM] [SUB][ESC][FS] [GS] [RS] [US] " & _
              "[DEL]"
    
    nStepDst = 4
    sTabDst = "0   1   2   3   4   5   6   7   8   9   10  11  12  13  14  15  " & _
              "16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31  " & _
              "0   1   2   3   4   5   6   7   8   9   10  11  12  13  14  15  " & _
              "16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31  " & _
              "127 "

    nSrcLen = Len(pi_sSrc)
    nPrefixLen = Len(pi_sPrefix)

    nPtr = 1
    Do
        If nPtr > nSrcLen Then Exit Do
        
        nPtr2 = InStr(nPtr, pi_sSrc, pi_sPrefix)
        
        If nPtr2 = 0 Then
            ' 残りを出力して終了
            sRet = sRet & Mid(pi_sSrc, nPtr, nSrcLen - nPtr + 1)
            Exit Do
        End If
        
        If Mid(pi_sSrc, nPtr2, nPrefixLen * 2) = pi_sPrefix & pi_sPrefix Then
            ' Prefix 1文字に集約
            ' prefix より前を出力 + prefix
            sRet = sRet & Mid(pi_sSrc, nPtr, nPtr2 - nPtr + nPrefixLen)
            nPtr = nPtr2 + nPrefixLen * 2
        Else
            ' テーブルを探す
            SearchInTable nIdx, nItemLen, pi_sSrc, nPtr2 + nPrefixLen, nStepSrc, sTabSrc
            If nIdx = 0 Then
                ' 見つからない
                ' そのまま出力
                sRet = sRet & Mid(pi_sSrc, nPtr, nPtr2 - nPtr + nPrefixLen)
                nPtr = nPtr2 + nPrefixLen
            Else
                ' 見つかった
                ' 変換後の文字列で出力
                sItem = GetFromTable(nIdx - 1, nStepDst, sTabDst)
                sRet = sRet & Mid(pi_sSrc, nPtr, nPtr2 - nPtr) & ChrW(Val(sItem))
                nPtr = nPtr2 + nPrefixLen + nItemLen
            End If
        End If
    Loop

    EncodeCtrlAsc = sRet

End Function

' Code128制御文字のエンコード
' 入力:ASC 出力:ASC
Public Function EncodeCtrlCode128(ByRef pi_sSrc As String, Optional pi_sPrefix As String = "$") As String
    Dim sTabSrc As String
    Dim nStepSrc As Long
    Dim sTabDst As String
    Dim nStepDst As Long
    
    Dim nSrcLen As Long
    Dim nPrefixLen As Long
    Dim nPtr As Long
    Dim sRet As String
    Dim nPtr2 As Long
    Dim nIdx As Long
    Dim sItem As String
    
    Dim nItemLen As Long

    nStepSrc = 9
    sTabSrc = "96       97       98       99       100      101      102      " & _
              "103      104      105      106      " & _
              "[FNC1]   [STARTA] [STARTB] [STARTC] " & _
              "[SHIFT]  "
    
    nStepDst = 4
    sTabDst = "196 197 198 199 200 201 202 203 204 205 206 202 203 204 205 198 "

    nSrcLen = Len(pi_sSrc)
    nPrefixLen = Len(pi_sPrefix)

    nPtr = 1
    Do
        If nPtr > nSrcLen Then Exit Do
        
        nPtr2 = InStr(nPtr, pi_sSrc, pi_sPrefix)
        
        If nPtr2 = 0 Then
            ' 残りを出力して終了
            sRet = sRet & Mid(pi_sSrc, nPtr, nSrcLen - nPtr + 1)
            Exit Do
        End If
        
        If Mid(pi_sSrc, nPtr2, nPrefixLen * 2) = pi_sPrefix & pi_sPrefix Then
            ' Prefix 1文字に集約
            ' prefix より前を出力 + prefix
            sRet = sRet & Mid(pi_sSrc, nPtr, nPtr2 - nPtr + nPrefixLen)
            nPtr = nPtr2 + nPrefixLen * 2
        Else
            ' テーブルを探す
            SearchInTable nIdx, nItemLen, pi_sSrc, nPtr2 + nPrefixLen, nStepSrc, sTabSrc
            If nIdx = 0 Then
                ' 見つからない
                ' そのまま出力
                sRet = sRet & Mid(pi_sSrc, nPtr, nPtr2 - nPtr + nPrefixLen)
                nPtr = nPtr2 + nPrefixLen
            Else
                ' 見つかった
                ' 変換後の文字列で出力
                sItem = GetFromTable(nIdx - 1, nStepDst, sTabDst)
                sRet = sRet & Mid(pi_sSrc, nPtr, nPtr2 - nPtr) & ChrW(Val(sItem))
                nPtr = nPtr2 + nPrefixLen + nItemLen
            End If
        End If
    Loop

    EncodeCtrlCode128 = sRet
End Function

' Code128-CODEへのエンコード
' 入力：ASC 出力：Code128
'  UseCodeSet ： 使用するコードセットを指定する　0:指定無し。データから決定 1,2,3:A,B,C
'                -2 の場合は、 CODESET B を強要し、途中の変換しない
'  SkipStartCode : START コードの出力を抑制する
'  CodeSetAtEnd : 終了時のコードセットの受け取り用
Public Function EncodeCode128(ByRef pi_sSrc As String, Optional pi_nUseCodeSet As Long = 0, Optional pi_bSkipStartCode As Boolean = False, Optional po_nCodeSetAtEnd As Long = 0) As String
    Dim nCodeSet As Long
    Dim bCanChangeCodeSet As Boolean
    
    Dim sRet As String
    
    Dim bNotInCode As Boolean
    Dim bToCodeSet3 As Boolean
        
    Dim nLen As Long
    Dim nPtr As Long
    Dim nChar As Long
    Dim nChar1 As Long
    Dim nChar2 As Long
    Dim nItemLen As Long
    
    sRet = ""
    nLen = Len(pi_sSrc)
'    If nLen = 0 Then
'        EncodeCode128 = ""
'        Exit Function
'    End If
    
    
    '初期処理
    ' コードセットの決定
    If pi_nUseCodeSet <> 0 Then
        If pi_nUseCodeSet < 0 Then
            nCodeSet = -pi_nUseCodeSet
            bCanChangeCodeSet = False
        Else
            nCodeSet = pi_nUseCodeSet
            bCanChangeCodeSet = True
        End If
    Else
        nCodeSet = InitCodeSet(pi_sSrc)
        bCanChangeCodeSet = True
    End If
    
    ' スタートコードの出力
    If pi_bSkipStartCode Then
    Else
        'sRet = sRet & ChrW(203 + (nCodeSet - 1))
        sRet = sRet & ChrW(103 + (nCodeSet - 1))
    End If
    
    nPtr = 1
    Do
        If nPtr > nLen Then
            po_nCodeSetAtEnd = nCodeSet
            Exit Do
        End If
        
        If nCodeSet = 3 Then
            ' コードセットC
            
            ' 規則違反の確認
            bNotInCode = False
            nItemLen = 0
            
            nChar1 = AscW(Mid(pi_sSrc, nPtr, 1))
            
            If nChar1 = 202 Then
                ' FNC1 は通過させる
                nItemLen = 1
            
            ElseIf nPtr + 1 > nLen Then
                ' ２文字　数字が取得できない
                bNotInCode = True
            
            Else
                ' １・２文字目が数値か？
                nChar2 = AscW(Mid(pi_sSrc, nPtr + 1, 1))
                If nChar1 >= 48 And nChar1 <= 57 And nChar2 >= 48 And nChar2 <= 57 Then
                    nItemLen = 2
                Else
                    bNotInCode = True
                End If
            End If
            
            ' エラーが無い場合は文字を出力し、読み進める
            If Not bNotInCode Then
                If nItemLen = 1 Then
                    If nChar1 = 202 Then
                        sRet = sRet & ChrW(102)
                    Else
                        sRet = sRet & ChrW(nChar1)
                    End If
                    nPtr = nPtr + 1
                Else
                    sRet = sRet & ChrW((nChar1 - 48) * 10 + (nChar2 - 48))
                    nPtr = nPtr + 2
                End If
            Else
                ' エラーがある場合
                If Not bCanChangeCodeSet Then
                    ' コードセットが強要されている場合は１文字読み飛ばす
                    nPtr = nPtr + 1
                Else
                    ' 次の移行先コードセットを決定する
                    nCodeSet = NextCodeSet(pi_sSrc, nLen, nPtr)
                    If nCodeSet = 1 Then
                        sRet = sRet & ChrW(101)
                    ElseIf nCodeSet = 2 Then
                        sRet = sRet & ChrW(100)
                    ElseIf nCodeSet = 3 Then
                        ' 変わらない場合はエラー（ありえない）
                        nPtr = nPtr + 1
                    End If
                End If
            End If
        
        ElseIf nCodeSet = 1 Then
            ' コードセットA
            ' 規則違反の確認
            bNotInCode = False
            bToCodeSet3 = False
            nItemLen = 0
            
            nChar = AscW(Mid(pi_sSrc, nPtr, 1))
            If (nChar >= 96 And nChar <= 127) Or nChar = 195 Then
                ' 念のため、195 = 95 = 127 = [DEL] で、DELと同値に扱います
                bNotInCode = True
            
            ElseIf Not bCanChangeCodeSet Then
                ' コードセット変更不可の場合は、以降の評価は行わない
            
            ElseIf nChar >= 48 And nChar <= 57 Then
                ' 数字４文字の連続チェックをします
                If IsCodeSet3(pi_sSrc, nLen, nPtr) Then
                    bNotInCode = True
                    bToCodeSet3 = True
                End If
            End If
            
            If Not bNotInCode Then
                ' 1文字出力
                If nChar = 202 Then
                    sRet = sRet & ChrW(102)
                ElseIf nChar >= 32 And nChar <= 95 Then
                    sRet = sRet & ChrW(nChar - 32)
                ElseIf nChar >= 0 And nChar <= 31 Then
                    sRet = sRet & ChrW(nChar + 64)
                End If
                nPtr = nPtr + 1
            
            ElseIf bToCodeSet3 = True Then
                ' コードセットCに切り替える
                nCodeSet = 3
                sRet = sRet & ChrW(99)
            
            Else
                ' コードセットの変更
                nCodeSet = NextCodeSet(pi_sSrc, nLen, nPtr, 1)
                
                If nCodeSet = -2 Then
                    ' シフトを使用して１文字だけコードセットBを出力する
                    If nChar >= 32 And nChar <= 127 Then
                        sRet = sRet & ChrW(198) & ChrW(nChar - 32)
                    End If
                    nCodeSet = 1
                    nPtr = nPtr + 1
                
                ElseIf nCodeSet = 2 Then
                    sRet = sRet & ChrW(100)
                
                End If
            End If
            
        ElseIf nCodeSet = 2 Then
            ' コードセットB
            ' 規則違反の確認
            bNotInCode = False
            bToCodeSet3 = False
            nItemLen = 0
            
            nChar = AscW(Mid(pi_sSrc, nPtr, 1))
            If nChar >= 0 And nChar <= 31 Then
                bNotInCode = True
            
            ElseIf Not bCanChangeCodeSet Then
                ' コードセット変更不可の場合は、以降の評価は行わない
            
            ElseIf nChar >= 48 And nChar <= 57 Then
                ' 数字４文字の連続チェックをします
                If IsCodeSet3(pi_sSrc, nLen, nPtr) Then
                    bNotInCode = True
                    bToCodeSet3 = True
                End If
            End If
            
            If Not bNotInCode Then
                ' 1文字出力
                If nChar = 202 Then
                    sRet = sRet & ChrW(102)
                ElseIf nChar >= 32 And nChar <= 127 Then
                    sRet = sRet & ChrW(nChar - 32)
                End If
                nPtr = nPtr + 1
            
            ElseIf bToCodeSet3 = True Then
                ' コードセットCに切り替える
                nCodeSet = 3
                sRet = sRet & ChrW(99)
            
            Else
                ' コードセットの変更
                nCodeSet = NextCodeSet(pi_sSrc, nLen, nPtr, 1)
                
                If nCodeSet = -1 Then
                    ' シフトを使用して１文字だけコードセットAを出力する
                    If nChar >= 32 And nChar <= 95 Then
                        sRet = sRet & ChrW(198) & ChrW(nChar - 32)
                    ElseIf nChar >= 0 And nChar <= 31 Then
                        sRet = sRet & ChrW(198) & ChrW(nChar + 64)
                    End If
                    nCodeSet = 1
                    nPtr = nPtr + 1
                
                ElseIf nCodeSet = 1 Then
                    sRet = sRet & ChrW(101)
                
                End If
            End If
        
        End If
    
    
    Loop
    
    EncodeCode128 = sRet

End Function

' チェックサム計算
' 入力：Code128  出力:Code128文字
Public Function GetCheckSum(ByRef pi_sSrc As String, Optional ByVal pi_bAddEnd As Boolean = True) As String
    Dim nPtr As Long
    Dim nLen As Long
    Dim nSum As Long
    Dim nWeight As Long
    
    nPtr = 1
    nLen = Len(pi_sSrc)
    nWeight = 1

    nSum = AscW(Mid(pi_sSrc, 1, 1))
    
    For nPtr = 2 To nLen
        nSum = (nSum + (AscW(Mid(pi_sSrc, nPtr, 1)) * nWeight) Mod 103) Mod 103
        
        If nWeight = 102 Then
            nWeight = 0
        Else
            nWeight = nWeight + 1
        End If
        
    Next

    If pi_bAddEnd Then
        GetCheckSum = pi_sSrc & ChrW(nSum) & ChrW(106)
    Else
        GetCheckSum = pi_sSrc & ChrW(nSum)
    End If
End Function

' フォントコードへの変換
' 入力：Code128  出力:FONT出力用文字列
Public Function FontCode(ByRef pi_sSrc As String) As String
    Dim sRet As String
    Dim nChar As Long
    Dim nPtr As Long
    Dim nLen As Long
    
    nLen = Len(pi_sSrc)
    sRet = ""
    For nPtr = 1 To nLen
        nChar = AscW(Mid(pi_sSrc, nPtr, 1))
        If nChar >= 0 And nChar <= 94 Then
            sRet = sRet & ChrW(nChar + 32)
        ElseIf nChar >= 95 And nChar <= 106 Then
            sRet = sRet & ChrW(nChar + 100)
        ElseIf nChar >= 195 And nChar <= 206 Then
            sRet = sRet & ChrW(nChar)
        End If
    Next

    FontCode = sRet

End Function

'
'

Public Function CheckDump(ByVal pi_sStr As String) As String
    Dim nPtr As Long
    Dim nLen As Long
    Dim sRet As String
    
    sRet = ""
    
    nLen = Len(pi_sStr)
    For nPtr = 1 To nLen
        'sRet = sRet & Right("00" & Hex(AscW(Mid(pi_sStr, nPtr, 1))), 2)
        sRet = sRet & Right("   " & CStr(AscW(Mid(pi_sStr, nPtr, 1))), 3)
        If nPtr = nLen Then
        ElseIf nPtr = 1 Then
            sRet = sRet & " "
        ElseIf (nPtr - 1) Mod 32 = 0 Then
            sRet = sRet & vbCrLf
        Else
            sRet = sRet & " "
        End If
    Next
    
    CheckDump = sRet
End Function

' 変換テーブル
'   変換元文字 を 6バイトで連結したもの。
'   後ろスペースを除いた文字数が一致・・・変換後文字を適用する
Private Sub SearchInTable( _
    ByRef po_nIdx As Long, ByRef po_nLen As Long, _
    ByRef pi_sStr As String, ByRef pi_nPtr As Long, ByRef pi_nTabStep As Long, ByRef pi_sTable As String, Optional ByRef pi_nIdxBase As Long = 1)
    Dim i As Long
    Dim nPtr As Long
    Dim nLen As Long
    Dim nIdxMax As Long
    Dim sItem As String

    nLen = Len(pi_sTable)
    nIdxMax = (nLen - 1) / pi_nTabStep
    
    po_nIdx = 0
    po_nLen = 0
    
    nPtr = 1
    For i = 1 To nIdxMax
        sItem = RTrim(Mid(pi_sTable, nPtr, pi_nTabStep))
        If Mid(pi_sStr, pi_nPtr, Len(sItem)) = sItem Then
            po_nIdx = i - 1 + pi_nIdxBase
            po_nLen = Len(sItem)
            Exit For
        End If
        
        nPtr = nPtr + pi_nTabStep
    Next

End Sub

Private Function GetFromTable(ByRef pi_nIdx As Long, ByRef pi_nTabStep As Long, ByRef pi_sTable) As String
    GetFromTable = RTrim(Mid(pi_sTable, 1 + pi_nIdx * pi_nTabStep, pi_nTabStep))
End Function

' 初期コードセットの取得
Private Function InitCodeSet(ByRef pi_sSrc As String) As Long
    Dim nPtr As Long
    Dim nChr1 As Long
    Dim nChr2 As Long
    Dim nCodeSet As Long
    Dim nLen As Long

    
    ' コードセットC を確認
    nPtr = 1
    nCodeSet = 0
    If Len(pi_sSrc) >= 2 Then
        nChr1 = AscW(Mid(pi_sSrc, nPtr, 1))
        If nChr1 = 202 Then
            ' １文字目のFNC1 は読み飛ばし
            nChr1 = AscW(Mid(pi_sSrc, nPtr + 1, 1))
            nChr2 = AscW(Mid(pi_sSrc, nPtr + 2, 1))
        Else
            nChr2 = AscW(Mid(pi_sSrc, nPtr + 1, 1))
        End If
        If nChr1 >= 48 And nChr1 <= 57 And nChr2 >= 48 And nChr2 <= 57 Then
            ' 先頭２文字が数字
            nCodeSet = 3
        End If
    End If
    
    If nCodeSet = 3 Then
    Else
        nCodeSet = 2    ' B を基本とする
        nLen = Len(pi_sSrc)
        Do
            If nPtr > nLen Then Exit Do
            
            nChr1 = AscW(Mid(pi_sSrc, nPtr, 1))
            '0-31の文字が、96-127 より先
            If nChr1 >= 0 And nChr1 <= 31 Then
                nCodeSet = 1
                Exit Do
            ElseIf (nChr1 >= 96 And nChr1 <= 127) Or nChr1 = 195 Then
                ' 念のため、195 = 95 = 127 = [DEL] で、DELと同値に扱います
                nCodeSet = 2
                Exit Do
            End If
            
            nPtr = nPtr + 1
        Loop
    End If

    InitCodeSet = nCodeSet
End Function

' 次のコードセットを探す
Private Function NextCodeSet(ByRef pi_sSrc As String, ByRef pi_nLen As Long, ByRef pi_nPtr As Long, Optional ByVal pi_nNowCodeSet As Long = 0) As Long
    Dim nPtr As Long
    Dim nChr As Long
    Dim nNumCnt As Long
    Dim nChr1 As Long
    Dim nChr2 As Long
    Dim nCodeSet As Long
    Dim nCodeSet1 As Long
    Dim nCodeSet2 As Long
    Dim nLen As Long

    
    ' コードセットC を確認
    ' nPtr より４文字連続して数値　または、２文字＋FNC1+２文字の場合、CodeSet=3 と判断
    nPtr = pi_nPtr
    nNumCnt = 0
    Do
        If nPtr + 2 > pi_nLen Then Exit Do
        nChr1 = AscW(Mid(pi_sSrc, nPtr, 1))
        If nChr1 = 202 Then
            ' FNC1 は読み飛ばし
            nPtr = nPtr + 1
        Else
            nChr2 = AscW(Mid(pi_sSrc, nPtr + 1, 1))
            
            If nChr1 >= 48 And nChr1 <= 57 And nChr2 >= 48 And nChr2 <= 57 Then
                nPtr = nPtr + 2
                nNumCnt = nNumCnt + 2
                
                If nNumCnt >= 4 Then Exit Do    ' ４桁の数値の連続を検知
            
            Else
                ' 数字以外であった
                Exit Do
            End If
        End If
    Loop
    
    If nNumCnt >= 4 Then
        nCodeSet = 3
    
    Else
        nCodeSet = 2    ' B を基本とする
        nPtr = pi_nPtr
        Do
            If nPtr > pi_nLen Then Exit Do
            
            nChr1 = AscW(Mid(pi_sSrc, nPtr, 1))
            '0-31の文字が、96-127 より先
            If nChr1 >= 0 And nChr1 <= 31 Then
                If pi_nNowCodeSet = 2 Then
                    ' 更に探索を進める
                    nCodeSet2 = NextCodeSet(pi_sSrc, pi_nLen, nPtr + 1)
                    If nCodeSet2 = 2 Then
                        ' １文字のみのシフト対応
                        nCodeSet = -1
                    Else
                        ' コードセットを変更
                        nCodeSet = 1
                    End If
                Else
                    nCodeSet = 1
                End If
                
                Exit Do
            
            ElseIf (nChr1 >= 96 And nChr1 <= 127) Or nChr1 = 195 Then
                ' 念のため、195 = 95 = 127 = [DEL] で、DELと同値に扱います
                
                If pi_nNowCodeSet = 1 Then
                    ' 更に探索を進める
                    nCodeSet2 = NextCodeSet(pi_sSrc, pi_nLen, nPtr + 1)
                    If nCodeSet2 = 1 Then
                        ' １文字のみのシフト対応
                        nCodeSet = -2
                    Else
                        ' コードセットを変更
                        nCodeSet = 2
                    End If
                Else
                    nCodeSet = 2
                End If
                Exit Do
            End If
            
            nPtr = nPtr + 1
        Loop
    End If

    NextCodeSet = nCodeSet
End Function

Private Function IsCodeSet3(ByRef pi_sSrc As String, ByRef pi_nLen As Long, ByRef pi_nPtr As Long) As Boolean

    Dim nPtr As Long
    Dim nChr As Long
    Dim nNumCnt As Long
    Dim nChr1 As Long
    Dim nChr2 As Long
    Dim nCodeSet As Long
    Dim nCodeSet1 As Long
    Dim nCodeSet2 As Long
    Dim nLen As Long

    
    ' コードセットC を確認
    ' nPtr より４文字連続して数値　または、２文字＋FNC1+２文字の場合、CodeSet=3 と判断
    nPtr = pi_nPtr
    nNumCnt = 0
    Do
        If nPtr + 2 > pi_nLen Then Exit Do
        nChr1 = AscW(Mid(pi_sSrc, nPtr, 1))
        If nChr1 = 202 Then
            ' FNC1 は読み飛ばし
            nPtr = nPtr + 1
        Else
            nChr2 = AscW(Mid(pi_sSrc, nPtr + 1, 1))
            
            If nChr1 >= 48 And nChr1 <= 57 And nChr2 >= 48 And nChr2 <= 57 Then
                nPtr = nPtr + 2
                nNumCnt = nNumCnt + 2
                
                If nNumCnt >= 4 Then Exit Do    ' ４桁の数値の連続を検知
            
            Else
                ' 数字以外であった
                Exit Do
            End If
        End If
    Loop
    
    If nNumCnt >= 4 Then
        IsCodeSet3 = True
    Else
        IsCodeSet3 = False
    End If

End Function


コメント

コメントを投稿

このブログの人気の投稿

Selenium Basic から Edge を使用したときの「Webエクスペリエンスのカスタマイズ」を非表示にする

Selenium にて、 EdgeWebDriver を使用して、Edge(chrome)を操作したとき、「Webエクスペリエンスのカスタマイズ」のウインドウが表示される現象が起きた。 【現象の整理】 ・通常に(Seleniumではなく手動で)Edgeを起動したときは、初回のみ表示される ・Selenium から起動したときは、毎回表示される ・表示されるページが、意図しないページになることがある。 【問題】 ・SendKeys などを使うときに問題となる。 ・Selenium にて、Get しても指定したページが開かないことがある。 【調査】 調べてみると以下の情報があった。 ・Selenium では、ユーザーのプロファイルは、起動毎に作成・廃棄される。 ・Selenium の起動時にユーザープロファイルを指定する方法がある。 通常起動時に、２回目以降表示されないため、ユーザープロファイルが関係していると推理。 Selenium からの起動時にユーザープロファイルを指定することで、ユーザープロファイルが保持されるようになり、「Webエクスペリエンスのカスタマイズ」が表示されなくなるか、検証することとした。 【検証】 ユーザープロファイルを指定して起動。 初回起動時に「Webエクス～」が表示されるため確認。 ２回目以降は表示されないことを確認した。     Dim driver As New Selenium.EdgeDriver     Dim elmDoc As Selenium.WebElement          driver.AddArgument "--user-data-dir=任意のフォルダ"     driver.AddArgument "--profile-directory=任意のフォルダ２"          With driver         .Start                   .Get "http://任意のアドレス"   ...
続きを読む

[VBScript]WiFiアダプタの無効化と有効化をスクリプトで実行する

OSをWindows10に入れ替えてから、起動直後やスリープからの復帰時に「識別中・・・インターネットアクセスなし」と表示され、インターネットに接続できない現象に遭遇しています。 結構な頻度で発生し、Wifiのネットワークアダプタを一度無効にしてから有効にすると治ります。 面倒な操作ですが、その後は安定するため、Wifiアダプタの買い替えまでには踏み切れません。 別件の調べ物をしていたら、WMIで無効・有効を操作できそうだったので、VBScriptで試してみました。 本題 VBScriptからWifiのネットワークアダプタを再接続（無効化→有効化）する。 ＜使い方＞ ・適当なファイル名(~.vbs）に保存し、ダブルクリックで実行。 ・ネットワークアダプタの名称に合わせて、検索条件（ %Wireless%の箇所）は適宜変更すること。 ・バッチファイルを作成し、起動後にスケジュール実行するようにしても良いかもしれません。無効・有効の設定には、管理者権限が必要なようです。 ポイント ・VBScriptからWMIを利用。Wifiアダプタの検索と設定が、比較的簡単。 ・アダプタの無効と有効の間に、何となくウェイトを入れています。根拠はありません。 Option Explicit Dim obj Set obj = Wscript.CreateObject("Shell.Application") if Wscript.Arguments.Count = 0 then ' 管理者権限でスクリプトを再実行する obj.ShellExecute "wscript.exe", WScript.ScriptFullName & " runas", "", "runas", 1 Wscript.Quit end if 'WMIにて使用する各種オブジェクトを定義・生成する。 Dim oClassSet Dim oClass Dim oLocator Dim oService 'ローカルコンピュータに接続する。 Set oLocator = WScript.CreateObject("WbemScripting.S...
続きを読む