セキュリティの厳しい社用PCなどでバーコードを作成するVBA

Sub DrawBarcodesInSteppedCells()
    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim inputRange As Range
    Set inputRange = ws.Range("AI3", ws.Cells(ws.Rows.Count, "AI").End(xlUp))

    Dim barWidth As Single: barWidth = 3
    Dim barHeight As Single: barHeight = 35
    Dim startRow As Long: startRow = 5      ' 最初の出力先行
    Dim rowStep As Long: rowStep = 5        ' 行間隔

    ' 古いバーコード削除
    Dim s As Shape
    For Each s In ws.Shapes
        If s.Name Like "BarCodeBar*" Or s.Name Like "BarCodeLabel*" Then s.Delete
    Next s

    Dim i As Long: i = 0
    Dim codeText As String, pattern As String
    Dim cell As Range
    Dim outputRow As Long
    Dim targetCell As Range
    Dim currentX As Single, startX As Single, startY As Single
    Dim barcodeIndex As Long: barcodeIndex = 0

    For Each cell In inputRange
        If Len(cell.Value) = 8 And IsNumeric(cell.Value) Then
            barcodeIndex = barcodeIndex + 1
            codeText = "*" & cell.Value & "*"
            pattern = GetCode39Pattern(codeText)

            outputRow = startRow + (barcodeIndex - 1) * rowStep
            Set targetCell = ws.Cells(outputRow, "B")

            startX = targetCell.Left + 5
            startY = targetCell.Top + 5
            currentX = startX

            ' バー描画
            Dim j As Long
            For j = 1 To Len(pattern)
                If Mid(pattern, j, 1) = "1" Then
                    With ws.Shapes.AddShape(msoShapeRectangle, currentX, startY, barWidth, barHeight)
                        .Name = "BarCodeBar" & barcodeIndex & "_" & j
                        .line.ForeColor.RGB = RGB(0, 0, 0)
                        .Fill.ForeColor.RGB = RGB(0, 0, 0)
                    End With
                End If
                currentX = currentX + barWidth
            Next j

            ' ラベル
            With ws.Shapes.AddTextbox(msoTextOrientationHorizontal, startX, startY + barHeight + 2, 150, 16)
                .TextFrame.Characters.text = cell.Value
                .Name = "BarCodeLabel" & barcodeIndex
                .TextFrame.HorizontalAlignment = xlHAlignLeft
                .TextFrame.VerticalAlignment = xlVAlignTop
                .line.Visible = msoFalse
            End With
        End If
    Next cell

    MsgBox "すべてのバーコードを作成しました！", vbInformation
End Sub

Function GetCode39Pattern(text As String) As String
    Dim patterns As Object
    Set patterns = CreateObject("Scripting.Dictionary")

    patterns.Add "*", "100101101101"
    patterns.Add "1", "110100101011"
    patterns.Add "2", "101100101011"
    patterns.Add "3", "110110010101"
    patterns.Add "4", "101001101011"
    patterns.Add "5", "110100110101"
    patterns.Add "6", "101100110101"
    patterns.Add "7", "101001011011"
    patterns.Add "8", "110100101101"
    patterns.Add "9", "101100101101"
    patterns.Add "0", "101001101101"

    Dim i As Long, result As String
    result = ""

    For i = 1 To Len(text)
        result = result & patterns(Mid(text, i, 1)) & "0"
    Next i

    GetCode39Pattern = result
End Function