InkPictureの枠内に描画したもの（サイン）を特定のセルに張り付けたい

VBAの質問です。

ユーザフォーム内にInkPictureの枠を設置します。
その枠内に描画されたものを、エクセルのシートのあるセルに張り付けるにはどの様なコードを書けばいいでしょうか。

ソースコード
Private Sub CommandButton1_Click()

Sheet1.Cells(1, 1).Value = InkPicture1.Picture

End Sub

補足情報（FW/ツールのバージョンなど）

office 365

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

回答1件

ベストアンサー

InkPictureを使うのは初めてだったので勉強がてらサンプルを書いてみました。

方法によって結果が異なったので、望む結果が得られているかはわかりませんが……

vba
1Sub SampleInkPicture()
2    
3    '出力先のシート
4    Dim ws As Excel.Worksheet
5    Set ws = Excel.ActiveSheet
6    
7    'MSINKAUTLib = Microsoft Tablet PC Type Library, version 1.0
8    Dim myInk As MSINKAUTLib.InkDisp
9    Set myInk = InkPicture1.Ink
10    
11'1. クリップボード経由で取得＆貼り付け
12    'クリップボード・シートのアクティブなセルなどに依存
13    
14    Call myInk.ClipboardCopy
15    Call VBA.DoEvents '実行しないと、コピーが完了しない
16    ws.PasteSpecial '手動貼り付けの「図」に近いがちょっと違う？
17    
18    
19'2. 画像出力して貼り付け
20    
21    '画像一時保存先
22    Dim tmpSavePath As String
23    tmpSavePath = VBA.Environ$("tmp") & "\tmp.gif"
24    
25    'すでにファイルがあれば消しておく
26    If VBA.Dir(tmpSavePath) <> vbNullString Then
27        VBA.Kill tmpSavePath
28    End If
29    
30    'Gifのバイナリに変換
31    Dim gifData() As Byte
32    gifData = myInk.Save(IPF_GIF)
33    
34    
35    'VBAのファイル操作でバイナリ出力
36    Dim fNo As Integer
37    fNo = VBA.FreeFile()
38    
39    Open tmpSavePath For Binary As #fNo
40        
41        Dim i As Long
42        For i = LBound(gifData) To UBound(gifData)
43            
44            Put fNo, , gifData(i)
45            
46        Next i
47        
48    Close #fNo
49    
50    
51    'ワークシートの左上に、元々の大きさで画像挿入
52    Dim gifShape As Excel.Shape
53    Set gifShape = ws.Shapes.AddPicture( _
54            tmpSavePath, _
55            msoFalse, _
56            msoTrue, _
57            0, _
58            0, _
59            -1, _
60            -1)
61    
62    '結果確認用に選択
63    ws.Activate
64    gifShape.Select
65    
66    '結果確認用に、保存したファイルのフォルダを開く
67    Call VBA.Shell("explorer /select,""" & tmpSavePath & """", vbNormalFocus)
68    
69    
70    Stop '変数確認用（ブレークポイント）
71    
72End Sub