[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『画像取り込みについて』（eiji）
Excelを32bitから64bitに変更インストールしたところ以下マクロで
画像の取込ができなくなり困っています。32bitパソコンでは問題なく
動作していました。
64bit用の対応おわかりになる方、ご教示お願いします。
★部分で「ファイルが見つかりません olepro32.dll」のエラー表示です
よろしくお願いします。
Private Sub UserForm_Initialize()
ActiveSheet.Shapes("図 1").Copy
Image1.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 4").Copy
Image2.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 5").Copy
Image3.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 3").Copy
Image4.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 6").Copy
Image5.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 8").Copy
Image6.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 9").Copy
Image7.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("グループ化 18").Copy
Image8.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 24").Copy
Image9.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 26").Copy
Image10.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 27").Copy
Image11.Picture = GetPicture(xlPicture)
ActiveSheet.Shapes("図 28").Copy
Image12.Picture = GetPicture(xlPicture)
'標準モジュール
Option Explicit
Private Type GUID
Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type UPICDESC Size As Long Type As Long hPic As Long hPal As Long Reserved As Long End Type Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" _ (picdesc As UPICDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _ (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hmf As Long) As Long Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long Private Declare PtrSafe Function CopyImage Lib "user32" _ (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Const CF_ENHMETAFILE = 14 Const PICTYPE_ENHMETAFILE = 4 Const CF_BITMAP = 2 '=xlBitmap Const PICTYPE_BITMAP = 1 Const IMAGE_BITMAP = 0 Const LR_COPYRETURNORG = 4 Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Function GetPicture(ByVal Format As XlCopyPictureFormat) As IPicture
Dim Handle&, desc As UPICDESC, id As GUID
If OpenClipboard(0&) > 0 Then
If Format = xlBitmap Then
Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
End If
CloseClipboard
End If
If Handle = 0 Then Exit Function
IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
With desc
.Size = Len(desc)
.Type = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = Handle
End With
'Pictureオブジェクトを作成
OleCreatePictureIndirect desc, id, 1, GetPicture’★
If GetPicture Is Nothing Then
If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
End If
End Function
＜ 使用 Excel：Excel2019、使用 OS：Windows11 ＞
https://www.google.com/amp/s/software.opensquare.net/relaxtools/archives/1916/amp/
（MK） 2023/05/02(火) 16:58:39
（eiji） 2023/05/02(火) 17:37:12
分かんないですけど「ファイルが無い」って言われてる以上、まずはソコの検証が先ではないでしょうか? ↓ちょっと式を見比べてみました。
■ご提示の式
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (picdesc As UPICDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
~~~~~~~~~~~~ ~~~~
Private Type UPICDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
Reserved As Long
End Type
■私の持ってる式(但し私は64bitではありません)
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As Long
~~~~~~~~ ~~~~~~~
■VBAから64bit の Windows API を使う場合の情報置き場 - Qiita
https://qiita.com/RelaxTools/items/346d0d3b6e8c982015ab
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (ByRef lpPictDesc As PictDesc, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, ByRef IPic As IPicture) As Long
~~~~~~~~ ~~~~~~~
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As LongPtr '←
Option1 As LongPtr '←
Option2 As LongPtr '←
End Type
（白茶） 2023/05/02(火) 17:59:35
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type UPICDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
Reserved As Long
End Type
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As LongPtr '←
Option1 As LongPtr '←
Option2 As LongPtr '←
End Type
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" _
(ByRef lpPictDesc As PictDesc, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, ByRef IPic As IPicture) As LongPtr
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hmf As Long) As Long Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long Private Declare PtrSafe Function CopyImage Lib "user32" _ (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Const CF_ENHMETAFILE = 14 Const PICTYPE_ENHMETAFILE = 4 Const CF_BITMAP = 2 '=xlBitmap Const PICTYPE_BITMAP = 1 Const IMAGE_BITMAP = 0 Const LR_COPYRETURNORG = 4 Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Function GetPicture(ByVal Format As XlCopyPictureFormat) As IPicture ’★
Dim Handle&, desc As UPICDESC, id As GUID
If OpenClipboard(0&) > 0 Then
If Format = xlBitmap Then
Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
End If
CloseClipboard
End If
If Handle = 0 Then Exit Function
IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
With desc
.Size = Len(desc)
.Type = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = Handle
End With
'Pictureオブジェクトを作成
OleCreatePictureIndirect desc, id, 1, GetPicture ’●
If GetPicture Is Nothing Then
If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
End If
End Function
（eiji） 2023/05/02(火) 19:40:34
「型が一致しません」って言って怒られた訳ですから、まずはそこを確認してみることです。
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" _
(ByRef lpPictDesc As PictDesc, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, ByRef IPic As IPicture) As LongPtr
~~~~~~~~
desc As UPICDESC ← PictDesc ではないですか?
（白茶） 2023/05/02(火) 19:55:09
Image1.Picture = GetPicture(xlPicture) GetPicture ←引数は省略できません エラーです 難しいですね？ 以下修正しましたが
Public Function GetPicture(ByVal Format As XlCopyPictureFormat, ByRef lpPictDesc As PictDesc) As IPicture
Dim Handle&, PictDesc As UPICDESC, id As GUID
If OpenClipboard(0&) > 0 Then
If Format = xlBitmap Then
Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
End If
CloseClipboard
End If
If Handle = 0 Then Exit Function 'イメージ取得失敗
IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
With PictDesc
.Size = Len(PictDesc)
.Type = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = Handle
End With
'Pictureオブジェクトを作成
OleCreatePictureIndirect PictDesc, id, 1, GetPicture
If GetPicture Is Nothing Then
If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
End If
End Function
（eiji） 2023/05/02(火) 20:13:22
>GetPicture ←引数は省略できません エラーです 自分を呼び出してる状況になっちゃってますね。(多分ですけど)
それとさっきのは
>Dim Handle&, PictDesc As UPICDESC, id As GUID
~~~~~~~~ココが PictDesc ではないのですか? って意味です。
結局 UPICDESC は Declare 内で使ってないですよね?
たぶん Dim Handle&, desc As PictDesc, id As GUID として Call OleCreatePictureIndirect(desc, id, 1, GetPicture) みたいな感じだと思います。
（白茶） 2023/05/02(火) 20:26:33
'Dim Handle&, PictDesc As UPICDESC, id As GUID
Dim Handle&, desc As PictDesc, id As GUID
If OpenClipboard(0&) > 0 Then
If Format = xlBitmap Then
Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
End If
CloseClipboard
End If
If Handle = 0 Then Exit Function 'イメージ取得失敗
IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
With PictDesc
.Size = Len(PictDesc)
.Type = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = Handle
End With
'Pictureオブジェクトを作成
Call OleCreatePictureIndirect(desc, id, 1, GetPicture)
'OleCreatePictureIndirect PictDesc, id, 1, GetPicture
If GetPicture Is Nothing Then
If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
End If
End Function
（eiji） 2023/05/02(火) 20:41:45
当方2010/32bit環境ですが、↓で実験してみたらイケました。
Public Function GetPicture(ByVal Format As XlCopyPictureFormat) As IPicture '★
'Dim Handle&, PictDesc As UPICDESC, id As GUID
Dim Handle&, desc As PictDesc, id As GUID
If OpenClipboard(0&) > 0 Then
If Format = xlBitmap Then
Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
End If
CloseClipboard
End If
If Handle = 0 Then Exit Function 'イメージ取得失敗
IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
With desc '★
.cbSizeofStruct = Len(desc) '★
.picType = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) '★
.hImage = Handle '★
End With
'Pictureオブジェクトを作成
Call OleCreatePictureIndirect(desc, id, 1, GetPicture)
'OleCreatePictureIndirect PictDesc, id, 1, GetPicture
If GetPicture Is Nothing Then
If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
End If
End Function
Sub test() '実験マクロ(図1の絵をImage1に転写)
ActiveSheet.Shapes("図 1").Copy
ActiveSheet.Image1.Picture = GetPicture(xlPicture)
End Sub
（白茶） 2023/05/02(火) 20:59:49
（eiji） 2023/05/03(水) 02:00:45
標準モジュール
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.x, tPT.y)
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)’★
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As Long
On Error GoTo errH 'Resume Next
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _
Cancel As Boolean)
If Not Intersect(Target, Range("V11:X14")) Is Nothing Then
Cancel = True
With ListBox1
.Show vbModal
End With
End If
End Sub
（eiji） 2023/05/03(水) 16:42:52
ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
HookListBoxScroll
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
（eiji） 2023/05/04(木) 00:48:33
当方 2021 / 64 bit 環境ですが、
＞32bitExcelでは、問題なく動作していました。
シートモジュールのマクロについてお聞きしますが 前回まで↓下記で動作していたのでしょうか？
**************************
～ 略 ～
With ListBox1
.Show vbModal
End With
～ 略 ～
'**************************
＊何か省いていませんか？
↓こちらなら、まだ理解できます。
'シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _
Cancel As Boolean)
If Not Intersect(Target, Range("V11:X14")) Is Nothing Then
Cancel = True
With UserForm1.ListBox1
Rem ListBox1へ何かの処理
Dim i&
For i = 1 To 15
.AddItem "項目" & i
Next i
.MultiSelect = fmMultiSelectExtended
End With
UserForm1.Show vbModal
End If
End Sub
＞以下 ユーザーフォームのListBox1の マウススクロール可能なマクロです。 ＞★部分の AddressOf MouseProc これが反転し コンパイルエラー型が一致しません
こちら環境では、提示のコードを 64 bit 対応に変更したところ ★部分のエラーは無く、ListBox1 を選択後、マウススクロールにて 上に動いています。
ただし、下には動きません。 ※まずは確認まで （あみな） 2023/05/04(木) 22:58:10
すみませんシートモジュールは間違えていました。
以下になります
シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _
Cancel As Boolean)
If Not Intersect(Target, Range("V11:X14")) Is Nothing Then
Cancel = True
With UserForm1’★
.Show vbModal
End With
End If
End Sub
ユーザーフォームモジュール
Option Explicit
Private RowSourceRng As Range
Private Sub ListBox1_MouseMove( _
ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
HookListBoxScroll
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
Private Sub UserForm_Initialize()
With Sheets(1).Range("AZ:BA")
Set RowSourceRng = Excel.Range(.Item(1, 2), .Item(.Rows.Count, 1).End(xlUp))
End With
RowSourceRngSortSet
End Sub
Private Sub RowSourceRngSortSet()
With RowSourceRng
.Sort Key1:=.Item(1, 2), Order1:=xlAscending, _
Header:=xlGuess, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
Me.ListBox1.RowSource = RowSourceRng.Address(External:=True)
End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Len(ActiveCell.Value) = 0 Then
ActiveCell.Value = ListBox1.Value
Else
ActiveCell.Value = ActiveCell.Value & "･" & ListBox1.Value
End If
End Sub
情報不足でした
この状況で再度マクロ検証お願いします。
よろしくお願いします。
（eiji） 2023/05/05(金) 01:29:05
＞この状況で再度マクロ検証お願いします。 特に問題なく、動いてくれておりますよｫ♪
シートモジュールと、ユーザーフォームモジュールは そのままのコードで良いです。
標準モジュールのみ下記に変更して試してください。 尚、念のためBOOKは複製を取ってください。 因みにですが、32 bit でも動くと思います。( きっと )
Option Explicit
Rem 標準モジュール
Rem 64bit対応
'************************
Private Type POINTAPI
X As LongPtr
Y As LongPtr
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hWnd As LongPtr
wHitTestCode As LongPtr
dwExtraInfo As LongPtr
End Type
Private Declare PtrSafe Function FindWindow Lib "user32" _ Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _ Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _ Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, _ ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _ ByVal hHook As LongPtr, ByVal nCode As LongPtr, _ ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _ ByVal hHook As LongPtr) As LongPtr Private Declare PtrSafe Function PostMessage Lib "user32.dll" _ Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As LongPtr, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _ ByVal xPoint As LongPtr, ByVal yPoint As LongPtr) As LongPtr Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _ ByRef lpPoint As POINTAPI) As LongPtr
Private Const WH_MOUSE_LL As LongPtr = 14 Private Const WM_MOUSEWHEEL As LongPtr = &H20A Private Const HC_ACTION As LongPtr = 0 Private Const GWL_HINSTANCE As LongPtr = (-6) Private Const WM_KEYDOWN As LongPtr = &H100 Private Const WM_KEYUP As LongPtr = &H101 Private Const VK_UP As LongPtr = &H26 Private Const VK_DOWN As LongPtr = &H28 Private Const WM_LBUTTONDOWN As LongPtr = &H201 Private mLngMouseHook As LongPtr Private mListBoxHwnd As LongPtr Private mbHook As Boolean
Sub HookListBoxScroll()
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc(ByVal nCode As LongPtr, ByVal wParam As LongPtr, _
ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
On Error GoTo errH 'Resume Next
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hWnd > 0 Then
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
※今後も、APIを利用するマクロで四苦八苦しないよう 参考文献を、下記に提示しておきますね。
※32 bit で動くマクロなら、基本は 64 bit 対応に箱の大きさを 変更すれば動きます。
※箱の大きさを揃えるとは？
＊|Byte型 |「0～255」 ＊|Integer型 |「-32，768～32,767」 ＊|Long型 |「-2,147,483,648 ～ 2,147,483,647 」32 ビット (4 バイト) の数値として格納 ＊|LongPtr 型 |「 -9,223,372,036,854,775,808 ～ 9,223,372,036,854,775,807 」64 ビット (8 バイト) の数値として格納 ＊|LongLong型 |「 -9,223,372,036,854,775,808 ～ 9,223,372,036,854,775,807 」64 ビット (8 バイト) の数値として格納
※参考文献
＊LongPtr (32 ビット システムでは Long 整数、64 ビット システムでは LongLong 整数) 変数は次のように格納されます。 https://learn.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/longptr-data-type ＊LongLong データ型 https://learn.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/longlong-data-type ＊VBAでWin32API（WindowsAPI）を64bit対応する方法 https://vbabeginner.net/win32api-64bit/ ＊WindowsAPI をOffice64bit版または32bit版のVBAで使うには https://hatena19.com/use-win-api-with-office-64bit-or-32bit-vba/
※LongPtrは、32 ビット環境ではLongに変換され、64 ビット環境では LongLong に変換される
※私の、 64 bit くんは、正常に動いてるので Σd(ゝ∀･)v 動かないときはご容赦を(o_ _)o （あみな） 2023/05/05(金) 20:15:22
Private Const WH_MOUSE_LL As Long = 14 Private Const WM_MOUSEWHEEL As LongPtr = &H20A Private Const HC_ACTION As LongPtr = 0 Private Const GWL_HINSTANCE As Long = (-6) Private Const WM_KEYDOWN As LongPtr = &H100 Private Const WM_KEYUP As LongPtr = &H101 Private Const VK_UP As LongPtr = &H26 Private Const VK_DOWN As LongPtr = &H28 Private Const WM_LBUTTONDOWN As LongPtr = &H201 Private mLngMouseHook As LongPtr Private mListBoxHwnd As LongPtr Private mbHook As Boolean
Sub HookListBoxScroll()
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)’★
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)’★
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
いろいろWeb検索したところ以下2つに行き着きました
https://excel-databace.hatenablog.com/entry/64bit-vba-error
https://www.excelnoob.com/mengaktifkan-scroll-mouse-pada-listbox-di-vba/
お忙しいところ申し訳ないですが確認していただけないでしょうか
また、（あみな）さんPC64bitと当方64bit設定の違いでもあるのでしょうね？
エディターの参照設定とか・・・
よろしくお願いします。
（eiji） 2023/05/06(土) 17:57:12
なんですって…エラーですか（ ; ; ）
私の、 Microsoft® Excel® 2021 MSO (バージョン 2304 ビルド 16.0.16327.20200) 64 ビット くんは正常です。
＞（あみな）さんPC64bitと当方64bit設定の違いでもあるのでしょうね？ それはあったら困るぽォ
私も、ここだけ↓下記に訂正して、動作確認しましたが、ちゃんと動きます。 逆に、エラーになってくれないと探せないですΣ(ﾉ∀｀*)ﾍﾟﾁｯ
Private Const WH_MOUSE_LL As Long = 14 '★ Private Const WM_MOUSEWHEEL As LongPtr = &H20A Private Const HC_ACTION As LongPtr = 0 Private Const GWL_HINSTANCE As Long = (-6) '★
勘違いなんて事は無いと思いますが、確認をしてください。 ↓ ※使用している Office のバージョンを確認する方法 https://support.microsoft.com/ja-jp/office/%E4%BD%BF%E7%94%A8%E3%81%97%E3%81%A6%E3%81%84%E3%82%8B-office-%E3%81%AE%E3%83%90%E3%83%BC%E3%82%B8%E3%83%A7%E3%83%B3%E3%82%92%E7%A2%BA%E8%AA%8D%E3%81%99%E3%82%8B%E6%96%B9%E6%B3%95-932788b8-a3ce-44bf-bb09-e334518b8b19
＞エディターの参照設定とか・・・ 新規BOOKに、ユーザーフォーム挿入しただけだから勝手に microsoft forms 2.0 object library が入ってるだけですね。
※一度、新規のBOOKで試すのが良いかと思います。
（eiji） 2023/05/05(金) 01:29:05 で提示されたマクロ分と （あみな） 2023/05/05(金) 20:15:22 の分しか私は入れてないです。
ユーザーフォーム1つに、ListBox1 を追加しただけです。
シートモジュールの、Range("V11:X14") 範囲をダブルクリックすると
ユーザーフォームが起動して、Range("AZ:BA")の範囲の値が ListBox1に反映され
1行をフォーカスして、マウスで上にスクロールできますね。
また、APIの事は、ここの回答者の中では...（白茶）さんが一番詳しいです。( きっと ) しかし、使用していない APIくんを調べるのは、かなり大変だし、環境が 64 bit でないと テストできないので…どうなのかなとも思います。まあ、誰がしても大変な部類ですが
取り敢えず、どんなものかだけ…数日前に興味を持って 少しだけ調べてたので、情報をあげておきます。
Option Explicit
'*************************************
Rem マウスカーソルの位置取得
Private Type POINTAPI
X As LongPtr 'Ｘ座標
Y As LongPtr 'Ｙ座標
End Type
'*************************************
Rem マウスの位置や送られるべきウィンドウのハンドルなどは
Rem 第3引数のlParamが示すアドレス
Rem（MOUSEHOOKSTRUCT構造体のアドレス）に入る。
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI 'マウスカーソル座標
hWnd As LongPtr 'ウィンドウハンドル
wHitTestCode As LongPtr ' ヒットテストコード
dwExtraInfo As LongPtr ' メッセージ関連のエクストラ情報
End Type
'*************************************
Rem Windowハンドルを取得 Rem [ pClassName ]ウィンドウが属するウィンドウクラス名を指定［省略不可］ Rem [ lpWindowName ] ウィンドウのタイトルバーの文字列を指定［省略不可］ Private Declare PtrSafe Function FindWindow Lib "user32" _ Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Rem 指定されたウィンドウに関する情報を取得 Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _ Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Rem フォームにフックプロシジャを登録しそこでマウスの動きを取得 Rem [ SetWindowsHookEx ] APIの戻り値はフックハンドルになる。 Rem これはフックを解除するときに必要になるので保存する｡ Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _ Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, _ ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Rem 最後の[ CallNextHookEx ] APIは次のフックプロシジャを呼び出す。 Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _ ByVal hHook As LongPtr, ByVal nCode As LongPtr, _ ByVal wParam As LongPtr, lParam As Any) As LongPtr
Rem SetWindowsHookEx 関数によってフック チェーンに Rem インストールされているフック プロシージャを削除する。 Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _ ByVal hHook As LongPtr) As LongPtr
Rem ポストされたメッセージを受信する Private Declare PtrSafe Function PostMessage Lib "user32.dll" _ Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As LongPtr, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Rem 指定の座標位置にある、ウィンドウハンドルを取得 Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _ ByVal xPoint As LongPtr, ByVal yPoint As LongPtr) As LongPtr
Rem GetCursorPos 関数で、マウスの画面上の現在地を取得 Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _ ByRef lpPoint As POINTAPI) As LongPtr
（あみな） 2023/05/06(土) 20:14:43
わぁ... こりゃまたメンドイ事に取り組まれてらっしゃるんですねぇー ちょっと私にはもう付いてけないデスわ正直。^^;
もう、私からアドバイス出来るとしたら...
Declareの正しい記述は、あみなさんの紹介されたリンク先にもリンクが貼ってありますが 「Win32API_PtrSafe.txt」を入手して逐一確認した方がいいです。 (これで↑ググっても出てきますよ多分)
網羅出来ている訳ではありません(GDI+とか入ってないし)が、これが「お手本」ですから。 て事で、頑張ってください。
以下、 excel - ListBox Scroll Event on Form - Stack Overflow https://stackoverflow.com/questions/72999647/listbox-scroll-event-on-form
を参考に定義の修正を試みてみた(もう完全にあてずっぽうです)
■GetWindowLongのDeclareを↓に変更
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
' Provided for reference only. Please use the LongPtr versions instead.
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
#End If
■SetWindowsHookExのDeclareを↓に変更
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
■CallNextHookExのDeclareを↓に変更
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
■UnhookWindowsHookExのDeclareを↓に変更
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
■PostMessageのDeclareを↓に変更
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
■WindowFromPointのDeclareを↓に変更
#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongPtr
' Copies a POINTAPI into a LongLong. For an API requiring a ByVal POINTAPI parameter,
' this LongLong can be passed in instead. Example API's include WindowFromPoint,
' ChildWindowFromPoint, ChildWindowFromPointEx, DragDetect, and MenuItemFromPoint.
Function PointToLongLong(point As POINTAPI) As LongLong
Dim ll As LongLong
Dim cbLongLong As LongPtr
cbLongLong = LenB(ll)
' make sure the contents will fit
If LenB(point) = cbLongLong Then
CopyMemory ll, point, cbLongLong
End If
PointToLongLong = ll
End Function
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
■GetCursorPosのDeclareを↓に変更
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
■定数の型をLongに変更
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
■HookListBoxScrollを↓に変更
Sub HookListBoxScroll()
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim tPT As POINTAPI
GetCursorPos tPT
#If Win64 Then
hwndUnderCursor = WindowFromPoint(PointToLongLong(tPT))
#Else
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
#End If
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0&)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
あ、 ちなみに、OSが64bitであることと、Officeが64bit版である事は、また別の話ですけど、 その辺は大丈夫ですかね? Windowsが64bitでもOfficeが32bitなら、当然32bitとして諸々を記述しないとダメですからね。
（白茶） 2023/05/06(土) 20:45:49
あ、しもた。
>> lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
GetWindowLongPtr(
ですよね。これでいったら。スマセン... ^^;
注: ↑でイケるとは言ってません。
「自分で書いた定義に従えばこうでしたネ」ってだけで。
（白茶） 2023/05/06(土) 21:55:01
（白茶）さん
最初の画像取込の件ありがとうございました。
また、見ていただき感謝いたします。
いろんな所ググっているのですが、見れば見るほどとんでもない質問したと反省<(_ _)>
ちょっと難しくてついて行けません。とりあえずアップ頂いたもので確認させてください。
＞OSが64bitであることと、Officeが64bit版である事は、また別の話ですけど、 その辺は大＞丈夫ですかね?
＞Windowsが64bitでもOfficeが32bitなら、当然32bitとして諸々を記述しないとダメですからね
↑この辺はOKです OS64bit Office64bitです。
LongPtr 64bit 32bit どちらもいけるのではないのですか？
LongLong 64bit用
できれば32bit版も一部のパソコンがありますので併用できればありがたいです。
試す時間（たいしたことはできませんが）いただき 確認後返信いたします。
（eiji） 2023/05/07(日) 03:29:42
あ、構造体の型を直し忘れてました。 お手本によると↓が正しい様です。
Private Type POINTAPI
x As Long
y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
（白茶） 2023/05/08(月) 09:07:15
ちなみに... (後から後からボロボロとスマセン ^^;)
PointToLongLong内で使用される[CopyMemory]のDeclareは↓でした。
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
（白茶） 2023/05/08(月) 10:45:16
マクロを整理をし、再度実行しましたが
★部分 mListBoxHwnd 黄色反転 コンパイルエラー変数が定義されていません。です
いやー難しいですね・・・
よろしくお願いします。
Option Explicit
Rem 標準モジュール
Rem 64bit対応
'************************
Private Type POINTAPI
x As Long
y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
' Provided for reference only. Please use the LongPtr versions instead.
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
#End If
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" _
Alias "PostMessageA" ( _
ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Function PointToLongLong(point As POINTAPI) As LongLong
Dim ll As LongLong
Dim cbLongLong As LongPtr
cbLongLong = LenB(ll)
' make sure the contents will fit
If LenB(point) = cbLongLong Then
CopyMemory ll, point, cbLongLong
End If
PointToLongLong = ll
End Function
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr
Private mbHook As Boolean
Sub HookListBoxScroll()
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim tPT As POINTAPI
GetCursorPos tPT
#If Win64 Then
hwndUnderCursor = WindowFromPoint(PointToLongLong(tPT))
#Else
hwndUnderCursor = WindowFromPoint(tPT.x, tPT.y)
#End If
If mListBoxHwnd <> hwndUnderCursor Then'★
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0&)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal ncode As LongPtr, ByVal wParam As LongPtr, _
ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
On Error GoTo errH 'Resume Next
If (ncode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, ncode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
（eiji） 2023/05/08(月) 15:36:39
>★ 部分 mListBoxHwnd 黄色反転 コンパイルエラー変数が定義されていません。です だったら mListBoxHwnd を変数定義すれば済むことでしょ。
（hensuu） 2023/05/08(月) 16:45:33
Private mListBoxHwnd As LongPtr
ほかに原因あるのでは？
分かりませんが違います？
（eiji） 2023/05/08(月) 16:55:50
（eiji） 2023/05/08(月) 21:16:17
で... 出来たよwww!!
会社で64bit版の入ったマシンを使わせて貰ったんだぜぃ
Rem ************************************************************************************************************************
Rem [Userform1]モジュール (動作確認用) List1のリストがマウスホイールでスクロール出来れば合格
Rem ************************************************************************************************************************
Option Explicit
Private WithEvents List1 As MSForms.ListBox
Private Sub List1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll
End Sub
Private Sub UserForm_Initialize()
Set List1 = Me.Controls.Add("Forms.ListBox.1", "List1")
List1.Top = 6!
List1.Left = 6!
List1.Width = Me.InsideWidth - 12!
List1.Height = 96!
Dim i As Long
For i = 1 To 20
List1.AddItem i
Next
List1.IntegralHeight = False
List1.IntegralHeight = True
End Sub
Private Sub UserForm_Terminate()
UnhookListBoxScroll
End Sub
Rem ************************************************************************************************************************
Rem 標準モジュール
Rem ************************************************************************************************************************
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long 'Ptr '←ココ、わざとLongで定義する
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
' Provided for reference only. Please use the LongPtr versions instead.
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr
Private mbHook As Boolean
#If Win64 Then
Function PointToLongLong(point As POINTAPI) As LongLong
Dim ll As LongLong
Dim cbLongLong As LongPtr
cbLongLong = LenB(ll)
' make sure the contents will fit
If LenB(point) = cbLongLong Then
CopyMemory ll, point, cbLongLong
End If
PointToLongLong = ll
End Function
#End If
Sub HookListBoxScroll()
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim tPT As POINTAPI
GetCursorPos tPT
#If Win64 Then '**********************************************
hwndUnderCursor = WindowFromPoint(PointToLongLong(tPT))
#Else
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
#End If '_____________________________________________________
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0&)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc(ByVal ncode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
On Error GoTo errH
If (ncode = HC_ACTION) Then
#If Win64 Then '*********************************************************
If WindowFromPoint(PointToLongLong(lParam.pt)) = mListBoxHwnd Then
#Else
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
#End If '________________________________________________________________
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx(mLngMouseHook, ncode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
（白茶） 2023/05/08(月) 21:17:00
ちなみに、
>> Type MOUSEHOOKSTRUCT >> pt As POINTAPI >> hwnd As Long 'Ptr '←ココ、わざとLongで定義する
この部分について、LongPtrのまま動いて貰おうと思ったら... ってバージョンです。
Rem ************************************************************************************************************************
Rem 標準モジュール
Rem ************************************************************************************************************************
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr '←★ココ、わざとLongで定義してたところ
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
' Provided for reference only. Please use the LongPtr versions instead.
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr
Private mbHook As Boolean
#If Win64 Then
Function PointToLongLong(point As POINTAPI) As LongLong
Dim ll As LongLong
Dim cbLongLong As LongPtr
cbLongLong = LenB(ll)
' make sure the contents will fit
If LenB(point) = cbLongLong Then
CopyMemory ll, point, cbLongLong
End If
PointToLongLong = ll
End Function
#End If
Sub HookListBoxScroll()
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim tPT As POINTAPI
GetCursorPos tPT
#If Win64 Then '**********************************************
hwndUnderCursor = WindowFromPoint(PointToLongLong(tPT))
#Else
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
#End If '_____________________________________________________
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0&)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc(ByVal ncode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
On Error GoTo errH
If (ncode = HC_ACTION) Then
#If Win64 Then '*********************************************************
If WindowFromPoint(PointToLongLong(lParam.pt)) = mListBoxHwnd Then
#Else
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
#End If '________________________________________________________________
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
Dim hwnd32 As Long '★追記
CopyMemory hwnd32, lParam.hwnd, LenB(hwnd32) '★追記
' If lParam.hwnd > 0 Then '←ココの条件を変えりゃあイイだけって話でもあるんだがね... ^^;
If hwnd32 > 0 Then '★修正
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx(mLngMouseHook, ncode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
（白茶） 2023/05/08(月) 21:19:32
おー、待ってました。無事動いた様で良かったっス。
>本当に詳しい方でなんですね いやいや、実は特に「詳しい人」って訳じゃないんですよね (詳しそうな「ふり」して遊んでるだけで ^^;) コールバック自体使った事なかったし。
ミスったらすぐハングしたりクラッシュしたりするんで、あんまり使う気になれなかったんですが、 今回勉強するいい機会を与えて頂きました。
まだ私自身よく理解出来ていない(体感43%くらいの納得感)状況ですが、 フックへの「食わず嫌い」感はちょっと薄れた気がします。 副次的に手持ちの道具の64bit対応の「甘さ」も幾つか発見できましたし。
こちらこそ、お世話になりました。
（白茶） 2023/05/11(木) 17:52:41
～ 勝手に番外編 ～
そうは言っても、やっぱ可能な限りコールバックは避けて通りたいなぁ... と考えてしまう。
ほんじゃあ、ループ回して監視し続けるしかないよね。 って事で、復習がてらUserformの中だけで完結させてみました。
Hookの代わりに無限ループ回しながらPeekMessageで監視し、 (もうこの時点で実用には向かない気がするけど ^^;) スクロール操作はeijiさんの原案通りPostMessageにお任せ。 ついでに >> 'If lParam.hwnd > 0 Then '←ココの条件を変えりゃあイイだけって話でもあるんだがね... ^^;
って部分についても 「符号なし長整数への擬似変換」を経由して32bit版/64bit版どちらでも同じ条件で判定出来る様に変更してみました。
Rem ************************************************************************************************************************
Rem [Userform1]モジュール
Rem ************************************************************************************************************************
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSG
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hwnd As LongPtr) As Long
Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#If Win64 Then '**********************************************************************************************************
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If '_________________________________________________________________________________________________________________
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const PM_NOREMOVE As Long = &H0
Private Const OFFSET_4 = 4294967296# '(&H100000000)
Private Const MAXINT_4 = 2147483647 '(&H7FFFFFFF)
Private WithEvents List1 As MSForms.ListBox
Private LoopFlag As Boolean
#If Win64 Then
Private Function PointToLongLong(point As POINTAPI) As LongLong
Dim ll As LongLong
Dim cbLongLong As LongPtr
cbLongLong = LenB(ll)
If LenB(point) = cbLongLong Then
CopyMemory ll, point, cbLongLong
End If
PointToLongLong = ll
End Function
#End If
Private Function LongToULong(Value As LongPtr)
If Value < 0 Then
LongToULong = CDec(Value) + OFFSET_4
Else
LongToULong = CDec(Value)
End If
End Function
Private Property Get IsRunning() As Boolean
IsRunning = LoopFlag
End Property
Private Property Let IsRunning(newBool As Boolean)
If LoopFlag = newBool Then Exit Property
LoopFlag = newBool
If LoopFlag Then
Me.Caption = "●監視中です..."
Call Observer
Else
Me.Caption = "■停止中"
End If
End Property
Private Sub Observer()
Dim ms As MSG, p As POINTAPI
Dim hwnd As LongPtr, hList As LongPtr, hCur As LongPtr
Dim vlKey As Long, pmRtn As Long
' WindowFromAccessibleObject Me, hwnd 'こっちだと何処でホイール操作しても反応するが
WindowFromAccessibleObject List1, hList '←ListBoxのハンドルが取れれば(実際取れた)ListBox上でのホイール操作のみに限定が可能だネ
Do While LoopFlag
GetCursorPos p
#If Win64 Then '**********************************************
hCur = WindowFromPoint(PointToLongLong(p))
#Else
hCur = WindowFromPoint(p.X, p.Y)
#End If '_____________________________________________________
If hCur = hList And Me.ActiveControl Is List1 Then
pmRtn = PeekMessage(ms, hList, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE)
If pmRtn And ms.message = WM_MOUSEWHEEL Then
vlKey = IIf(LongToULong(ms.wParam) > MAXINT_4, VK_DOWN, VK_UP)
PostMessage hList, WM_KEYDOWN, vlKey, 0
PostMessage hList, WM_KEYUP, vlKey, 0
Else
TranslateMessage ms
DispatchMessage ms
End If
End If
DoEvents: DoEvents: DoEvents
Sleep &H10&
Loop
End Sub
Private Sub UserForm_Activate()
IsRunning = True
End Sub
Private Sub UserForm_Click()
IsRunning = Not IsRunning
End Sub
Private Sub UserForm_Initialize()
Set List1 = Me.Controls.Add("Forms.ListBox.1", "List1")
List1.Top = 6!
List1.Left = 6!
List1.Width = Me.InsideWidth - 12!
List1.Height = 96!
Dim i As Long
For i = 1 To 50
List1.AddItem i
Next
List1.IntegralHeight = False
List1.IntegralHeight = True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
IsRunning = False
End Sub
（白茶） 2023/05/12(金) 15:44:10
2023/05/05(金) 01:29:05時点で掲示しました
・Private Sub UserForm_Initialize()
・Private Sub ListBox1_MouseUp
この2点を、どのように加工したらいいのか解りません。
レベルが違いすぎます。
良い方法はありますか。
（eiji） 2023/05/13(土) 01:50:47
混乱させてしまってスミマセン ^^;
あくまで「コールバック避けて通るなら」という条件下での一例として追記させて頂きました。 eijiさんのユーザーフォームに組み込むのは、ちょっとオススメしません。
実は別にすごくないんですよね。これ。^^; やってる事の難易度はむしろ下がってます。
モジュール1個で済ませられるのは、確かに一見メリットにも感じましょう。(感じるだけですが) しかしマウスホイールを反応させるためにずーっとループ回し続けるのってどうなんでしょう? 本来ユーザーフォームにやってもらいたかった「お仕事」へ差し障る可能性が大きいので、 局所的な使用に限定するならば、まぁ使ってもいいかなーくらいの位置付けだと思います。
実際、私の手持ち道具でも同様の手法を組み込んでるユーザーフォームがありますが、 ユーザーフォームが閉じられるまで監視ループがずーっと回しっ放しって訳じゃなく、 特定の機能を実行している間だけ監視ループを動かす様にしてます。
ユーザーフォームにマウスホイールのイベントを実装する|K窓 Excel技<Excel Tips> Excel編
http://www2.aqua-r.tepm.jp/~hironobu/ke_m15.htm#E03M149
↑これが恐らくひとつの「到達点」ではないかと思ってますけど、 eijiさんのユーザーフォームもなさってる事の本質に違いはありませんし、 無理にコールバック避けなくてもいいんじゃないかと思ってます。
（白茶） 2023/05/13(土) 12:06:34
・・・ていう前置きを書いてからコードを投下しようと思ってたら夜になっちゃった...^^;
以前、お遊びのつもりで「ループ回して監視」の機能をクラスモジュールに追いやったものを作った事があったのを思い出し、 折角ならと、ひとしきり弄り回して遊び直しておりました。本トピで切欠を頂いたものと思ってます。感謝です。^^;
何か意味不明なのがごちゃごちゃ書いてありますけど、 あんまり深く考えずに「小ネタ」のひとつとしてお試しください。 (んで光の速さで廃棄しましょう^^; )
Rem ************************************************************************************************************************
Rem [clsMouseEv]クラスモジュール
Rem ************************************************************************************************************************
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSG
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const PM_NOREMOVE As Long = &H0
Private Const VK_SHIFT As Long = &H10
Private Const VK_CONTROL As Long = &H11
Private Const VK_MENU As Long = &H12
Private Const VK_LBUTTON As Long = &H1
Private Const VK_RBUTTON As Long = &H2
Private Const VK_MBUTTON As Long = &H4
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const OFFSET_4 = 4294967296# '(&H100000000)
Private Const MAXINT_4 = 2147483647 '(&H7FFFFFFF)
Private LoopFlag As Boolean, aCurPos As POINTAPI
Private btn(0 To 2) As Long, sft(0 To 2) As Long
Private hw As LongPtr
Private xDPI As Long, yDPI As Long, xlPPI As Long
Public Event MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Public Event MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Public Event MouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Public Event MouseWheelUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Public Event MouseWheelDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Public Event MouseOver(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Public Event MouseOut(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Private Function LongToULong(Value As LongPtr)
If Value < 0 Then
LongToULong = CDec(Value) + OFFSET_4
Else
LongToULong = CDec(Value)
End If
End Function
Private Function GetDPI(nIndex As Long) As Long
Dim hDC As LongPtr
hDC = GetDC(Application.hwnd)
GetDPI = GetDeviceCaps(hDC, nIndex)
ReleaseDC &H0, hDC
End Function
Rem ===========================================================================
Rem ピクセル⇔ポイント変換
Private Function Px2PtX(aPixel As Long) As Single 'ピクセルを水平ポイントに変換
Px2PtX = Int((aPixel * xlPPI / xDPI) / (xlPPI / xDPI)) * (xlPPI / xDPI) 'Int((px * 0.75) / 0.75) * 0.75
End Function
Private Function Pt2PxX(aPoint As Single) As Long '水平ポイントをピクセルに変換
Pt2PxX = Int(aPoint * xDPI / xlPPI)
End Function
Private Function Px2PtY(aPixel As Long) As Single 'ピクセルを垂直ポイントに変換
Px2PtY = Int((aPixel * xlPPI / yDPI) / (xlPPI / yDPI)) * (xlPPI / yDPI)
End Function
Private Function Pt2PxY(aPoint As Single) As Long '垂直ポイントをピクセルに変換
Pt2PxY = Int(aPoint * yDPI / xlPPI)
End Function
Rem ===========================================================================
Property Get TargetWindow() As LongPtr
TargetWindow = hw
End Property
Property Let TargetWindow(newhWnd As LongPtr)
If hw = newhWnd Then Exit Property
hw = newhWnd
End Property
Property Get IsMouseOver() As Boolean
If hw <> 0 Then
Dim wRect As RECT
GetWindowRect hw, wRect
IsMouseOver = (aCurPos.X >= wRect.Left And aCurPos.X <= wRect.Right And aCurPos.Y >= wRect.Top And aCurPos.Y <= wRect.Bottom)
End If
End Property
Property Get ScreenX() As Long
ScreenX = aCurPos.X
End Property
Property Get ScreenY() As Long
ScreenY = aCurPos.Y
End Property
Property Get ClientX() As Single
If hw Then
Dim p As POINTAPI
p = aCurPos
ScreenToClient hw, p
ClientX = Px2PtX(p.X)
End If
End Property
Property Get ClientY() As Single
If hw Then
Dim p As POINTAPI
p = aCurPos
ScreenToClient hw, p
ClientY = Px2PtY(p.Y)
End If
End Property
Property Get ButtonState() As Long
ButtonState = btn(0) + btn(1) + btn(2)
End Property
Property Get ShiftState() As Long
ShiftState = sft(0) + sft(1) + sft(2)
End Property
Property Get IsRunning() As Boolean
IsRunning = LoopFlag
End Property
Property Let IsRunning(newBool As Boolean)
If LoopFlag = newBool Then Exit Property
LoopFlag = newBool
If LoopFlag Then Call Observer
End Property
Private Sub Observer()
Dim ms As MSG, pmRtn As Long, i As Long, d As Long, u As Long, h As LongPtr, o As Boolean
Static ovr As Boolean, oldCurPos As POINTAPI, btnOld(0 To 2) As Long, sftOld(0 To 2) As Long
Do
If Not LoopFlag Then Exit Do
GetCursorPos aCurPos
o = IsMouseOver
If hw <> 0 And o Or hw = 0 Then
btn(0) = IIf(GetAsyncKeyState(VK_LBUTTON) And &H8000&, &H1, 0)
btn(1) = IIf(GetAsyncKeyState(VK_RBUTTON) And &H8000&, &H2, 0)
btn(2) = IIf(GetAsyncKeyState(VK_MBUTTON) And &H8000&, &H4, 0)
sft(0) = IIf(GetAsyncKeyState(VK_SHIFT) And &H8000&, &H1, 0)
sft(1) = IIf(GetAsyncKeyState(VK_CONTROL) And &H8000&, &H2, 0)
sft(2) = IIf(GetAsyncKeyState(VK_MENU) And &H8000&, &H4, 0)
d = 0
u = 0
For i = 0 To 2
If btn(i) <> 0 And btnOld(i) = 0 Then d = d + 1
Next
For i = 0 To 2
If btn(i) = 0 And btnOld(i) <> 0 Then u = u + 1
Next
If oldCurPos.X <> aCurPos.X Or oldCurPos.Y <> aCurPos.Y Or d > 0 Or u > 0 Then RaiseEvent MouseMove(ButtonState, ShiftState, aCurPos.X, aCurPos.Y)
If hw <> 0 And o And Not ovr Then RaiseEvent MouseOver(ButtonState, ShiftState, aCurPos.X, aCurPos.Y)
If d > 0 Then RaiseEvent MouseDown(ButtonState, ShiftState, aCurPos.X, aCurPos.Y)
If u > 0 Then RaiseEvent MouseUp(ButtonState, ShiftState, aCurPos.X, aCurPos.Y)
pmRtn = PeekMessage(ms, 0&, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE)
If pmRtn And ms.message = WM_MOUSEWHEEL Then
If LongToULong(ms.wParam) > MAXINT_4 Then
RaiseEvent MouseWheelDown(ButtonState, ShiftState, aCurPos.X, aCurPos.Y)
Else
RaiseEvent MouseWheelUp(ButtonState, ShiftState, aCurPos.X, aCurPos.Y)
End If
End If
TranslateMessage ms '今のところ
DispatchMessage ms '特に意味無し
oldCurPos = aCurPos
btnOld(0) = btn(0)
btnOld(1) = btn(1)
btnOld(2) = btn(2)
sftOld(0) = sft(0)
sftOld(1) = sft(1)
sftOld(2) = sft(2)
End If
If hw <> 0 And Not o And ovr Then RaiseEvent MouseOut(ButtonState, ShiftState, aCurPos.X, aCurPos.Y)
ovr = o
DoEvents
Sleep &H10&
Loop
End Sub
Private Sub Class_Initialize()
xDPI = GetDPI(LOGPIXELSX)
yDPI = GetDPI(LOGPIXELSY)
xlPPI = Application.InchesToPoints(1)
End Sub
Rem ************************************************************************************************************************
Rem [Userform1]モジュール (eijiさんのユーザーフォームに見立ててます。あらかじめ ListBox1 の配置が必要です)
Rem ************************************************************************************************************************
Option Explicit
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hwnd As LongPtr) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private WithEvents m As clsMouseEv, hList As LongPtr
Rem ------------------------------------------------------------------------------------------------------------------------
Private RowSourceRng As Range
Rem ************************************************************************************************************************
Private Sub m_MouseWheelDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
If Me.ActiveControl Is Me.ListBox1 Then
PostMessage hList, WM_KEYDOWN, VK_DOWN, 0
PostMessage hList, WM_KEYUP, VK_DOWN, 0
End If
End Sub
Private Sub m_MouseWheelUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
If Me.ActiveControl Is Me.ListBox1 Then
PostMessage hList, WM_KEYDOWN, VK_UP, 0
PostMessage hList, WM_KEYUP, VK_UP, 0
End If
End Sub
Private Sub UserForm_Activate()
Set m = New clsMouseEv
WindowFromAccessibleObject Me.ListBox1, hList
m.TargetWindow = hList
m.IsRunning = True
End Sub
Rem ------------------------------------------------------------------------------------------------------------------------
Private Sub UserForm_Initialize()
With Sheets(1).Range("AZ:BA")
Set RowSourceRng = Excel.Range(.Item(1, 2), .Item(.Rows.Count, 1).End(xlUp))
End With
RowSourceRngSortSet
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'''' UnhookListBoxScroll
m.IsRunning = False '←これ大事です(無限ループだし)
End Sub
Private Sub RowSourceRngSortSet()
With RowSourceRng
.Sort Key1:=.Item(1, 2), Order1:=xlAscending, Header:=xlGuess, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
Me.ListBox1.RowSource = RowSourceRng.Address(External:=True)
End Sub
''''Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'''' HookListBoxScroll
''''End Sub
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Len(ActiveCell.Value) = 0 Then
ActiveCell.Value = ListBox1.Value
Else
ActiveCell.Value = ActiveCell.Value & "･" & ListBox1.Value
End If
End Sub
（白茶） 2023/05/13(土) 21:53:03
クラスモジュールに、マクロを書くなんて初めてですね（しかもこんな短時間に！）
（ほかの方のデータは見たことありますが）classモジュール調べたり忙しい！
＞(んで光の速さで廃棄しましょう^^; )
とんでもない
折角ですので、いろいろなシーンで利用できそうです。(シコシコ頑張ります。)
多分理解はできないと思いますが、少しでも活用できるよういろいろ試してみます。
感謝・感激でございます。
ここまでしていただき本当にありがとうございました。(*^_^*)
（eiji） 2023/05/16(火) 18:40:45
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.