【VBA】セルを塗りつぶしてCODE39バーコードを作成してみる
<機能>
(1)セルを使ってバーコード(CODE39規格)を作成します
※チェックディジットを付加します
(2)バーコード作成データは設定ファイルから読み込みます
(3)設定ファイルをデモ用に自動生成します
(4)セルを使って作成したバーコードをファイルに出力します
※画像保存がうまくいかない場合はデバッグモードでブレイクするとうまくいくことが多いです
(原因調査中)
<動作検証>
Microsoft Office 2016
<実行イメージ>
セルを使ってバーコード(CODE39)を作成
画像(JPG)として出力します
<補足>
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
よろしければポチッと押してください