セルをコピーして同じ場所に画像(PNG）として貼り付けたい

標準ではないフォントを使って表示したセルを画像化し貼り付けて
フォントがインストールされていない端末でも同様に表示させたいです。
ご教示の程よろしくお願い致します。

◆環境
Windows10
Microsoft Office Standard　2016　Excel
（16.0.5188.1000）

◆やってみた事
下記コードで実行すると画像化は出来たように見えますが、「フォントA」を
インストールしていない端末で開くと、他のフォントで表示されていました。

VBA
1Option Explicit
2Sub バーコード画像化()
3
4
5    Dim Rtn As String
6 
7    'フォントの確認
8    Rtn = MsgBox("バーコードは正常に表示されていますか？", vbYesNo, "確認")
9    '「はい」の場合
10    If Rtn = vbYes Then
11    'それ意外の場合案内をかけて動作を終了する
12    Else
13        MsgBox "「フォントA」をインストールしてください。" & vbCrLf & "詳しくは○○まで"
14        Exit Sub
15    End If
16
17
18
19
20'画像に灰色の線が残らない様に目盛線を非表示
21ActiveWindow.SheetViews("見本").DisplayGridlines = False
22ActiveWindow.SheetViews("短縮版").DisplayGridlines = False
23
24
25'見本
26  
27    With Worksheets("見本").Range("B18:O19")
28      .Borders(xlEdgeBottom).LineStyle = False  '下線消す
29      .Borders(xlEdgeLeft).LineStyle = False  '左線消す
30      .Borders(xlEdgeRight).LineStyle = False  '右線消す
31      .CopyPicture Appearance:=xlScreen, Format:=xlPicture  '図としてコピー
32      .PasteSpecial'貼付け
33      .ClearContents  '元の値を消す
34      .Borders.LineStyle = True  '()内省略で上下左右縦横中線が一括選択できるが隣接セルの被った枠線は操作しない
35      .Borders(xlEdgeTop).LineStyle = False  '上線消す
36      
37    End With
38
39
40'見本２
41
42    With Worksheets("見本").Range("B51:O52")
43      .Borders(xlEdgeBottom).LineStyle = False
44      .Borders(xlEdgeLeft).LineStyle = False
45      .Borders(xlEdgeRight).LineStyle = False
46      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
47      .PasteSpecial 
48      .ClearContents
49      .Borders.LineStyle = True
50      .Borders(xlEdgeTop).LineStyle = False
51      
52    End With
53
54
55'短縮版
56
57    With Worksheets("短縮版").Range("B13:O14")
58      .Borders(xlEdgeBottom).LineStyle = False
59      .Borders(xlEdgeLeft).LineStyle = False
60      .Borders(xlEdgeRight).LineStyle = False
61      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
62      .PasteSpecial
63      .ClearContents
64      .Borders.LineStyle = True
65      .Borders(xlEdgeTop).LineStyle = False
66      
67    End With
68    
69'目盛線を表示
70ActiveWindow.SheetViews("見本").DisplayGridlines = True
71ActiveWindow.SheetViews("短縮版").DisplayGridlines = True
72    
73End Sub

ネットで検索し.PasteSpecialの後ろに
Format:="図 (PNG)", Link:=False, DisplayAsIcon:=Falseを付けてみましたが
エラー1004が表示され貼付けできません。

VBA
1Option Explicit
2Sub バーコード画像化()
3
4
5    Dim Rtn As String
6 
7    'フォントの確認
8    Rtn = MsgBox("バーコードは正常に表示されていますか？", vbYesNo, "確認")
9    '「はい」の場合
10    If Rtn = vbYes Then
11    'それ意外の場合案内をかけて動作を終了する
12    Else
13        MsgBox "「フォントA」をインストールしてください。" & vbCrLf & "詳しくは○○まで"
14        Exit Sub
15    End If
16
17
18
19
20'画像に灰色の線が残らない様に目盛線を非表示
21ActiveWindow.SheetViews("見本").DisplayGridlines = False
22ActiveWindow.SheetViews("短縮版").DisplayGridlines = False
23
24
25'見本
26  
27    With Worksheets("見本").Range("B18:O19")
28      .Borders(xlEdgeBottom).LineStyle = False  '下線消す
29      .Borders(xlEdgeLeft).LineStyle = False  '左線消す
30      .Borders(xlEdgeRight).LineStyle = False  '右線消す
31      .CopyPicture Appearance:=xlScreen, Format:=xlPicture  '図としてコピー
32      .PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False '貼付け
33      .ClearContents  '元の値を消す
34      .Borders.LineStyle = True  '()内省略で上下左右縦横中線が一括選択できるが隣接セルの被った枠線は操作しない
35      .Borders(xlEdgeTop).LineStyle = False  '上線消す
36      
37    End With
38
39
40'見本２
41
42    With Worksheets("見本").Range("B51:O52")
43      .Borders(xlEdgeBottom).LineStyle = False
44      .Borders(xlEdgeLeft).LineStyle = False
45      .Borders(xlEdgeRight).LineStyle = False
46      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
47      .PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False
48      .ClearContents
49      .Borders.LineStyle = True
50      .Borders(xlEdgeTop).LineStyle = False
51      
52    End With
53
54
55'短縮版
56
57    With Worksheets("短縮版").Range("B13:O14")
58      .Borders(xlEdgeBottom).LineStyle = False
59      .Borders(xlEdgeLeft).LineStyle = False
60      .Borders(xlEdgeRight).LineStyle = False
61      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
62      .PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False
63      .ClearContents
64      .Borders.LineStyle = True
65      .Borders(xlEdgeTop).LineStyle = False
66      
67    End With
68    
69'目盛線を表示
70ActiveWindow.SheetViews("見本").DisplayGridlines = True
71ActiveWindow.SheetViews("短縮版").DisplayGridlines = True
72    
73End Sub
74

行動規範の内容に同意します

回答1件

ベストアンサー

以下、ご参考まで。

https://jizilog.com/vba-piccopy

投稿2021/08/30 07:17

hex309

総合スコア761

deppy

2021/09/01 01:10

hex309様ありがとうございます。リンク先のページ拝見し引数を削除した所エラーは回避できました。しかし、貼り付けした画像はフォント未インストール端末で開いた場合に他のフォントに置き換えられている状態は変わりませんでした。メタファイル形式での貼付けになっているのでは、と素人ながら推測しております。引き続き回答募集しております。宜しくお願い致します。

hex309

2021/09/01 01:20

CopyPictureメソッドの引数Formatの値を「xlBitmap」にしても同様でしょうか？

deppy

2021/09/01 07:05

hex309様ご指摘頂いたとおり .CopyPicture の Format を xlBitmap .PasteSpecial の引数を削除で実現できました。ありがとうございます。重ねての質問で申し訳ないのですが、同時に下記は可能でしょうか。（あらかじめ用意された枠付きのセルの中の値がそのまま画像に　なったように見せたいです。） ◆セルのサイズに合わせて貼付けする ◆背景を透過させるご迷惑でなければご教示頂きたく、お願い致します。

hex309

2021/09/01 07:40

こんにちは。質問内容が異なる場合は、あらたな質問としたほうが、回答が付きやすいかと思います。以下、ご参考まで。 Private Sub CopyPictureTest() Range("C3").CopyPicture Format:=xlBitmap ActiveSheet.Paste Range("C10") With ActiveSheet.Shapes(1) .LockAspectRatio = msoFalse .Width = Range("C10").Width .Height = Range("C10").Height With .PictureFormat .TransparentBackground = True .TransparencyColor = RGB(255, 255, 255) End With .Fill.Visible = False End With End Sub

deppy

2021/09/01 23:43

hex309様貼付けてから画像を選択しサイズと背景色を設定するのですね。また、異なる質問になる場合は新たな質問を立てた方がよい旨も承知致しました。次回よりそのように致します。この度はご教示頂きありがとうございました。大変助かりました。

行動規範の内容に同意します