【VBA】セルを塗りつぶしてCODE39バーコードを作成してみる

0

    <機能>

    (1)セルを使ってバーコード(CODE39規格)を作成します

     ※チェックディジットを付加します

    (2)バーコード作成データは設定ファイルから読み込みます

    (3)設定ファイルをデモ用に自動生成します

    (4)セルを使って作成したバーコードをファイルに出力します

     ※画像保存がうまくいかない場合はデバッグモードでブレイクするとうまくいくことが多いです

     (原因調査中)

     

    <動作検証>

    Microsoft Office 2016

     

    <実行イメージ>

    セルを使ってバーコード(CODE39)を作成

    VBA,CODE39バーコードを作成

    画像(JPG)として出力します

    VBA,CODE39バーコードを画像出力

     

    <補足>

    CODE39のパターン定義は以下のように行いました

    ・合計9個の文字で塗りとスペースを表現

     (例)「A」だと 100001001

    ・塗りとスペースは交互に出現(CODE39規格)

    ・太いバーを1、細いバーを0で表現する

    ・対象文字は「1-0,A-Z,-.$/+%」と半角スペースと「*」

     

    セルにバーコードを描画するルールを以下のように行いました

    ・細エレメント幅は1セル分
    ・太エレメント幅は2セル分(エレメント比=2.0)

     ※9本のうち、3本は太線なので1文字12セルとなります
    ・キャラクタギャップは1セル分
    ・クワイエットゾーン(左右余白)は1文字分+αで15セル

    ・チェックディジットを付加

     

    <使い方>
    適当なところにソースを貼り付けてください
    Code39バーコード作成() を実行すると処理を開始します

     

    '//バーコードの高さ
    Const D_BARHEIGHT As Integer = 25
    '//バーコードの上余白
    Const D_BARMARGIN_UP As Integer = 10
    '//バーコードの下余白
    Const D_BARMARGIN_DOWN As Integer = 50
    '//バーコードの左余白(出力位置)
    Const D_BARMARGIN_LEFT As Integer = 100

     

    '/********************************************************
    '/* Code39バーコード作成
    '/********************************************************

    Sub Code39バーコード作成()
        Dim strCode() As String
        Dim strDemotxt As String
        Dim folPath As String
        
        '//デモ用キャラクタ設定ファイルを自動生成
        strDemotxt = ThisWorkbook.Path & "¥バーコード変換対象.txt"
        MakeSampleTxt strDemotxt
        
        '//デモ用キャラクタ設定ファイルから変換対象キャラクタを取得
        ReadSampleTxt strDemotxt, strCode
           
        '//先頭にシートを追加
        strday = Now
        ThisWorkbook.Worksheets.Add Before:=Worksheets(1)
        Sheets(1).Name = "Code39_" & Format(strday, "yyyymmddhhmmss")
        
        '//全て(数式、文字列、書式、コメント、アウトライン)クリア
        Cells.Select
        Selection.Clear
        Selection.Font.Name = "MS ゴシック"
        Selection.Font.Size = 30
        Selection.ColumnWidth = 0.5
        Selection.RowHeight = 6
        Range("A1").Select
        With ActiveWindow
            '//ズーム設定
            .Zoom = 40
            '//枠線を非表示
            .DisplayGridlines = False
        End With
        
        '//画像保存用ディレクトリを作成
        folPath = ThisWorkbook.Path & "¥" & Sheets(1).Name
        MkDir folPath
        If Dir(folPath, vbDirectory) = "" Then
            MsgBox "画像保存フォルダの作成に失敗しました" & vbCrLf & folPath, vbCritical
            Exit Sub
        End If
        
        '//バーコード作成メイン処理
        MakeCode39BarCode strCode, folPath
           
        '//印刷の向き(横:xlLandscape 縦:xlPortrait)
        ActiveSheet.PageSetup.Orientation = xlPortrait
        Range("A1").Select
           
        '//終了メッセージ
        MsgBox "おわりました", vbInformation

    End Sub

     

    '/********************************************************
    '/* Code39バーコード作成 メイン処理
    '/********************************************************

    Sub MakeCode39BarCode(ByRef strCode() As String, ByVal folPath As String)
        
        Dim i As Integer, j As Integer, k As Integer
        Dim strptn As String, chk As String, strmoji As String
        Dim gyo As Long
        Dim clm As Integer
        Dim wkmoji As String
        
        '//初回の上余白を設定
        gyo = D_BARMARGIN_UP
        For i = 0 To UBound(strCode)
            
            '//描画ルール
            '//(1)細エレメント幅は1セル分
            '//(2)太エレメント幅は2セル分(エレメント比=2.0)
            '//(3)キャラクタギャップは1セル分
            '//(4)クワイエットゾーン(左右余白)は1文字分+αで15セル

            clm = D_BARMARGIN_LEFT
            '//クワイエットゾーン分あける
            clm = clm + 15
            
            '//チェックディジットを取得
            chk = GetCheckDigit(strCode(i))
            If chk = "" Then
                MsgBox "チェックディジットの取得に失敗しました" & vbCrLf & strCode(i), vbCritical
                GoTo nextrec
            End If
            
            '//スタートコード・ストップコード、チェックディジットを付加
            strmoji = "*" & strCode(i) & chk & "*"
            For j = 1 To Len(strmoji)
                '//パターンを取得
                strptn = GetCode39BarCodePattern(Mid(strmoji, j, 1))
                If strptn = "" Then
                    MsgBox "バーコードのパターンが見つかりませんでした" & vbCrLf & strCode(i), vbCritical
                    Cells(gyo, clm) = "【Error!!】"
                    GoTo nextrec
                End If
                
                '//描画開始
                For k = 1 To 9
                    wkmoji = Mid(strptn, k, 1)
                    If 1 = (k Mod 2) Then
                        '//奇数の時はバー(塗り部分)
                        Range(Cells(gyo, clm), Cells(gyo + D_BARHEIGHT, clm + CInt(wkmoji))).Interior.Color = RGB(0, 0, 0)
                    Else
                        '//偶数の時はスペース(空白)
                    End If
                    
                    '//カラム位置を進める
                    clm = clm + (1 + CInt(wkmoji))
                Next
                '//最終文字でなければキャラクタギャップを入れる
                If j <> Len(strmoji) Then
                    clm = clm + 1
                End If
                
            Next
            '//クワイエットゾーン分あける
            clm = clm + 15
            '//データを表示
            With Range(Cells(gyo + D_BARHEIGHT, D_BARMARGIN_LEFT), Cells(gyo + D_BARHEIGHT + 8, clm - 1))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                '//マイナス(-)、スラッシュ(/)が含まれる場合の文字化け防止
                .NumberFormatLocal = "@"
                .Value = strCode(i)
            End With
            
            '//画像として保存
            Dim savePath As String
            Dim rg As Range, cht As ChartObject
            savePath = folPath & "¥img" & Format(CStr(i + 1), "0000") & ".jpg"
            
            Range(Cells(gyo, D_BARMARGIN_LEFT), Cells(gyo + D_BARHEIGHT + 8, clm - 1)).Select
            Set rg = Selection
            rg.CopyPicture appearance:=xlScreen, Format:=xlBitmap
            
            Set cht = ActiveSheet.ChartObjects.Add(rg.Left, rg.Top, rg.Width, rg.Height)
            cht.Activate
            cht.Chart.Paste
            
            cht.Parent.Activate
            ActiveChart.ChartArea.Format.Line.Visible = False
            ActiveChart.HasLegend = False
            cht.Chart.Export Filename:=savePath, Filtername:="JPG"
            cht.Chart.Parent.Delete
            Range("A" & CStr(gyo)).Select
                   
            '//行の開始位置を更新(バーコードの高さ+データ表示)
            gyo = gyo + D_BARHEIGHT + 8
            '//下余白を設定
            gyo = gyo + D_BARMARGIN_DOWN
            '//改ページ(水平方向)を設定
            ActiveSheet.HPageBreaks.Add Before:=Range("A" & CStr(gyo))
            
            '//次のバーコードの上余白を確保
            gyo = gyo + D_BARMARGIN_UP
            
    nextrec:
        Next

     

    End Sub

     

    '/********************************************************
    '/* Code39バーコード作成 指定文字のパターンを取得
    '/********************************************************

    Function GetCode39BarCodePattern(ByVal moji As String) As String
        GetCode39BarCodePattern = ""
        Dim ptn As Variant
        Dim i As Integer, wkstr() As String
        
        '//Code39のパターン定義
        '//(1)バー(塗り部分)とスペース(空白)の合計は9
        '//(2)バーとスペースが交互に出現する
        '//(3)太:1、細:0で表現する
        '//(4)対象文字「1-0,A-Z,-.$/+%」、半角スペース、*

        ptn = Array("0,000110100", "1,100100001", "2,001100001", _
                    "3,101100000", "4,000110001", "5,100110000", _
                    "6,001110000", "7,000100101", "8,100100100", _
                    "9,001100100", "A,100001001", "B,001001001", _
                    "C,101001000", "D,000011001", "E,100011000", _
                    "F,001011000", "G,000001101", "H,100001100", _
                    "I,001001100", "J,000011100", "K,100000011", _
                    "L,001000011", "M,101000010", "N,000010011", _
                    "O,100010010", "P,001010010", "Q,000000111", _
                    "R,100000110", "S,001000110", "T,000010110", _
                    "U,110000001", "V,011000001", "W,111000000", _
                    "X,010010001", "Y,110010000", "Z,011010000", _
                    "-,010000101", ".,110000100", " ,011000100", _
                    "$,010101000", "/,010100010", "+,010001010", _
                    "%,000101010", "*,010010100")
        
        '//パターンを検索
        For i = 0 To UBound(ptn)
            wkstr = Split(ptn(i), ",")
            If moji = wkstr(0) Then
                If UBound(wkstr) = 0 Then Exit Function
                GetCode39BarCodePattern = wkstr(1)
                Exit Function
            End If
        Next
        
    End Function

     

    '/********************************************************
    '/* Code39バーコード作成 チェックディジットを取得
    '/********************************************************

    Function GetCheckDigit(ByVal str As String)
        GetCheckDigit = ""
        Dim i As Integer
        Dim wkmoji As String, iwk As Integer, ichk As Integer
        Dim total As Integer
        
        total = 0
        For i = 1 To Len(str)
            wkmoji = Mid(str, i, 1)
            iwk = Asc(wkmoji)
            
            If iwk >= 48 And iwk <= 57 Then
                '//数値はそのまま足す
                total = total + (iwk - 48)
            
            ElseIf iwk >= 65 And iwk <= 90 Then
                '//A-Zは10-35に変換して足す
                total = total + (iwk - 55)
            
            Else
                '//特殊記号
                Select Case iwk
                Case 45 '"-"
                    total = total + 36
                Case 46 '"."
                    total = total + 37
                Case 32 '半角スペース
                    total = total + 38
                Case 36 '"$"
                    total = total + 39
                Case 47 '"/"
                    total = total + 40
                Case 43 '"+"
                    total = total + 41
                Case 37 '"%"
                    total = total + 42
                Case Else
                    Exit Function
                End Select
                
            End If
        Next
        
        '//モジュラス43方式なので43で割った余りを求める
        ichk = total Mod 43
        
        '//チェックディジットを取得
        If ichk >= 0 And ichk <= 9 Then
            GetCheckDigit = CStr(ichk)
        ElseIf ichk >= 10 And ichk <= 35 Then
            GetCheckDigit = Chr(65 + (ichk - 10))
        Else
            '//特殊記号
            Select Case ichk
            Case 36
                GetCheckDigit = "-"
            Case 37
                GetCheckDigit = "."
            Case 38
                GetCheckDigit = " "
            Case 39
                GetCheckDigit = "$"
            Case 40
                GetCheckDigit = "/"
            Case 41
                GetCheckDigit = "+"
            Case 42
                GetCheckDigit = "%"
            Case Else
                Exit Function
            End Select
        End If
        
    End Function

     

    '/********************************************************
    '/* 取得文字列がCode39対象文字かチェック
    '/* 戻り値;True(対象) False(非対象文字が混入)
    '/********************************************************

    Function isCode39Character(ByVal buf As String) As Boolean
        Const strchk As String = "[0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$/+% ,-]"
        Dim i As Integer, moji As String
        
        '//本サンプルプログラムの仕様として32文字を上限とする
        If LenB(buf) > 32 Then
            isCode39Character = False
            Exit Function
        End If
        
        isCode39Character = True
        For i = 1 To Len(buf)
            moji = Mid(buf, i, 1)
            If moji Like strchk Then
                'パターンにマッチ
            Else
                'パターンにアンマッチ
                isCode39Character = False
                Exit Function
            End If
        Next
    End Function

     

    '/********************************************************
    '/* デモ用ファイルからバーコード変換対象キャラクタを取得
    '/********************************************************

    Sub ReadSampleTxt(ByVal strSample As String, ByRef strCode() As String)
        Dim fl As Long
        
        '//取得バッファを初期化
        ReDim strCode(0)
        strCode(0) = ""
        
        '//テスト用サンプルテキストファイルをオープン
        fl = FreeFile
        Open strSample For Input As #fl
        
        Do Until EOF(fl)
            Line Input #fl, buf
            '//大文字に変換
            buf = UCase(buf)
            '//半角に変換
            buf = StrConv(buf, vbNarrow)
            
            '//空白行、"'"で始まる行はスキップ
            If buf = "" Then GoTo nextgyo
            If Mid(buf, 1, 1) = "'" Then GoTo nextgyo
            
            '//対象文字列意外が設定されていればスキップ
            If Not isCode39Character(buf) Then GoTo nextgyo
            
            '//バーコード変換対象文字列としてバッファにセット
            If strCode(0) = "" Then
                strCode(0) = buf
            Else
                ReDim Preserve strCode(UBound(strCode) + 1)
                strCode(UBound(strCode)) = buf
            End If
    nextgyo:
        Loop
        
        '//テスト用サンプルテキストファイルをクローズ
        Close #fl
    End Sub

     

    '/********************************************************
    '/* バーコード変換対象キャラクタ設定ファイルをダミーで作成
    '/********************************************************

    Sub MakeSampleTxt(ByVal strSample As String)
        Dim fl As Long
        
        '//テスト用サンプルテキストファイルをオープン
        fl = FreeFile
        Open strSample For Output As #fl
        
        '//データを書き込み
        Print #fl, "'//// テスト用ダミーテキストファイル"
        Print #fl, "1234567890"
        Print #fl, "123456"
        Print #fl, "123"
        Print #fl, "abcdefghijklmnopqrstuvwxyz"
        Print #fl, "ABC-12345/DEF"
        Print #fl, "-.$/+ %"
        
        '//テスト用サンプルテキストファイルをクローズ
        Close #fl
    End Sub
     

    よろしければポチッと押してください

    プログラマー ブログランキングへ

     



    selected entries

    categories

    calendar

    S M T W T F S
         12
    3456789
    10111213141516
    17181920212223
    24252627282930
    31      
    << March 2024 >>

    profile

    others

    archives