Excel-VBAによるバーコード生成プログラム-No.4

こんにちは、Ryoです。

さて、今回はNo.3に続き、code39フォントに置換し画像化した
バーコードをラベル様式に反映する「c.印刷様式への貼付け」と
「d.処理中の画像等クリア」について解説していきます。

ちなみに記事のNo.1はここから、No.2はこちらから、No.3はこの辺りから行けます。

1.Excel画面

【印刷ボタン】を画像の下に設置し、これから作成するコードを登録します。

別Sheetの名前をここでは「ラベル印刷用」として作っています。
セル幅等は以下の通りです。

• 列幅：24.13
• 行の高さ：79.25
• 余白上、下：0.9
• 余白右、左：0.8
• 用紙サイズ：A4

ラベルシールはスリーエムジャパン株式会社（A-one)品番28388　44面　一片サイズ48.3*25.4mm　レーザープリンタ用を使用しています。

2.コード全体

c.印刷様式への貼付け

Sub Label_print()
'//画像化したバーコードを印刷用ラベルシートへ反映する//
    Dim strName(50) As Variant
    Dim Bn As Variant
    Dim Ct,b,e,nm As Integer
    Dim T,L As Double
 
    Range(Cells(13, 2), Cells(13, 4)).ClearContents
    Application.ScreenUpdating = False
    Ct = 0

    '//バーコード生成画面で作成した画像情報の取得とコピー実行//
    For b = 1 To ActiveSheet.Shapes.Count
          strName(b) = ActiveSheet.Shapes(b).Name
             If InStr(strName(b), "Picture") = 1 _
             Or InStr(strName(b), "図") = 1 Then
                  ActiveSheet.Shapes(strName(b)).Copy
                  Bn = strName(b)
                  Ct = Ct + 1
             End If
    Next b
    
    If Ct <> 1 Then
        MsgBox "バーコード画像が生成されていません", vbCritical
        Exit Sub
    End If
    
    Call Clear_bc
    Application.ScreenUpdating = False
   
    Erase strName
    Worksheets("ラベル印刷用").Activate
    
    '//初期に残データや画像をすべて除去する//
    Call Picture_Del
    Range("A1").Select
  
    L = 0  '//貼り付け位置（Left）補正用//
    nm = 100  '//貼り付け画像のリネーム管理用//
  
    For e = 1 To 4 '//ラベル4列//
        For i = 1 To 11  '//ラベル11行//
           Ct = Ct + 1
           ActiveSheet.Paste
           Bn = Selection.Name
             '//貼り付けた画像はSelect状態にあり、画像名を取得//
             With ActiveSheet.Shapes(Bn)
               '//取得した画像名をReNameする（Copy画像は全てName同一の為)//
               .Name = "Picture" & nm + Ct
             End With
              '//ReNameした画像を指定する//
              With ActiveSheet.Shapes("Picture" & nm + Ct)
               '//貼り付け位置をラベル印字部に合わせてシフトする//
               .Top = T + 13.5
               .Left = L + 13.75
              End With
            T = T + 78.8
          Next i
      '//Topは列完了後に初期位置に戻る//
      T = 0
      L = L + 148
    Next e
 
  Cells(1,1).select
  Application.ScreenUpdating = True
    
End Sub

d.処理中の画像等クリア

◆メイン画面側の文字データ、画像クリア

Sub Clear_bc()
'//バーコード生成実行時の画面クリア用//

  Dim strName(10) As Variant

  Application.ScreenUpdating = False

     For i = 1 To ActiveSheet.Shapes.Count
            strName(i) = ActiveSheet.Shapes(i).Name
               If InStr(strName(i), "Picture") = 1 _
               Or InStr(strName(i), "図") = 1 Then
                  ActiveSheet.Shapes(strName(i)).Delete
               End If
      Next i
    
    Range(Cells(23, 3), Cells(25, 3)).ClearContents
    Application.ScreenUpdating = True

End Sub

◆ラベル様式側の旧画像クリア

Sub Picture_Del()
'//ActiveSheet内のPicture画像をすべて削除する//
  Dim Shp As Shape
  
  For Each Shp In ActiveSheet.Shapes
    If Shp.Type = msoPicture Then Shp.Delete
  Next Shp
  
End Sub

では、各コードについて解説していきます。

3.コード解説

ここでは画像化したバーコードを印刷用ラベルシート様式へ貼付ける処理を行います。

先ず生成された文字情報をクリアして画面を固定化し、バーコード画像の情報
(名前）取得とコピーを行います。

　  Range(Cells(13, 2), Cells(13, 4)).ClearContents

    Application.ScreenUpdating = False

    Ct = 0

    For b = 1 To ActiveSheet.Shapes.Count

          strName(b) = ActiveSheet.Shapes(b).Name

             If InStr(strName(b), "Picture") = 1 _
             Or InStr(strName(b), "図") = 1 Then

                  ActiveSheet.Shapes(strName(b)).Copy

                  Bn = strName(b)

                  Ct = Ct + 1

             End If

    Next b

念の為、処理実行時にバーコード画像が生成されていなければ警告を表示します。

　　If Ct <> 1 Then
    
　　    MsgBox "バーコード画像が生成されていません", vbCritical
    
　　    Exit Sub
    
　　End If

元のバーコード画像を削除し、画面固定化と配列に格納したデータをクリアし
「ラベル印刷用」のワークシートに切り替えます。

　　 Call Clear_bc
    
　　 Application.ScreenUpdating = False
   
     Erase strName
    
     Worksheets("ラベル印刷用").Activate

ここからラベル様式に合わせた位置に画像の貼付けを行っていきます。
先ずSheet内に残された画像を削除し、初期位置を選択します。

　　 Call Picture_Del
     
　　 Cells(1,1).Select

貼付け位置と画像のリネーム用変数を指定します。
Lは貼り付け位置（Left)の補正用、nmは画像リネーム管理用です。

　　 L = 0  

　   nm = 100  

今回使用するラベルは4列×11行となっていますので、位置をシフトしながら
貼付けを行っていきます。
必要回数の繰り返し処理と開始位置に画像を貼付けて、名前情報を取得します。

　　 For e = 1 To 4 '//ラベル4列//

        For i = 1 To 11  '//ラベル11行//

           Ct = Ct + 1

           ActiveSheet.Paste

           Bn = Selection.Name

貼付けの処理を行った画像は選択された状態になっていますので、取得した
画像名に対しリネームを行います。

　　　 With ActiveSheet.Shapes(Bn)
        
               .Name = "Picture" & nm + Ct
        
　　     End With

リネームした画像を改めて指定し印字部に合わせて位置調整を行います

リネーム理由ですが、最初に生成したにバーコード画像を元にして
コピーし貼付けていきますので、画像名が貼付け処理する度に
「同じ名前」となることから処理上変更する必要がある為です。

初期位置に貼付けた画像を.Topと.Leftで位置を指定します。
その後、次の行（この場合+78.8）位置をシフトし11行分繰り返します。

　　　　　With ActiveSheet.Shapes("Picture" & nm + Ct)
        
    　         .Top = T + 13.5
        
　　　　       .Left = L + 13.75
      
　        End With

            T = T + 78.8

     　 Next i

1列分11行の貼付けが完了したら、Top位置を0とし、Left位置をシフト
（この場合+148）し、次行の処理を開始するという繰り返し処理になります。

     
      T = 0
     
　　　L = L + 148
   
　 Next e

貼付け処理完了後、画面固定化解除を行って処理終了となります。

　Range("A1").Select

  Application.ScreenUpdating = True
    
End Sub　　

ここまでの処理を「印刷ラベル反映」ボタンに登録してありますので、
押すと様式に4×11枚分のバーコード画像が貼り付けられます。

次にクリア処理部分について解説します。

バーコード生成～ラベル様式貼付けまでのコード内で見かける
Call Clear_bcとCall Picture_Delについて簡単にご説明します。

当処理はそれぞれのコード内で実行すれば済むのですが、実行したい箇所で
何度も同じコードを記述するのは手間ですし、修正があると面倒なことに
なりますので、単純動作で完結する処理は分けた方が後々楽になります。

先ずClear_bcの目的は、バーコード生成する際に以前のデータが残っていると
間違いやすいことと紛らわしい為、必要なくなった情報を消しています。

Sub Clear_bc()

    Dim strName(10) As Variant

    Application.ScreenUpdating = False

     For i = 1 To ActiveSheet.Shapes.Count

            strName(i) = ActiveSheet.Shapes(i).Name

               If InStr(strName(i), "Picture") = 1 _
               Or InStr(strName(i), "図") = 1 Then

                  ActiveSheet.Shapes(strName(i)).Delete

               End If
      Next i
    
    Range(Cells(23, 3), Cells(25, 3)).ClearContents

    Application.ScreenUpdating = True

End Sub

次にPicture_Delですが、ラベル様式側に以前生成した画像が残っていると
手動で消去する手間があったり、そのまま実行すると画像に画像が重なって
いきますので、いつしか異常に重いファイルになったりします。

その為、印刷ラベル反映処理実行時に対象シートに存在するpictureファイル
全てを抽出して削除を実行するものです。

この処理を単独で完結しておくと「画像消去」等のボタンを作って登録すれば
手動で全てクリアすることも出来ます。

Sub Picture_Del()

  Dim Shp As Shape
  
  For Each Shp In ActiveSheet.Shapes

    If Shp.Type = msoPicture Then Shp.Delete

  Next Shp
  
End Sub

以上になります。




取り扱う製品やバーコード化したい目的によって形や表示は様々なので、
ピンポイントでニーズにマッチするものではないと思いますが、ご検討の
一助や何かのお役に立てれば幸いです。

Ryo