プロが教えるわが家の防犯対策術!

いつもお世話になっております。
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

A 回答 (7件)

職印くん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
では、どうでしょう?
この回答への補足あり
    • good
    • 0
この回答へのお礼

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

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

#3,5です。


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

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

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

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

#2,4です。


>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

参考まで
この回答への補足あり
    • good
    • 0

#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
    • good
    • 0

#2です。


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

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

参考まで
    • good
    • 0
この回答へのお礼

冒頭に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

職印くん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 = "MS P明朝"
      .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を利用しないといけないようでしたらごめんなさい。
    • good
    • 0
この回答へのお礼

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

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

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



>ws.Range("dc16").Select

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

ってのはダメですかね?
ダメであれば私には無理な話ですけどね。
あくまで憶測でしかないので。
    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング