Excel VBAで他アプリへのテキストデータ貼り付け

質問

お世話になります

Excel VBAで任意のデータを１アクション（現状ではユーザーフォーム上でコマンドボタンをワンクリック）で他アプリケーション（Excelの次にアクティブな状態）のテキストボックスにテキストを貼り付けたいと思っています。

どなたか妙案のある方お願いします

回答No.5

mitarashi

#1です。いい加減にしろと、お叱りを受けそうですが、別の方法をWEBでみつけました。元は他のアプリをスクロールするコードなのですが、アレンジしてみました。このコードだと、複数起動したメモ帳に、ワンクリックで貼り付けられます。マウス動作をフックするため、左クリックでUserFormが閉じられませんので、ALT+F4で閉じて、テキスト貼り付けを終了してください。なお、貼り付けエラーを検出しようとしてうまくいっていません。
☆UserForm1のコード
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "USER32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10
Private Const GWL_HINSTANCE = (-6)

Private Sub UserForm_Initialize()
Dim i As Integer
Dim hWnd As Long
Dim hInst As Long

Me.Caption = "myForm"
hWnd = FindWindow(vbNullString, Me.Caption)
hInst = GetWindowLong(hWnd, GWL_HINSTANCE)
hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, hInst, 0)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookWindowsHookEx hHook
End Sub
☆Module1のコード
Public Declare Function SetWindowsHookEx Lib "USER32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "USER32" (ByVal hHook As Long) As Long
Public Declare Function CallNextHookEx Lib "USER32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function WindowFromPoint Lib "USER32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
Private Declare Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long

Public Const HC_ACTION = 0
Public Const WH_MOUSE_LL = 14
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_SETTEXT As Long = &HC

Public Type MSLLHOOKSTRUCT
X As Long
Y As Long
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type

Public Type POINTAPI
X As Long
Y As Long
End Type

Public hHook As Long

Sub test()
UserForm1.Show
End Sub

Public Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim m As MSLLHOOKSTRUCT
Dim pt As POINTAPI
Dim hWnd As Long
Dim classname As String * 255
Dim wname As String
Dim myText As String
Dim lngRet As Long

If nCode = HC_ACTION Then
Select Case wParam
Case WM_LBUTTONDOWN
myText = ActiveCell.Text
GetCursorPos pt
hWnd = WindowFromPoint(pt.X, pt.Y)
Call GetClassName(hWnd, classname, Len(classname))
wname = Left(classname, InStr(classname, Chr(0)) - 1)
' Debug.Print wname
Select Case wname
Case "Edit"
lngRet = SendMessage(hWnd, WM_SETTEXT, 0, ByVal myText)
ActiveCell.Offset(1, 0).Activate
End Select
LowLevelMouseProc = 1
Exit Function
End Select
End If
LowLevelMouseProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function

参考URL：

http://soudan1.biglobe.ne.jp/qa2912840.html

回答No.4

mitarashi

#1,#3です。もう誰も見ていないと思いますが、「自アプリケーション外のマウスのイベントを拾える様にするAPI」を、VBAで使う方法を模索していて、以前断念した、VBAからCreateWindowを使う方法を再度調べてみると、みつけてしまいました。これで、真っ当な？Windowが作れますので、上記APIが使えます。
下記コードの使い方は、貼り付けたいデータ列の最初のセルをアクティブにし、mainを実行すると、ウィンドウが表示されます。click hereと表示されたらそのボタンをクリックし、click controlと表示されたら、貼り付け先のコントロールをクリックします。メモ帳を沢山表示させておいて実行したら動作しました。メモ帳→エクセルをアクティブにするのがうまくいかないので、都度ボタンをクリックするという２アクションになってしまいます。Windowを消さずにVBAを終了させるとフリーズする等、色々と不安定なところがあり、趣味の世界です。VBAでWin32プログラミングもおつではないでしょうか。
Private Type WNDCLASSEX
cbSize As Long
style As Long
lpfnWndProc As Long
cbClsExtra As Long
cbWndExtra As Long
hInstance As Long
hIcon As Long
hCursor As Long
hbrBackground As Long
lpszMenuName As String
lpszClassName As String
hIconSm As Long
End Type

Private Type POINTAPI
x As Long
y As Long
End Type

Private Type MSG
hWnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As Long) As Long
Private Declare Function LoadIcon Lib "USER32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Long) As Long
Private Declare Function LoadCursor Lib "USER32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal fnObject As Long) As Long
Private Declare Function RegisterClassEx Lib "USER32" Alias "RegisterClassExA" (lpwcx As WNDCLASSEX) As Long
Private Declare Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function ShowWindow Lib "USER32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function UpdateWindow Lib "USER32" (ByVal lhwnd As Long) As Long
Private Declare Function GetMessage Lib "USER32" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "USER32" (lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "USER32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private Declare Sub PostQuitMessage Lib "USER32" (ByVal nExitCode As Long)
Private Declare Function DefWindowProc Lib "USER32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetCapture Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function WindowFromPoint Lib "user32.dll" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
Private Declare Function DestroyWindow Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowText Lib "USER32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long

Private Const CS_VREDRAW As Long = &H1
Private Const CS_HREDRAW As Long = &H2
Private Const IDI_APPLICATION As Long = 32512
Private Const IDC_ARROW As Long = 32512
Private Const WHITE_BRUSH As Long = 0
Private Const WS_OVERLAPPED As Long = &H0
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000

Private Const WS_MINIMIZE As Long = &H20000000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_EX_APPWINDOW As Long = &H40000
Private Const WS_OVERLAPPEDWINDOW As Long = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_ARRANGEDWINDOW As Long = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_MINIMIZE)
Private Const CW_USEDEFAULT As Long = &H80000000
Private Const SW_SHOW As Long = 5
Private Const WM_DESTROY As Long = &H2
Private Const WM_TIMER As Long = &H113
Private Const WM_CLOSE As Long = &H10
Private Const WM_PASTE As Long = &H302
Private Const WM_CLEAR As Long = &H303
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_COMMAND As Long = &H111
Private Const WM_PAINT As Long = &HF

Private Const SW_RESTORE As Long = 9
Private Const IDM_BUTTON1 = &H100
Private Const BS_PUSHLIKE As Long = &H1000
Private Const EM_SETSEL = &HB1

Private Const APP_NAME As String = "PASTEAPP"
Private Const APP_TITLE As String = "Paste Text"

Public hWnd As Long
Public hWndButton As Long

Private Sub Auto_Close()
Call DestroyWindow(hWnd)
End Sub

Public Sub Main()
Dim wc As WNDCLASSEX
Dim message As MSG

wc.cbSize = Len(wc)
wc.style = CS_HREDRAW Or CS_VREDRAW
wc.lpfnWndProc = FPtr(AddressOf WindowProc)
wc.cbClsExtra = 0
wc.cbWndExtra = 0
wc.hInstance = GetModuleHandle(0)
wc.hIcon = LoadIcon(0, IDI_APPLICATION)
wc.hCursor = LoadCursor(0, IDC_ARROW)
wc.hbrBackground = GetStockObject(WHITE_BRUSH)
wc.lpszMenuName = vbNullString
wc.lpszClassName = APP_NAME
wc.hIconSm = LoadIcon(0, IDI_APPLICATION)
If RegisterClassEx(wc) = 0 Then
Exit Sub
End If
hWnd = CreateWindowEx(WS_EX_APPWINDOW, APP_NAME, APP_TITLE, _
WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, _
200, 100, 0, 0, wc.hInstance, 0)
hWndButton = CreateWindowEx(0, "Button", "click here", WS_CHILD Or BS_PUSHLIKE Or WS_VISIBLE, _
20, 20, 150, 30, hWnd, IDM_BUTTON1, wc.hInstance, 0)
Call ShowWindow(hWnd, SW_SHOW)
Call UpdateWindow(hWnd)
Do While (GetMessage(message, 0, 0, 0))
Call TranslateMessage(message)
Call DispatchMessage(message)
Loop
End Sub

Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim rc As Long, hdc As Long, nhWnd As Long
Dim temp As String
Dim classname As String * 255
Dim wname As String
Dim lngRet As Long, lngTimID
Dim Poi As POINTAPI

Select Case uMsg
Case WM_DESTROY
Call PostQuitMessage(0)
WindowProc = 0
Case WM_COMMAND
Select Case LWORD(wParam)
Case IDM_BUTTON1
Call SetWindowText(hWndButton, "click control")
Call SetCapture(hWnd)
End Select
Case WM_CLOSE
Call DestroyWindow(hWnd)
Call PostQuitMessage(0)
Case WM_LBUTTONDOWN
Call ReleaseCapture
GetCursorPos Poi
nhWnd = WindowFromPoint(Poi.x, Poi.y)
lngRet = GetClassName(nhWnd, classname, Len(classname))
wname = Left(classname, InStr(classname, Chr(0)) - 1)
Debug.Print wname
ActiveCell.Copy
If nhWnd <> hWnd Then
Select Case wname
Case "Edit"
Call SendMessage(nhWnd, EM_SETSEL, 0, -1)
Call SendMessage(nhWnd, WM_CLEAR, 0, 0)
Call SendMessage(nhWnd, WM_PASTE, 0, 0)
Call SetWindowText(hWndButton, "click here")
End Select
Else
Call ReleaseCapture
End If
Application.CutCopyMode = False
ActiveCell.Offset(1, 0).Activate
Case Else
WindowProc = DefWindowProc(hWnd, uMsg, wParam, lParam)
End Select
End Function

Private Function FPtr(ByVal p As Long) As Long
FPtr = p
End Function

Public Function HWORD(ByVal LongValue As Long) As Integer
HWORD = (LongValue And &HFFFF0000) \ &H10000
End Function

Public Function LWORD(ByVal LongValue As Long) As Integer
If (LongValue And &HFFFF&) > &H7FFF Then
LWORD = (LongValue And &HFFFF&) - &H10000
Else
LWORD = LongValue And &HFFFF&
End If
End Function

Public Function GetLong(ByVal UpperWord As Integer, ByVal LowerWord As Integer) As Long
GetLong = (LowerWord And &HFFFF&) Or (UpperWord * &H10000)
End Function

参考URL：

http://d.hatena.ne.jp/uskz/20071030/p1

回答No.3

mitarashi

#1です。少々遊んでみました。拙い切り貼りで識者からは笑われそうですが、
１．ワークシートにコマンドボタンを一個置いて、シートモジュールに下記のコードを書き込みます。
Private WithEvents myTimer As myTimerClass
Private Declare Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function WindowFromPoint Lib "user32.dll" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Type POINTAPI
x As Long
y As Long
End Type

Private Const WM_PASTE As Long = &H302
Private Const WM_CLEAR As Long = &H303
Private Const EM_SETSEL = &HB1

Private Sub CommandButton1_Click()
Set myTimer = New myTimerClass
Call myTimer.TimerTask(1000)
DoEvents
End Sub

Private Sub mytimer_UpdateTime(ByVal lngJump As Long)
Dim nhWnd As Long
Dim ClassName As String * 255
Dim Poi As POINTAPI
Dim lngRet As Long
Dim wName As String

GetCursorPos Poi
nhWnd = WindowFromPoint(Poi.x, Poi.y)
Call GetClassName(nhWnd, ClassName, 255)
　　wName = Left(ClassName, InStr(ClassName, Chr(0)) - 1)
Debug.Print wName
If wName = "XLMAIN" Then Exit Sub
Select Case wName
Case "Edit"
lngRet = SendMessage(nhWnd, EM_SETSEL, 0, -1)
lngRet = SendMessage(nhWnd, WM_CLEAR, 0, 0)
lngRet = SendMessage(nhWnd, WM_PASTE, 0, 0)
End Select
End Sub
２．クラスモジュールmyTimerClassを定義します。
Public Event UpdateTime(ByVal lngJump As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Sub TimerTask(ByVal Duration As Long)
Dim lngStart As Long

lngStart = GetTickCount
Do While GetTickCount < lngStart + Duration
Loop
RaiseEvent UpdateTime(GetTickCount - lngStart)
End Sub
３．使い方
適当なセルの内容等をコピーした後、コマンドボタンをクリックし、他のアプリケーションのEditコントロールの上にマウスポインタを置きます。クリックしてから1秒後にマウスポインタがあるEditコントロールの内容を消去して、クリップボードの中味を貼り付けます。相手がメモ帳程度なら動作しました。相手のコントロールのクラス名を、Debug.Printする様になっていますので、相手に応じて拡張可能です（物好きな方はどうぞ）。相手によっては、ハンドルを取得できない事もある様です。
（注）自アプリケーション外のマウスのイベントを拾える様にするAPIを、VBからは使える様ですが、VBAのフォームからは無理な様です。という事で、VBAのヘルプのサンプルを改造した怪しげなタイマーを使っています。
これが呼び水になって達人の方々の反応があると嬉しいです。

回答No.2

Wendy02

こんばんは。

直接の解答にはなりませんが、#1さんのリンク先のsendmessage か、postmessage か、どちらかを使うのが良いのですが、問題は、

「他アプリケーション（Excelの次にアクティブな状態）のテキストボックス」
のハンドルが取れないことには、難しいのではないかと思います。

それをするためには、Spy++ などのツールが必要です。(擬似ツールは、Vectorにあります）テキストボックス自体はそのままでも、そのアプリケーション自体を決めなくてはなりません。

そういうのが出来なって思うなら、うみうみ屋さんの、UWSCがあります。
この中に、すでに、Win32 APIと同様の機能も含まれていますが、Win32 APIのような難しい書き方は必要ありません。後は、位置関係だけ動かさなければ、そのまま、キーボードマクロが完成します。Excelから呼び出すことも可能です。

このマクロのプログラミングは、VBAの出来る方なら簡単に出来ますが、記録マクロも可能です。

http://www.uwsc.info/

なお、このシェアウェアは、会社でも正規ツールとして認められるものです。

回答No.1

mitarashi

こちらがご参考になるのではないでしょうか。
> C# のスレッドなのに VB でサンプルコードを書いてしまいました。
だ、そうですし。APIを使うのは一緒だと思いますので。
http://social.msdn.microsoft.com/Forums/ja-JP/csharpexpressja/thread/cda56584-dca9-43b8-896f-db47dcf394c8