Excel2013VBAでフリーソフト「職印くん32」を作成しシートに貼り付けたい

いつもお世話になっております。
Excel2013VBAで、フリーソフトの「職印くん32」を起動して、日付入力、名前入力して、シートに貼り付けたいと思っています。
現状、起動は出来ます。日付は本日の日付にすることもできます。（SendKeys "%t", True）
プログラム上に直接日付を入れると指定した日にすることはできました。
名前の入力は、アルファベッドやひらがななどの入力はできました。SendKeys でスペースキーを押して漢字変換確定はエラーでできませんでした。
最後に職員くんの画像をコピーしてクリップボード上に保存することはできましたが、貼り付けは出来ませんでした。（SendKeys "^v", True）

やりたいのは、名前の入力をInputBoxでできたらよいと思っています。(日付もできたらなおよい)
そして、最後にシートに貼り付けたいのですが、SendKeys "^v", True　を実行しても貼り付けしてくれません。クリップボードには保存されているので、手動でctrl+Vを実施すると貼り付けることができます。
この件でご教授いただけないでしょうか？よろしくお願いいたします。

Sub test()
Dim ws As Worksheet
Dim rc As Long
Dim strInput As String

Set ws = ThisWorkbook.ActiveSheet

rc = Shell("C:\Program Files\Hashi's Tools\職印くん32\Shokuin.exe", vbNormalFocus)
If rc = 0 Then MsgBox "起動に失敗しました"
'本日の日付を入力
SendKeys "%t", True
'指定の日付を入力2020 3 6
SendKeys "%d", True
SendKeys "2020", True
SendKeys "{TAB}", True
SendKeys "3", True
SendKeys "{TAB}", True
SendKeys "6", True

If IMEStatus = vbIMEModeOff Then SendKeys "{kanji}"
'strInput = InputBox("氏名を入力してください。") '氏名を入力する

AppActivate "職印くん32", True
SendKeys "%n", True
SendKeys "tanaka", True
'SendKeys "{SPACE}", True 'エラーになる　名前を変換
'SendKeys "{ENTER}", True '変換確定

SendKeys "^c", True 'クリップボード内へはコピーできている
ws.Range("dc16").Select
SendKeys "^v", True '貼りつかない(ここで手動でctrl+Vを実行すると貼りつく)

End Sub

質問者からの補足コメント

• なかなかうまくいかないです。
  とりあえず、教えて頂いた所のxlClipboardFormatBitmap 　は、xlClipboardFormatPICT　にすることで動きました。
  ただし、動くときは、If Application.ClipboardFormats(i) =　～ActiveSheet.Paste辺りをブレークポイントを設定したり、ステップ送りで動かした時にしか貼り付けてくれませんでした。
  
  最小限のプログラムにして、実行するとクリップボード格納までは動きますが、貼り付けられず終了です。何度も実行すると実行時エラー1004でWorksheetクラスのPasteメソッドが失敗しました、表示が出て、デバックを押すと、 ActiveSheet.Pasteの所でストップがかかっています。そのまま継続すると、動作を再開し貼りつけてくれます。

  No.2の回答に寄せられた補足コメントです。 補足日時：2020/03/11 12:38

• 回答ありがとうございます。
  まだ途中までしか作っていないのですが、あれからタイマとフォームを利用することで、できそうな感じになっています。
  今回のを64ビットPCで試してみようとしましたが、Sub の前の所が赤字でコンパイルエラーになり、これはDeclareをDeclare PtrSafeに置き換えることで解決しましたが、hwndの取得に失敗しました、というエラーが発生して動きませんでした。
  どう修正すればよろしいでしょうか？

    補足日時：2020/03/14 02:22

• 補足ありがとうございます。LongPtrに置き換えたりこの度提示していただいたのと差し替えたりしましたが、エラーがでてうまく動きませんでした。おそらく、64ビット絡みの宣言に問題があるのだと思います。
  'Officeが64bitの場合、下記も必要か、の所も追加するとエラーがでてしまいました。
  この度、解決することができました。sleepをいれることでクリップボードから貼り付けできました。
  別補足にも記載しましたが、貼付け前よりクリップボードの型確認の所に入れる方が効果がありました。
  また、思い通りに動くものがとりあえず出来上がり解決しました。やり方は、フォーム起動時に職印くんを呼び出し、設定は職印くん上で行い、フォームの実行ボタンを押すと、フォーム上にチェックを入れたシート全てに貼り付けていくというものです。

  No.6の回答に寄せられた補足コメントです。 補足日時：2020/03/14 21:50

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2020/03/09 01:41

職印くん32は、皆目見当が付きませんが、Paste部分だけ、、

>SendKeys "^c", True 'クリップボード内へはコピーできている
なら、VBAで
Dim i As Long
　　For i = 1 To UBound(Application.ClipboardFormats)
　　　　If Application.ClipboardFormats(i) = xlClipboardFormatBitmap Then
　　　　　　Range("dc16").Select
　　　　　　ActiveSheet.Paste
　　　　　　Exit For
　　　　End If
　　Next i
では、どうでしょう？

この回答へのお礼

ありがとうございました。

お礼日時：2020/03/15 13:26

No.7 回答者： taisuke555 回答日時： 2020/03/15 13:12

#3,5です。

64bit版のOfficeは頭にありませんでした。
32bit版なら64bitOSでもうまくいったので、
投稿してしまいました。
64bit版Officeの環境がないので、下手にアドバイスできません。
申し訳ありません。

この回答へのお礼

この度はありがとうございました。
せっかくの投稿を活かすことができず申し訳なかったです。

一応動作的には完成し、今回の投稿は完結しました。

お礼日時：2020/03/15 13:24

No.6 回答者： Qchan1962 回答日時： 2020/03/14 10:54

＃２，４です。

>PtrSafeに置き換えることで解決しましたが、hwndの取得に失敗しました、
おそらく、64bitの場合　As Long は、As LongPtr　になります。

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

32bitと64bitに対応する為、分けて呼び出す。

#If VBA7 And Win64 Then
Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lparam As LongPtr) As Long
#Else
Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
#End If

'Officeが64bitの場合、下記も必要か、、
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#If VBA7 Then　
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

'--------------------
64bit Declare PtrSafe　　 As LongPtr
32bit Declare　　　　　　As Long

参考まで

No.5 回答者： taisuke555 回答日時： 2020/03/13 11:22

#3です。

#2さんへの補足部分でコピーしてから貼り付けの間にsleep等で
少し待ったらどうなります？

一応以下で貼り付けれたけど、どうでしょう？
職印くん32がアクティブになっていなくても大丈夫だと思います。

細かいエラー処理はしてないですし、
この方法が正しいかわかりません。（とりあえず動いただけです）
日付等はInputbox等でアレンジしてください。
うまくいかなかったら、ごめんなさい。

Private Const WM_SETTEXT = &HC
Private Const WM_COMMAND = &H111

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Test()
　　Dim rc　　　　As Long
　　Dim cnt　　　 As Long
　　Dim hInputBox As Long
　　Dim hWindow1　As Long
　　Dim hWindow2　As Long
　　
　　Dim CB As Variant, i As Long
　　
　　'職印くん32起動
　　rc = Shell("C:\Program Files\Hashi's Tools\職印くん32\Shokuin.exe", vbNormalFocus)
　　If rc = 0 Then MsgBox "起動に失敗しました"
　　
　　'hwnd取得
　　Do
　　　　hWindow1 = FindWindow("#32770", "職印くん32 [標準職印]")
　　　　If (hWindow1 <> 0) Then
　　　　　　Exit Do
　　　　Else
　　　　　　cnt = cnt + 1
　　　　　　If (cnt > 3) Then
　　　　　　　　MsgBox "hwndの取得に失敗しました"
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　Sleep 100
　　　　End If
　　Loop
　　hWindow2 = FindWindowEx(hWindow1, 0&, "#32770", "基本設定")

　　'各項目に入力
　　hInputBox = FindWindowEx(hWindow2, 0&, "Edit", "")　 '年
　　Call SendMessage(hInputBox, WM_SETTEXT, 0, ByVal "2021")
　　hInputBox = FindWindowEx(hWindow2, hInputBox, "Edit", "") '月
　　Call SendMessage(hInputBox, WM_SETTEXT, 0, ByVal "11")
　　hInputBox = FindWindowEx(hWindow2, hInputBox, "Edit", "") '日
　　Call SendMessage(hInputBox, WM_SETTEXT, 0, ByVal "15")
　　
　　hInputBox = FindWindowEx(hWindow2, hInputBox, "RichEdit20W", "") '部署
　　Call SendMessage(hInputBox, WM_SETTEXT, 0, ByVal "てすと")
　　hInputBox = FindWindowEx(hWindow2, hInputBox, "RichEdit20W", "") '氏名
　　Call SendMessage(hInputBox, WM_SETTEXT, 0, ByVal "テスト")
　　
　　Call SendMessage(hWindow1, WM_COMMAND, 32768, 0)　 'コピー
　　
　　CB = Application.ClipboardFormats　　　　　　　　　'クリップボード確認
　　If CB(1) = True Then
　　　　MsgBox "クリップボードは空です。", 48
　　　　Exit Sub
　　End If
　　For i = 1 To UBound(CB)
　　　　If CB(i) = 2 Then　　　　　　　　　　　　　　　'画像ならばペースト
　　　　　　ActiveSheet.Range("dc16").Select
　　　　　　ActiveSheet.Paste
　　　　　　Exit For
　　　　End If
　　Next i
End Sub

No.4 回答者： Qchan1962 回答日時： 2020/03/11 15:08

＃２です。

FormatPICTなのですね。実験して頂き、申し訳ありません。
多分AppActivate "職印くん32"を破棄した後、Excelに戻ってから実行すれば、、出来そうな気もしますが、、
何分環境が作れないので、当てずぽうで、、すみません。

回答とは離れるかもしれませんが、印鑑などを押す時、
私は、RelaxTools Addinを使っています。
他のアドインなどは使う事はないのですが、ソースがオープンなので不精な私は気に入ってます。
https://software.opensquare.net/relaxtools/

参考まで

この回答へのお礼

冒頭にAPI宣言をして、

#If VBA7 Then '###（64bit）
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else '###（32bit）
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
' Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

この下にタイマを入れることで、確認した中では100%貼り付け可能になりました。

For i = 1 To UBound(Application.ClipboardFormats)
DoEvents
Sleep (1000) '1秒
DoEvents

↓こちらの前も試しましたが、上の方が動作的に安定しました。
ActiveSheet.Paste

お礼日時：2020/03/14 21:28

No.3 回答者： taisuke555 回答日時： 2020/03/11 13:18

職印くん32を利用しないといけないのでしょうか？

このソフトをよく知らないので、メリットがあるのかもしれませんが、
EXCELで図形を描いた方が早くないですか？

以下適当に作ってみました。

Sub Macro1()
　　Dim ovl　As Object
　　Dim ln1　As Object
　　Dim ln2　As Object
　　
　　Dim tx1　As Object
　　Dim tx2　As Object
　　Dim tx3　As Object
　　
　　Set ovl = ActiveSheet.Shapes.AddShape(msoShapeOval, 205.5, 61.5, 42.75, 42.75)
　　With ovl.DrawingObject.ShapeRange
　　　　.Fill.Visible = msoFalse
　　　　.Line.Visible = msoTrue
　　　　.Line.Weight = 1#
　　End With
　　
　　Set ln1 = ActiveSheet.Shapes.AddLine(207, 77.25, 247, 77.25)
　　ln1.DrawingObject.ShapeRange.Line.Visible = msoTrue
　　
　　Set ln2 = ActiveSheet.Shapes.AddLine(207, 89.25, 247, 89.25)
　　ln2.DrawingObject.ShapeRange.Line.Visible = msoTrue
　　
　　Set tx1 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 214, 64, 27, 12)
　　tx1.DrawingObject.Characters.Text = "部署"
　　
　　Set tx2 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 208, 77, 39, 12)
　　tx2.DrawingObject.Characters.Text = "2. 3. 4"
　　
　　Set tx3 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 214, 90, 27, 12)
　　tx3.DrawingObject.Characters.Text = "職印"
　　　　
　　ActiveSheet.Shapes.Range(Array(tx1.Name, tx2.Name, tx3.Name)).Select
　　With Selection
　　　　With .Font
　　　　　　.Name = "ＭＳ Ｐ明朝"
　　　　　　.Size = 10
　　　　End With
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　　　With .ShapeRange
　　　　　　.Fill.Visible = msoFalse
　　　　　　.Line.Visible = msoFalse
　　　　End With
　　End With
　　
　　ActiveSheet.Shapes.Range(Array(ovl.Name, ln1.Name, ln2.Name, tx1.Name, tx2.Name, tx3.Name)).Select
　　Selection.ShapeRange.Group.Select
End Sub

後は、部署、日付、名前の部分をInputBoxなりでアレンジするようなのではだめですか？
職印くん32を利用しないといけないようでしたらごめんなさい。

この回答へのお礼

ありがとうございました。
これも、綺麗に動きよいかと思いました。
機会があれば活用したいと思います。

お礼日時：2020/03/14 21:29

No.1 回答者： めぐみん_ 回答日時： 2020/03/06 13:10

SendKeys は全くやった事のない知識もない者ですが。

＞ws.Range("dc16").Select

・BookをAppActivate等でまずアクティブにする
・ws.Range("dc16").Select　にてセルを選び
・SendKeys "^v", True にて貼り付けに挑戦

ってのはダメですかね？
ダメであれば私には無理な話ですけどね。
あくまで憶測でしかないので。

この回答へのお礼

回答ありがとうございました。残念ながらダメでした。

お礼日時：2020/03/08 16:48