[[20250226230455]]　『バーコード作成ツール』（ごう）　ページの最後に飛ぶ

『バーコード作成ツール』（ごう）

このコードはかなり古い物になります。20年前の物です。多分
開いてみたらエラーになり使えなくなっておりました。
使えたらと思いダメもとでお聞きしたいと思います。
使えるようになりますか？よろしくお願いします。
ちなみにマクロやVBAは私は？です。

'------------------------------------------------------------------------------
'ビットマップ構造体
'------------------------------------------------------------------------------
Private Type BITMAPINFOHEADER

    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type

Const BI_RGB = 0&

'------------------------------------------------------------------------------
'API宣言
'------------------------------------------------------------------------------
Private Declare Sub MoveMemory Lib "kernel32" _

        Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, _
        ByVal Length As Long)

Private Declare Function GlobalAlloc Lib "kernel32" _

        (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Const GMEM_DDESHARE = &H2000
Private Declare Function GlobalFree Lib "kernel32" _
        (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" _
        (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
        (ByVal hMem As Long) As Long

Private Declare Function OpenClipboard Lib "user32" _

        (ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" _
        (ByVal uFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Const CF_DIB = 8

'----------------------------------------------------
' バーコードタイプキャラクタ配列宣言
'----------------------------------------------------
'[ BAR ]
Private t_BAR_Char As String ' キャラクタセット
Private t_BAR_CharStr As Variant ' 非単文字キャラクタセット
Private t_BAR_Pattern As Variant ' バーパターン

'----------------------------------------------------
' プロパティ変数宣言
'----------------------------------------------------
Private m_Target As Object ' 出力対象オブジェクト

Private m_Top As Long ' 出力開始上端位置
Private m_Left As Long ' 出力開始左端位置
Private m_Kind As Long ' バーコード種類
Private m_Block As Long ' バーコード 1ブロックラインサイズ
Private m_Height As Long ' バーコード高さ
Private m_Width As Long ' バーコード横幅

Private m_Check As Boolean ' モジュラスチェックあり/なし

Private m_code As String ' コードキャラクタ
Private m_StartChr As String ' スタートキャラクタ(A,B,C,D)
Private m_StopChr As String ' ストップキャラクタ(A,B,C,D)
Private m_CtrlChr As String ' 制御括文字
Private m_StartMode As String ' スタートモード(A,B,C)

'------------------------------------------------------------------------------
' Long型2次元配列のビットマップをクリップボードにコピー
'------------------------------------------------------------------------------
Public Function CopyDIBToClipBoard(Data() As Long) As Boolean

    Dim bmih As BITMAPINFOHEADER
    Dim hMem        As Long
    Dim lpBuf       As Long
    Dim lngHeadSize As Long
    Dim lngBitsSize As Long
    Dim fSuccess    As Boolean

    ' BITMAPINFOHEADERのセット
    If Not FillHeader(Data, bmih) Then Exit Function
    With bmih
        lngHeadSize = .biSize
        lngBitsSize = 4 * .biWidth * Abs(.biHeight)
    End With

    ' メモリの確保
    hMem = GlobalAlloc(GMEM_DDESHARE, lngHeadSize + lngBitsSize)
    If hMem = 0 Then Exit Function

    lpBuf = GlobalLock(hMem)

    If lpBuf = 0 Then
        GlobalFree hMem: Exit Function
    End If

    ' データのコピー
    MoveMemory ByVal lpBuf, bmih, lngHeadSize
    MoveMemory ByVal lpBuf + lngHeadSize, _
               Data(LBound(Data), LBound(Data, 2)), _
               lngBitsSize
    GlobalUnlock hMem

    ' クリップボードに出力
    If OpenClipboard(0) Then
        EmptyClipboard
        If SetClipboardData(CF_DIB, hMem) Then
            fSuccess = True
        End If
        CloseClipboard
    End If

    ' メモリの解放
'    If Not fSuccess Then GlobalFree hMem       '←元は出力不成功の時だけ解放。なぜだろう…
    GlobalFree hMem
    CopyDIBToClipBoard = fSuccess

End Function

'------------------------------------------------------------------------------
' BITMAPINFOHEADERの設定
'------------------------------------------------------------------------------
Private Function FillHeader(Data() As Long, _

                    bmih As BITMAPINFOHEADER) As Boolean

    Dim lngWidth  As Long
    Dim lngHeight As Long

    ' 配列の要素数(＝ビットマップの幅と高さ)を取得
    On Error Resume Next
    lngWidth = UBound(Data) - LBound(Data) + 1
    lngHeight = UBound(Data, 2) - LBound(Data, 2) + 1
    On Error GoTo 0

    If lngWidth = 0 Or lngHeight = 0 Then
        Exit Function
    End If

    With bmih
        .biSize = Len(bmih)
        .biWidth = lngWidth
        '.biHeight = lngHeight  ' ボトムアップ形式にする場合
        .biHeight = -lngHeight  ' トップダウン形式にする場合
        .biPlanes = 1
        .biBitCount = 32        ' bpp
        .biCompression = BI_RGB
    End With

    FillHeader = True

End Function

'------------------------------------------------------------------------------
' JANチェックキャラクタ任意桁用 (JAN標準・短縮共用)
'------------------------------------------------------------------------------
Private Function pfncJANCheck(ByVal strCode As String) As Long

    Dim i As Long
    Dim lngModulus As Long
    Dim WorkModulus As Long

    pfncJANCheck = -1
    lngModulus = 0

    For i = 0 To Len(strCode) - 1
        WorkModulus = (InStr(t_BAR_Char, UCase(Mid(strCode, Len(strCode) - i, 1))) - 1)

        If i Mod 2 Then
            lngModulus = lngModulus + WorkModulus * 3
        Else
            lngModulus = lngModulus + WorkModulus
        End If

    Next i

    i = lngModulus Mod 10
    pfncJANCheck = 10 - i

    If pfncJANCheck = 10 Then pfncJANCheck = 0

End Function

'------------------------------------------------------------------------------
' モジュラス16 任意桁用 (NW7用)
'------------------------------------------------------------------------------
Private Function pfncModulus16(ByVal strCode As String) As Long

    Dim i As Long
    Dim lngModulus As Long

    pfncModulus16 = -1
    lngModulus = 0

    For i = 1 To Len(strCode)
        lngModulus = lngModulus + (InStr(t_BAR_Char, UCase(Mid(strCode, i, 1))) - 1)
    Next i

    i = lngModulus Mod 16
    pfncModulus16 = 16 - i

    If pfncModulus16 = 16 Then pfncModulus16 = 0

End Function

'------------------------------------------------------------------------------
' モジュラス43 任意桁用 (CODE39用)
'------------------------------------------------------------------------------
Private Function pfncModulus43(ByVal strCode As String) As Long

    Dim i As Long
    Dim lngModulus As Long

    pfncModulus43 = -1
    lngModulus = 0

    For i = 1 To Len(strCode)
        lngModulus = lngModulus + (InStr(t_BAR_Char, UCase(Mid(strCode, i, 1))) - 1)
    Next i

    i = lngModulus Mod 43
    pfncModulus43 = i

End Function

'------------------------------------------------------------------------------
' NW7,CODE39 変換
'------------------------------------------------------------------------------
Private Function pfncConvBAR(ByVal strCode As String) As String

    Dim i As Long
    Dim j As Long
    Dim lngLength As Long

    pfncConvBAR = ""
    lngLength = Len(strCode)

    For i = 1 To lngLength
        ' 変換
        j = InStr(t_BAR_Char, UCase(Mid(strCode, i, 1)))

        If j > 0 Then
            pfncConvBAR = pfncConvBAR + t_BAR_Pattern(j - 1)
        End If

    Next i

End Function

'------------------------------------------------------------------------------
' CODE128 変換
'------------------------------------------------------------------------------
Private Function pfncConvBAR128(ByVal strCode As String, ByVal CtrlChr As String, ByVal StartMode As String) As String

    Dim Cnt As Long
    Dim Cnt1 As Long
    Dim Cnt2 As Long
    Dim Cnt_chr As Long
    Dim Cnt_CD103 As Long
    Dim CD103 As Long
    Dim lngLength As Long
    Dim t_BAR_CharStrA As Variant
    Dim t_BAR_CharStrB As Variant
    Dim t_BAR_CharStrC As Variant
    Dim t_BAR_CharStrX As Variant
    Dim CodeMode As String

    t_BAR_CharStrA = Array("SP", "!", """", "#", "$", "%", "&", "'", "(", ")", _
                           "*", "+", ",", "-", ".", "/", "0", "1", "2", "3", _
                           "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", _
                           ">", "?", "@", "A", "B", "C", "D", "E", "F", "G", _
                           "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", _
                           "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "[", _
                           "\", "]", "^", "_", "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", _
                           "ACK", "BEL", "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", _
                           "DEL", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "EM", _
                           "SUB", "ESC", "FS", "GS", "RS", "US", "FNC3", "FNC2", "SHIFT", "CODEC", _
                           "CODEB", "FNC4", "FNC1")

    t_BAR_CharStrB = Array("SP", "!", """", "#", "$", "%", "&", "'", "(", ")", _
                           "*", "+", ",", "-", ".", "/", "0", "1", "2", "3", _
                           "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", _
                           ">", "?", "@", "A", "B", "C", "D", "E", "F", "G", _
                           "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", _
                           "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "[", _
                           "\", "]", "^", "_", "‘", "a", "b", "c", "d", "e", _
                           "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", _
                           "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", _
                           "z", "{", "|", "}", "～", "DEL", "FNC3", "FNC2", "SHIFT", "CODEC", _
                           "FNC4", "CODEA", "FNC1")

    t_BAR_CharStrC = Array("00", "01", "02", "03", "04", "05", "06", "07", "08", "09", _
                           "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", _
                           "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", _
                           "30", "31", "32", "33", "34", "35", "36", "37", "38", "39", _
                           "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", _
                           "50", "51", "52", "53", "54", "55", "56", "57", "58", "59", _
                           "60", "61", "62", "63", "64", "65", "66", "67", "68", "69", _
                           "70", "71", "72", "73", "74", "75", "76", "77", "78", "79", _
                           "80", "81", "82", "83", "84", "85", "86", "87", "88", "89", _
                           "90", "91", "92", "93", "94", "95", "96", "97", "98", "99", _
                           "CODEB", "CODEA", "FNC1")

    CodeMode = StartMode
    pfncConvBAR128 = ""
    lngLength = Len(strCode)

    CtrlFlg = "OFF"
    ShiftFlg = "OFF"

    Cnt_CD103 = 0
    Cnt_chr = 0

    Select Case StartMode
      Case "A"
        pfncConvBAR128 = pfncConvBAR128 + "11010000100"    'スタートコードA
        t_BAR_CharStrX = t_BAR_CharStrA
        Cnt_CD103 = 103
      Case "B"
        pfncConvBAR128 = pfncConvBAR128 + "11010010000"    'スタートコードB
        t_BAR_CharStrX = t_BAR_CharStrB
        Cnt_CD103 = 104
      Case "C"
        pfncConvBAR128 = pfncConvBAR128 + "11010011100"    'スタートコードC
        t_BAR_CharStrX = t_BAR_CharStrC
        Cnt_CD103 = 105
    End Select

    '対象文字列分解
    For Cnt = 1 To lngLength

        If CtrlFlg = "OFF" Then
            ConStr = Mid(strCode, Cnt, 1)
        End If

        '制御括出現
        If Mid(strCode, Cnt, 1) = CtrlChr Then

            If CtrlFlg = "ON" Then
                CtrlFlg = "OFF"
                If ConStr = "" Then
                    ConStr = CtrlChr    '制御括終了時に文字なしは制御括文字自身
                End If
            Else
                CtrlFlg = "ON"
                ConStr = ""
            End If

        End If

        If CtrlFlg = "OFF" Then

            ' 変換
            For Cnt1 = 0 To 102

                If t_BAR_CharStrX(Cnt1) = ConStr Then
                    Cnt2 = Cnt1
                    Exit For
                End If

            Next Cnt1

            If Cnt2 >= 0 And Cnt2 <= 102 Then
                pfncConvBAR128 = pfncConvBAR128 + t_BAR_Pattern(Cnt2)
                Cnt_chr = Cnt_chr + 1
                Cnt_CD103 = Cnt_CD103 + (Cnt2 * Cnt_chr)
            End If

            'コード一時変更指示なら各セットを変更
            If ShiftFlg = "ON" Then

                ShiftFlg = "OFF"

                Select Case CodeMode
                  Case "C"
                    t_BAR_CharStrX = t_BAR_CharStrC
                  Case "B"
                    t_BAR_CharStrX = t_BAR_CharStrB
                  Case "A"
                    t_BAR_CharStrX = t_BAR_CharStrA
                End Select

            End If

            'コード変更指示なら各セットを変更
            Select Case ConStr
              Case "CODEC"
                CodeMode = "C"
                t_BAR_CharStrX = t_BAR_CharStrC
              Case "CODEB"
                CodeMode = "B"
                t_BAR_CharStrX = t_BAR_CharStrB
              Case "CODEA"
                CodeMode = "A"
                t_BAR_CharStrX = t_BAR_CharStrA
            End Select

            'コード一時変更指示なら各セットを変更
            If ConStr = "SHIFT" Then

                ShiftFlg = "ON"

                Select Case CodeMode
                  Case "C"
                    t_BAR_CharStrX = t_BAR_CharStrA
                  Case "B"
                    t_BAR_CharStrX = t_BAR_CharStrC
                  Case "A"
                    t_BAR_CharStrX = t_BAR_CharStrB
                End Select

            End If

        Else
            '制御括処理中で制御括文字でなければ検索対象文字列に追加
            If Mid(strCode, Cnt, 1) <> CtrlChr Then
                ConStr = ConStr & Mid(strCode, Cnt, 1)
            End If

        End If

    Next Cnt

    'チェックディジット算出
    CD103 = Cnt_CD103 Mod 103

    'ストップコード追加
    pfncConvBAR128 = pfncConvBAR128 + t_BAR_Pattern(CD103) + "1100011101011"

End Function

'------------------------------------------------------------------------------
' JAN 変換
'------------------------------------------------------------------------------
Private Function pfncConvBARJAN(ByVal strCode As String) As String

    Dim i As Long
    Dim j As Long
    Dim lngLength As Long
    Dim t_BAR_Parity As Variant     ' パリティパターン
    Dim BAR_Pattern As String
    Dim p As String

    '1:奇数、0:偶数
    t_BAR_Parity = Array("111111", _
                          "110100", _
                          "110010", _
                          "110001", _
                          "101100", _
                          "100110", _
                          "100011", _
                          "101010", _
                          "101001", _
                          "100101")

    pfncConvBARJAN = ""

    ' パリティの決定
    p = t_BAR_Parity(UCase(Left(strCode, 1)))
    strCode = Mid(strCode, 2, 12)
    lngLength = Len(strCode)

    For i = 1 To lngLength

        'センターバーの挿入
        If i = 7 Then
            pfncConvBARJAN = pfncConvBARJAN & "01010"
        End If

        ' 変換
        j = InStr(t_BAR_Char, UCase(Mid(strCode, i, 1)))

        If j > 0 Then

            If i < 7 And Mid(p, i, 1) = 1 Then
                'センターの左でかつパリティが奇数ならそのまま使用
                BAR_Pattern = t_BAR_Pattern(j - 1)
            Else
                BAR_Pattern = t_BAR_Pattern(j - 1)

                'バーとスペースを反転
                BAR_Reverse = ""

                For X = 1 To 7
                    If Mid(BAR_Pattern, X, 1) = "1" Then
                        BAR_Reverse = BAR_Reverse & "0"
                    Else
                        BAR_Reverse = BAR_Reverse & "1"
                    End If
                Next X

                BAR_Pattern = BAR_Reverse

                'センターの左は並びを左右入れ替え
                If i < 7 Then

                    BAR_Reverse = ""

                    For X = 1 To 7
                        BAR_Reverse = Mid(BAR_Pattern, X, 1) & BAR_Reverse
                    Next X

                    BAR_Pattern = BAR_Reverse

                End If

            End If

            pfncConvBARJAN = pfncConvBARJAN + BAR_Pattern

        End If

    Next i

    'スタート＆ストップ付加
    pfncConvBARJAN = "101" + pfncConvBARJAN + "101"

End Function

'------------------------------------------------------------------------------
' バーコード出力
'------------------------------------------------------------------------------
'Public Sub PrintBar(m_code, m_Height)
Public Function PrintBar(m_code, m_Height, m_Width, m_Check, m_Kind, m_StartChr, m_StopChr, m_CtrlChr, m_StartMode)

    Dim i As Long               ' ループカウンタ
    Dim strCode As String       ' スタート・ストップ・チェックを含むコード
    Dim strPatern As String     ' strCodeのBARパターンデータ
    Dim lngRatioX As Long       ' 横(X)比率
    Dim lngRatioY As Long       ' 縦(Y)比率
    Dim lngBlock As Long        ' 1ブロックサイズ
    Dim lngX1 As Long           ' バー開始X座標
    Dim lngY1 As Long           '         Y座標
    Dim lngX2 As Long           ' バー終了X座標
    Dim lngY2 As Long           '         Y座標
    Dim strChr As String        ' 1キャラクタ文字列
    Dim lngChrBarWidth As Long  ' 1キャラクタバーコード幅
    Dim lngChrWidth As Long     ' コード文字列1キャラクタ幅

    '--------------------------------------------
    ' バーコードタイプキャラクタ配列初期設定開始
    '--------------------------------------------
    Select Case m_Kind
      Case 0
        'm_StartChr = "A"
        'm_StopChr = "A"
        Init_Return = BarInit_NW7()

      Case 1
        m_StartChr = "*"
        m_StopChr = "*"
        Init_Return = BarInit_C39()

      Case 2
        m_StartChr = ""
        m_StopChr = ""
        Init_Return = BarInit_C128()

      Case 3
        m_StartChr = ""
        m_StopChr = ""
        Init_Return = BarInit_JAN()

    End Select

    '--------------------------------------------
    ' バーコードタイプキャラクタ配列初期設定終了
    '--------------------------------------------

    ' スタート・ストップキャラクタ
    strCode = m_StartChr & m_code & m_StopChr

    ' モジュラスチェック
    If m_Check Then
        Select Case m_Kind

          'NW7(モジュラス16)=スタート・ストップ込みで計算
          Case 0
            strCode = m_StartChr & m_code & _
                Mid(t_BAR_Char, pfncModulus16(strCode) + 1, 1) & m_StopChr

          'CODE39(モジュラス43)=スタート・ストップなしで計算
          Case 1
            strCode = m_StartChr & m_code & _
                Mid(t_BAR_Char, pfncModulus43(m_code) + 1, 1) & m_StopChr

          'CODE128(モジュラス103)=スタートのみ付きという変則のため変換ルーチン内で処理

          'JAN(JAN専用)=スタート・ストップはない
          Case 3
            strCode = m_code & pfncJANCheck(strCode)

        End Select
    End If

    ' BAR パターンに変換
    Select Case m_Kind
      Case 2
        strPatern = pfncConvBAR128(strCode, m_CtrlChr, m_StartMode)
      Case 3
        strPatern = pfncConvBARJAN(strCode)
      Case Else
        strPatern = pfncConvBAR(strCode)
    End Select

    ' 1キャラクタバーコード幅
    lngChrBarWidth = (lngBlock * lngRatioY) * 14

    ' バーコード描画
    BarPix = 4              'バー１本分の幅ピクセル数

    ' パターン分x1 ピクセル
    ReDim myData(1 To Len(strPatern) * BarPix, 0 To 0) As Long
    Dim X As Long, Y As Long

    For Y = 0 To 0

        i0 = 0

        For i = 1 To Len(strPatern): For z = 1 To BarPix

            ' バー出力(高さ1ピクセル)
            i0 = i0 + 1

            If Mid(strPatern, i, 1) = "1" Then
                myData(i0, Y) = RGB(0, 0, 0)
            Else
                myData(i0, Y) = RGB(255, 255, 255)
            End If

        Next: Next i
    Next

    ' コピー＆ペースト
    If CopyDIBToClipBoard(myData) Then

        ActiveSheet.Paste                   'クリップボードから貼り付け

        Change_Height = Selection.ShapeRange.Height     'サイズ調整
        Change_Width = Selection.ShapeRange.Width
        Change_Height = m_Height / Change_Height
        Change_Width = m_Width / Change_Width

        '何故か縦方向は106倍以上はエラーになるので暫定回避
        Do While Change_Height > 106
            Selection.ShapeRange.ScaleHeight 106, msoFalse, msoScaleFromTopLeft
            Change_Height = Change_Height / 106
        Loop

        '縦方向に拡大
        Selection.ShapeRange.ScaleHeight Change_Height, msoFalse, msoScaleFromTopLeft

        '横方向に拡大
        Selection.ShapeRange.ScaleWidth Change_Width, msoFalse, msoScaleFromTopLeft

    End If

End Function

Public Function BarInit_JAN()

    '****************************************
    '                  JAN
    '****************************************
    t_BAR_Char = "0123456789"
    t_BAR_Pattern = Array("0001101", _
                          "0011001", _
                          "0010011", _
                          "0111101", _
                          "0100011", _
                          "0110001", _
                          "0101111", _
                          "0111011", _
                          "0110111", _
                          "0001011")

End Function

Public Function BarInit_C128()

    '****************************************
    '                  Code128
    '****************************************
    t_BAR_Char = ""
    t_BAR_Pattern = Array("11011001100", "11001101100", "11001100110", "10010011000", "10010001100", _
                          "10001001100", "10011001000", "10011000100", "10001100100", "11001001000", _
                          "11001000100", "11000100100", "10110011100", "10011011100", "10011001110", _
                          "10111001100", "10011101100", "10011100110", "11001110010", "11001011100", _
                          "11001001110", "11011100100", "11001110100", "11101101110", "11101001100", _
                          "11100101100", "11100100110", "11101100100", "11100110100", "11100110010", _
                          "11011011000", "11011000110", "11000110110", "10100011000", "10001011000", _
                          "10001000110", "10110001000", "10001101000", "10001100010", "11010001000", _
                          "11000101000", "11000100010", "10110111000", "10110001110", "10001101110", _
                          "10111011000", "10111000110", "10001110110", "11101110110", "11010001110", _
                          "11000101110", "11011101000", "11011100010", "11011101110", "11101011000", _
                          "11101000110", "11100010110", "11101101000", "11101100010", "11100011010", _
                          "11101111010", "11001000010", "11110001010", "10100110000", "10100001100", _
                          "10010110000", "10010000110", "10000101100", "10000100110", "10110010000", _
                          "10110000100", "10011010000", "10011000010", "10000110100", "10000110010", _
                          "11000010010", "11001010000", "11110111010", "11000010100", "10001111010", _
                          "10100111100", "10010111100", "10010011110", "10111100100", "10011110100", _
                          "10011110010", "11110100100", "11110010100", "11110010010", "11011011110", _
                          "11011110110", "11110110110", "10101111000", "10100011110", "10001011110", _
                          "10111101000", "10111100010", "11110101000", "11110100010", "10111011110", _
                          "10111101110", "11101011110", "11110101110", "11010000100", "11010010000", _
                          "11010011100", "1100011101011")

End Function

Public Function BarInit_C39()

    '****************************************
    '                  Code39
    '****************************************
    t_BAR_Char = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%*"
    t_BAR_Pattern = Array("11001100000111110011111001100", "11111001100000110011001111100", "11001111100000110011001111100", "11111001111100000110011001100", _
                          "11001100000111110011001111100", "11111001100000111110011001100", "11001111100000111110011001100", "11001100000110011111001111100", _
                          "11111001100000110011111001100", "11001111100000110011111001100", _
                          "11111001100110000011001111100", "11001111100110000011001111100", "11111001111100110000011001100", "11001100111110000011001111100", _
                          "11111001100111110000011001100", "11001111100111110000011001100", "11001100110000011111001111100", "11111001100110000011111001100", _
                          "11001111100110000011111001100", "11001100111110000011111001100", "11111001100110011000001111100", "11001111100110011000001111100", _
                          "11111001111100110011000001100", "11001100111110011000001111100", "11111001100111110011000001100", "11001111100111110011000001100", _
                          "11001100110011111000001111100", "11111001100110011111000001100", "11001111100110011111000001100", "11001100111110011111000001100", _
                          "11111000001100110011001111100", "11000001111100110011001111100", "11111000001111100110011001100", "11000001100111110011001111100", _
                          "11111000001100111110011001100", "11000001111100111110011001100", _
                          "11000001100110011111001111100", "11111000001100110011111001100", "11000001111100110011111001100", "11000001100000110000011001100", _
                          "11000001100000110011000001100", "11000001100110000011000001100", "11001100000110000011000001100", "11000001100111110011111001100")

End Function

Public Function BarInit_NW7()

    '****************************************
    '                  NW7
    '****************************************
    t_BAR_Char = "0123456789-$:/.+ABCD"
    t_BAR_Pattern = Array("101010001110", _
                          "101011100010", _
                          "101000101110", _
                          "111000101010", _
                          "101110100010", _
                          "111010100010", _
                          "100010101110", _
                          "100010111010", _
                          "100011101010", _
                          "111010001010", _
                          "101000111010", _
                          "101110001010", _
                          "11101011101110", _
                          "11101110101110", _
                          "11101110111010", _
                          "10111011101110", _
                          "10111000100010", _
                          "10001000101110", _
                          "10100010001110", _
                          "10100011100010")

End Function

'
' PrintBarを使用してアクティブセルにバーコード図を貼り付け
'
Public Function Barcode_main(m_Kind, m_Check, m_StartChr, m_StopChr, m_CtrlChr, m_StartMode)

    start_col = ActiveCell.Column          'アクティブセルの列番号
    start_row = ActiveCell.Row             'アクティブセルの行番号
    start_adr = ActiveCell.Address         'アクティブセルのアドレス
    Start_Val = ActiveCell.Value           'アクティブセルの値
    Loop_Row = Selection.Rows.Count    'アクティブセル領域の行数を取得
    Loop_Col = Selection.Columns.Count '   　　　〃　　　　 列数　〃

    'm_Check = False
    'm_Kind = 1

    For Y = 0 To Loop_Row - 1: For X = 0 To Loop_Col - 1

        Cells(start_row + Y, start_col + X).Select
        Cell_value = Cells(start_row + Y, start_col + X)

        If Cell_value <> "" Then

            Cell_width = Selection.Width
            Cell_height = Selection.Height

            Bar_Return = PrintBar(Cell_value, Cell_height, Cell_width, m_Check, _
                                    m_Kind, m_StartChr, m_StopChr, m_CtrlChr, m_StartMode)

        End If

    Next: Next

    Range(start_adr).Select

End Function

'-------- 動作テスト用 --------
Sub Test1()

    ' 256x256 ピクセル
    ReDim myData(0 To 255, 0 To 255) As Long
    Dim X As Long, Y As Long

    ' グラデーションを描いてみる
    For Y = 0 To 255: For X = 0 To 255
        ' 実際はRGBではなくBGR
        myData(X, Y) = RGB(0, Y, X)
    Next: Next

    ' コピー＆ペースト
    If CopyDIBToClipBoard(myData) Then
        ActiveSheet.Paste
    End If

End Sub

＜使用 Excel：Excel2021、使用 OS：Windows11 ＞

＞開いてみたらエラーになり使えなくなっておりました
エラー名を書くのが常識でしょ。
コードは自分で作成したものだとして自分で解決したらどうですか。
「20年前の物です。」ならばOSやExcelのバージョンに合うように
見直したらどうですか。
そんなに長いコードを見るのもうんざりします。
（UYXL） 2025/02/27(木) 08:56:16

  Excel2021ならBarCode Controlが使用出来るのでは？
（はてな） 2025/02/27(木) 09:21:43

UYXLさんそんな答え方するのでしたらスルーすれば
いいのでは？
いちいち文句みたいな文面はやめてください。
自分で直せるならここに書き込まないですし、こんな答えを
望んでもいません
もともと無理を承知で聞いてるだけです。

はてな様回答ありがとうございます。
検索して参考にいたします。
（ごう） 2025/02/27(木) 11:21:40

BarCode Controlはバージョンによっては入ってない場合もあると思いますので、
もし入ってなくてJANコード対応のみでよかったら下記のマクロを使ったらどうでしょう。

2021年に公開されたものなので使えるのでは。

エクセルVBAでJANコードからバーコードをまとめて生成する #Excel - Qiita
https://qiita.com/chitomo12/items/69ef429891332187096a

「vba バーコード作成」をキーワードにググったら最初にでてきたものです。
（hatena） 2025/02/27(木) 11:41:53

 とりあえずAPI宣言の部分はVBA7以降の記述に従って変更

    '------------------------------------------------------------------------------
    'API宣言
    '------------------------------------------------------------------------------
    Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Const GMEM_DDESHARE = &H2000
    Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWndNewOwner As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long

 宣言でLongPtrに変わったところは、各プロシージャ内の宣言も合せてLongPtrに変更

    '------------------------------------------------------------------------------
    ' Long型2次元配列のビットマップをクリップボードにコピー
    '------------------------------------------------------------------------------
    Public Function CopyDIBToClipBoard(Data() As Long) As Boolean
        Dim bmih As BITMAPINFOHEADER
        Dim hMem        As LongPtr
        Dim lpBuf       As LongPtr
        Dim lngHeadSize As LongPtr
        Dim lngBitsSize As LongPtr
        Dim fSuccess    As Boolean
        ' BITMAPINFOHEADERのセット

 ただ、これでもまだハングしますね。

 ローカル変数の宣言をサボってる箇所が散見されます。
 API使う場合ってその辺シビアに扱わないといけないので、何か関係してるのかも知れません。
 (ざっと見では、それくらいしか言えないっす)

（白茶） 2025/02/27(木) 11:49:19

 白茶さん指摘の修正をしたあと実行すると、ActiveSheet.Pasteで落ちます。

 CopyDIBToClipBoard の最後の方

    ' メモリの解放
    If Not fSuccess Then GlobalFree hMem       '←元は出力不成功の時だけ解放。なぜだろう…
    ' GlobalFree hMem

 のように　出力不成功の時だけ解放　にすると、うまくいきました
（´・ω・`） 2025/02/27(木) 13:59:44

 Copilotに聞いてみました

 SetClipboardData関数を使用してクリップボードにデータを設定した場合、そのメモリの所有権はシステムに移ります。
 したがって、GlobalFree関数を使用してメモリを解放する必要はありません。
 もしGlobalFreeを呼び出してメモリを解放すると、システムがそのメモリを再度アクセスしようとしたときにエラーが
 発生する可能性があります。

 具体的には、SetClipboardData関数の公式ドキュメントによると、「SetClipboardDataが成功すると、システムはhMem
 パラメータで指定されたオブジェクトの所有権を持ちます。所有権がシステムに移った後、アプリケーションはデータ
 を書き込んだり解放したりすることはできません」と記載されています1。

 したがって、SetClipboardData関数を使用した後は、GlobalFree関数を呼び出さないようにしてください1。
（´・ω・`） 2025/02/27(木) 14:37:28

 私の環境では絵が貼り付きませんでした。(「×このイメージは現在表示できません。」が貼り付いてきます)

 で、改造案をひとつ。
 DIB使ってビットマップ作るのなら、SetDIBits使って組んだ方が若干スマートな感じがします。(これは単に好みの問題かも)
 グローバルメモリオブジェクトとかRtlMoveMemoryとか、使わないで済むのなら使わない方が無難(というか安全というか)です。

 >実際はRGBではなくBGR
 の部分何も考えてないし、ビットマップの後始末(DeleteObject)もしてない(するならペースト後にする必要あり)ですけど
 だいたい↓こんな感じでイケそうです。

 ▼API宣言に追加
    Rem *********************************************************************************
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Const CF_BITMAP = 2&
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
    End Type
    Private Const DIB_RGB_COLORS = 0&
    Private Declare PtrSafe Function SetDIBits Lib "gdi32" (ByVal hDC As LongPtr, ByVal hBITMAP As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
    Rem _________________________________________________________________________________

 ▼ビットマップをクリップボードにコピーする関数を追加
    Rem *********************************************************************************
    Private Function CopyBmptoClipboard(hBmp As LongPtr) As Boolean
        Call OpenClipboard(0&)
        Call EmptyClipboard
        CopyBmptoClipboard = CBool(SetClipboardData(CF_BITMAP, hBmp))
        Call CloseClipboard
    End Function
    Rem _________________________________________________________________________________

 ▼CopyDIBToClipBoard関数の中身を改造
    '------------------------------------------------------------------------------
    ' Long型2次元配列のビットマップをクリップボードにコピー
    '------------------------------------------------------------------------------
    Public Function CopyDIBToClipBoard(Data() As Long) As Boolean
        Dim bmih As BITMAPINFOHEADER
        Dim hMem        As LongPtr
        Dim lpBuf       As LongPtr
        Dim lngHeadSize As LongPtr
        Dim lngBitsSize As LongPtr
        Dim fSuccess    As Boolean
        ' BITMAPINFOHEADERのセット
        If Not FillHeader(Data, bmih) Then Exit Function
        With bmih
            lngHeadSize = .biSize
            lngBitsSize = 4 * .biWidth * Abs(.biHeight)
        End With
    Rem *********************************************************************************
    '    ' メモリの確保
    '    hMem = GlobalAlloc(GMEM_DDESHARE, lngHeadSize + lngBitsSize)
    '    If hMem = 0 Then Exit Function
    '    lpBuf = GlobalLock(hMem)
    '    If lpBuf = 0 Then
    '        GlobalFree hMem: Exit Function
    '    End If
    '    ' データのコピー
    '    MoveMemory ByVal lpBuf, bmih, lngHeadSize
    '    MoveMemory ByVal lpBuf + lngHeadSize, _
    '               Data(LBound(Data), LBound(Data, 2)), _
    '               lngBitsSize
    '    GlobalUnlock hMem
    '    ' クリップボードに出力
    '    If OpenClipboard(0) Then
    '        EmptyClipboard
    ''        If SetClipboardData(CF_DIB, hMem) Then
    '        If SetClipboardData(CF_BITMAP, hMem) Then
    '            fSuccess = True
    '        End If
    '        CloseClipboard
    '    End If
    '    ' メモリの解放
    ''    If Not fSuccess Then GlobalFree hMem       '←元は出力不成功の時だけ解放。なぜだろう…
    '    GlobalFree hMem
    '    CopyDIBToClipBoard = fSuccess
        Dim rtn As Long
        Dim bi As BITMAPINFO
        bi.bmiHeader = bmih
        Dim hDC As LongPtr, hBmp As LongPtr, hOld As LongPtr
        hDC = CreateCompatibleDC(0&)
        hBmp = CreateDIBSection(hDC, bi, DIB_RGB_COLORS, 0&, 0&, 0&)
        hOld = SelectObject(hDC, hBmp)
        rtn = SetDIBits(hDC, hBmp, 0&, Abs(bmih.biHeight), Data(LBound(Data), LBound(Data, 2)), bi, DIB_RGB_COLORS)
        Call SelectObject(hDC, hOld)
        Call DeleteDC(hDC)
        CopyDIBToClipBoard = CopyBmptoClipboard(hBmp)
    Rem _________________________________________________________________________________
    End Function

（白茶） 2025/02/27(木) 20:35:24

 話のついででもう一案。
 CopyDIBToClipBoard関数と同じ事をGDI+使って再現してみると...

 ▼API宣言に追加
    Rem *********************************************************************************
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(7) As Byte
    End Type
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    Private Enum ImageLockMode
        ImageLockModeRead = 1
        ImageLockModeWrite = 2
        ImageLockModeUserInputBuf = 4
    End Enum
    Private Type BITMAPDATA
        Width       As Long
        Height      As Long
        stride      As Long
        PixelFormat As Long
        scan0       As LongPtr
        Reserved    As LongPtr
    End Type
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, ByRef scan0 As Any, ByRef nBitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As Long
    Private Declare PtrSafe Function GdipBitmapLockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef RECT As Any, ByVal flags As Long, ByVal PixelFormat As Long, ByRef lockedBitmapData As Any) As Long
    Private Declare PtrSafe Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef lockedBitmapData As Any) As Long
    Private Enum PixelFormat
        PixelFormat32bppRGB = &H22009
        PixelFormat32bppARGB = &H26200A
    End Enum
    Private Declare PtrSafe Function GdipSaveImageToStream Lib "gdiplus" (ByVal Image As LongPtr, ByVal Stream As LongPtr, ByRef clsidEncoder As GUID, ByVal encoderParams As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, ByRef pCLSID As GUID) As Long
    Private Const CLSID_PNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
    Private Declare PtrSafe Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As LongPtr, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
    Private Declare PtrSafe Function GetHGlobalFromStream Lib "ole32" (ByVal Stream As IUnknown, ByRef hGlobal As LongPtr) As Long
    Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
    Rem _________________________________________________________________________________

 ▼関数を２つ追加
    Rem *********************************************************************************
    Private Function CreateFromBits(Bits() As Long, Optional ByVal PixelFormat As PixelFormat = PixelFormat32bppARGB) As LongPtr
        Dim pxWidth As Long, pxHeight As Long, hGpImg As LongPtr
        pxWidth = UBound(Bits, 1) - LBound(Bits, 1) + 1
        pxHeight = UBound(Bits, 2) - LBound(Bits, 2) + 1
        If GdipCreateBitmapFromScan0(pxWidth, pxHeight, 0, PixelFormat32bppARGB, ByVal 0, hGpImg) = 0 Then
            Dim BmpData As BITMAPDATA
            With BmpData
                .Width = pxWidth
                .Height = pxHeight
                .PixelFormat = PixelFormat32bppARGB
                .scan0 = VarPtr(Bits(LBound(Bits, 1), LBound(Bits, 2)))
                .stride = pxWidth * 4
            End With
            Call GdipBitmapLockBits(hGpImg, ByVal 0, ImageLockModeUserInputBuf Or ImageLockModeWrite, PixelFormat, BmpData)
            Call GdipBitmapUnlockBits(hGpImg, BmpData)
            CreateFromBits = hGpImg
        End If
    End Function
    Private Function CopyPngtoClipboard(hGpImg As LongPtr) As Boolean
        Call OpenClipboard(0&)
        Call EmptyClipboard
        Dim aStream As IUnknown, pngGUID As GUID
        Call CreateStreamOnHGlobal(0&, 0&, aStream)
        Call CLSIDFromString(StrPtr(CLSID_PNG), pngGUID)
        If GdipSaveImageToStream(hGpImg, ByVal ObjPtr(aStream), pngGUID, 0) = 0 Then
            Dim hGlobal As LongPtr, CF_PNG As Long
            Call GetHGlobalFromStream(aStream, hGlobal)
            If hGlobal Then
                CF_PNG = RegisterClipboardFormat("PNG")
                CopyPngtoClipboard = CBool(SetClipboardData(CF_PNG, hGlobal))
            End If
        End If
        Call CloseClipboard
    End Function
    Rem _________________________________________________________________________________

 ▼動作テスト用(Test2)
    Sub Test2()
        ' 256x256 ピクセル
        ReDim mydata(0 To 255, 0 To 255) As Long
        Dim X As Long, Y As Long
        ' グラデーションを描いてみる
        For Y = 0 To 255: For X = 0 To 255
            'COLORREF値 &H00BBGGRR = r * &H100 ^ 0 Or g * &H100 ^ 1 Or b * &H100 ^ 2 = RGB(r, g, b)
            'RGBQUAD値  &H00RRGGBB = r * &H100 ^ 2 Or g * &H100 ^ 1 Or b * &H100 ^ 0 ARGB値の構成順(&HAARRGGBB)と同じ
            mydata(X, Y) = X * &H100 ^ 2 Or Y * &H100 ^ 1 Or 0 * &H100 ^ 0
        Next: Next
        ' コピー＆ペースト
        Dim gi As GdiplusStartupInput, tkn As LongPtr, GpBmp As LongPtr
        gi.GdiplusVersion = 1&
        Call GdiplusStartup(tkn, gi)
        GpBmp = CreateFromBits(mydata, PixelFormat32bppRGB)
        If GpBmp Then
            If CopyPngtoClipboard(GpBmp) Then ActiveSheet.Paste
            Call GdipDisposeImage(GpBmp)
        End If
        If tkn Then Call GdiplusShutdown(tkn)
    End Sub

 ちなみに、
 GdipCreateHBITMAPFromBitmapでgdi32のビットマップに変換すれば、先述のCopyBmptoClipboardがそのまま使えるので、
 そうなるとCopyPngtoClipboardは用意しなくても再現可能です。(←アルファチャンネル維持したい場合なんかに使えます)

    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long

        If GpBmp Then
    '        If CopyPngtoClipboard(GpBmp) Then ActiveSheet.Paste
            Dim hBmp As LongPtr
            If GdipCreateHBITMAPFromBitmap(GpBmp, hBmp, 0&) = 0 Then
                If CopyBmptoClipboard(hBmp) Then ActiveSheet.Paste
                Call DeleteObject(hBmp)
            End If
            Call GdipDisposeImage(GpBmp)
        End If

（白茶） 2025/02/28(金) 23:47:36

コメント返信：

[ 一覧(最新更新順) ]

[[20250226230455]] 『バーコード作成ツール』（ごう） ページの最後に飛ぶ

[[20250226230455]]　『バーコード作成ツール』（ごう）　ページの最後に飛ぶ