2023年10月30日月曜日

シェイプをグループ化して、そのイメージでタックシールを印刷してみるアイデアに挑戦してみた ー ChartObjects(VBAマクロ)

          
以前、職場の中でVBAで印刷プログラムの作成を依頼されたことがありました。
出荷で梱包に宛先シールを貼り付けるのに、プログラムが必要になったらしい。

元々、汎用コンピュータのシステムで実装されていましたが、改善したいのか。
嘱託身分ゆえ、自由な時間を使ってコードを書いてみたくもなり、挑戦したの。

色々と面倒でしたが、一応動作した中でデモをすると印象は芳しくありません。
印刷するプリンターが古いせいか、印刷も品質が芳しくなく、なぜか沙汰止み。

なのでお蔵入りになりましたが、自分なりに反省点が無いわけでもありません。
先ず、A4サイズの用紙に、切込みが入った大型のシール(三枚)への印刷方法。

先ず、エクセルのシートをA4用紙に設定して印刷マージンを決めておきます。
次に、各シールは、十個以上のテキストボックス・シェイプを貼ることにした。

それからシール三枚とも同じ印刷データを流すので、シェイプ数が三倍になる。
各位置を決めるのにも時間が掛ったし、データを流し込むコードも結構手間だ。

しかも、コードの管理も大変で、シール一枚一枚の印刷位置調整にも一苦労ね。
一応、シェイプはグループ化で位置の調整を簡素化しましたが、それでも厄介。

結果、実際に起動させるとシェイプにデータ貼りつけの流れが、もっさりする。
これを解決するには、シェイプを集合化してイメージ画像に置き換えてみたい。

この画像を保存しておいて、ブックの別シートに三枚貼付けるのはどうかなあ。
そんなコードがあれば便利と、ネットでググってみましたら、何とありました。

サンプルコードを挙げておきますが、使っておけばよかったと今更ながら反省。
ただですね、シェイプグループからイメージコピー作成に、若干時間が必要だ。

このため、次のチャート領域に貼り付けるコードを遅延実行させる必要がある。
それが、”Application.OnTime”メソッドですが、一連の動きは意外とモッサリ。

というわけで、タックシールの印刷画像を作る処理コードは、一応、完成です。
一方、各テキストボックスでは、書体とそのサイズを指定するなど複雑で、QRコードを貼り込む作業もあって、そのような処理の多さが表示速度に影響していたのかもしれないのですが、今となっては、プログラムを見直す気すらない自分なのでした。

<サンプルコード> 
Sub GrouObjectMaking()
ThisWorkbook.Worksheets("Sheet1").Activate
  With ActiveSheet.Shapes
    If .Count >= 2 Then 'グループ化条件、シェイプが複数
       .SelectAll
          Selection.Group.Name = "Group"
      Else
          Exit Sub
    End If
  End With
With ActiveSheet.Shapes("Group")
  .CopyPicture 'ここでグループシェイプを画像コピー
  ActiveSheet.ChartObjects.Add(0, 0, .Width, .Height).Name = "Paste"
End With
    With ActiveSheet.ChartObjects("Paste") 'グラフを貼らない設定
      .Chart.PlotArea.Fill.Visible = msoFalse
        .Chart.ChartArea.Fill.Visible = msoFalse
          .Chart.ChartArea.Border.LineStyle = 0
    End With
      Application.OnTime Now + TimeValue("00:00:02"), "GroupPaste"
      '注:画像作成の所要時間を作って、チャートに画像貼り付けをコール
End Sub

Private Sub GroupPaste()
  With ActiveSheet.ChartObjects("Paste")
    .Chart.Paste 'グラフを貼り込む設定
    .Chart.Export ThisWorkbook.Path & "\SEAL.png" '画像のファイル保存
    .Delete 'チャートを消去
  End With
    ActiveSheet.Shapes("Group").Ungroup 'グループ解除
      ActiveSheet.Range("A1").Select
End Sub



いいねと思ったら、三つポチっとね!
にほんブログ村 スキースノボーブログへにほんブログ村 スキースノボーブログ スキーへにほんブログ村 旅行ブログ 旅日記・旅の思い出へ
にほんブログ村    にほんブログ村      にほんブログ村 



0 件のコメント:

コメントを投稿