Results of 1 - 1 of about 37655 for IF (0.008 sec.)
- [[20230502164009]]
- #score: 1592
- @digest: e68ea4a97a3d2039b40fbd6aae08a1e8
- @id: 94161
- @mdate: 2023-05-16T09:40:45Z
- @size: 87930
- @type: text/plain
- #keywords: mlistboxhwnd (440675), longptr (342333), mlngmousehook (246956), hwndundercursor (229117), windowfrompoint (219520), postmessage (213197), getpicture (199958), unhooklistboxscroll (186158), mouseproc (183453), mbhook (174435), acurpos (161773), pictdesc (159983), lngappinst (159899), ptrsafe (153712), pointapi (146890), cblonglong (135330), mousewheel (130171), lparam (122560), pointtolonglong (120184), handle (116796), wparam (113846), lbuttondown (112474), pictype (108570), setwindowshookex (108570), mousehookstruct (103331), hinstance (95670), callnexthookex (95375), declare (93360), user32 (89928), xlbitmap (87654), longlong (84150), enhmetafile (77638)
- 『画像取り込みについて』（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 ＞ ---- olepro32.dll 32 64 で検索したらこんなんでました。 関係あるか分かりませんけど。 https://www.google.com/amp/s/software.opensquare.net/relaxtools/archives/1916/amp/ （MK） 2023/05/02(火) 16:58:39 ---- （MK）さん ありがとうございます。 紹介サイト検索済みで貼付マクロも対応できているみたいです。 ＞Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" _ ↑こちらの部分と思われます。 （eiji） 2023/05/02(火) 17:37:12 ---- 追加説明になりますが、同一book上に画像が貼り付けてありこの画像を ユーザーフォームのImage1.Pictureに表示させているマクロです。 ＞ ActiveSheet.Shapes("図 1").Copy ＞ Image1.Picture = GetPicture(xlPicture) ↑64bitは、対応できないのでしょうかね （eiji） 2023/05/02(火) 17:43:33 ---- 分かんないですけど「ファイルが無い」って言われてる以上、まずはソコの検証が先ではないでしょうか? ↓ちょっと式を見比べてみました。 ■ご提示の式 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 ---- （白茶）さん ありがとうございます。 以下修正しマクロ実行したところ ★部分黄色反転し ●部分 desc 部分がエラー エラー内容 「コンパイルエラー ByRef引数の型が一致しません」です。 以下マクロ修正内容です。よろしくお願いします 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 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 ---- （白茶）さん ありがとうございます。 う〜あ〜 うまくいきませんね コンパイルラー引数は省略できませんは変化ありません ↓違いますか? Public Function GetPicture(ByVal Format As XlCopyPictureFormat, ByRef lpPictDesc As PictDesc) 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 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 ---- （白茶）さん 対応、ありがとうございます。 64bit環境が現在利用できないため後日連絡いたします。 よろしくお願いします。 （eiji） 2023/05/03(水) 02:00:45 ---- （白茶）さん ありがとうございました。 マクロ通りました、感謝です。 64bitに変更したら動かないものばかりで困りました。 もう一つ困っているのですが見てもらえますか? 以下 ユーザーフォームのListBox1のマウススクロール可能なマクロです。 ★部分の AddressOf MouseProc これが反転し コンパイルエラー型が一致しません 何度もすみませんがよろしくお願いします。 32bitExcelでは、問題なく動作していました。 標準モジュール 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 ---- 追記説明 以下 アップ忘れました フォームモジュール 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 （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 ---- （あみな）さん ありがとうございます。 現在のPCは、32bitなので64bitは検証できませんが 32bitはちゃんと動いています。 64bitは明後日以降でないと操作できませんが、昨日操作した結果が↓でした。 ＞★部分の AddressOf MouseProc これが反転し コンパイルエラー型が一致しません すみませんシートモジュールは間違えていました。 以下になります シートモジュール 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 ---- （あみな）さん ありがとうございます。 エラーでした。 ★ ・WH_MOUSE_LL ・GWL_HINSTANCE 2ヵ所 型が一致しません。でましたが Longに戻したとこエラー解消しましたが どうしても AddressOf MouseProc 黄色反転は 型が一致しません。 これだけは私の能力では分かりませんでした。 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 'X座標 Y As LongPtr 'Y座標 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 ---- （あみな）さん いろいろ調べていただきありがとうございます。 なぜ、（あみな）さんの環境では実行できるのか不思議です当方のPC状況 複数台64bit 新規購入しセットアップしたのですが全てエラーが出てしまいました。 また、64bitへ変更したのは32bit版でエディター操作後たびたび「メモリ不足」と出てしまうので 導入したわけですがAPIでこんなことになるとは予測できませんでした。参った参った・・・ いろいろ確認後返信させてください。 （白茶）さん 最初の画像取込の件ありがとうございました。 また、見ていただき感謝いたします。 いろんな所ググっているのですが、見れば見るほどとんでもない質問したと反省<(_ _)> ちょっと難しくてついて行けません。とりあえずアップ頂いたもので確認させてください。 ＞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 ---- （白茶）さん ありがとうございます。 ネットでググっていたら全く同じ内容のものがありました。が やはり同様のエラーが出るのは分かりましたが、解決には至ったいないようです。 64bitって良いところないのですかね? https://social.msdn.microsoft.com/Forums/en-US/8b06b7a3-2ee0-4fc4-9bb5-293da29e81d0/compile-error-type-mismatch?forum=isvvba#8b06b7a3-2ee0-4fc4-9bb5-293da29e81d0 マクロを整理をし、再度実行しましたが ★部分 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 ---- （hensuu）さん ありがとうございます。 定義できていると思うのですが↓ Private mListBoxHwnd As LongPtr ほかに原因あるのでは? 分かりませんが違います? （eiji） 2023/05/08(月) 16:55:50 ---- （白茶）さん 掲示いただいたリンク先のAPIいろいろ挑戦中です また、報告いたします。 （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 ---- （白茶）さん ＞会社で64bit版の入ったマシンを使わせて貰ったんだぜぃ マシンを借りてまで対応して頂き本当にありがとうございました。 うぉ-無事、当方の64bitくん動いてくれました。(^^)ここ2日間ほどWeb検索したり API 64bit調べたりしてましたが、難しくて難しくて 一夜漬けではダメですね 多少ですが、64bitの対応が解ってきました。が （白茶）さんが前述で（あみな）さんも言っておられましたが、 本当に詳しい方でなんですね。助かりました。 また、何かありましたら相談させてください。 ありがとうございました。 （eiji） 2023/05/11(木) 16:52:01 ---- おー、待ってました。無事動いた様で良かったっス。 >本当に詳しい方でなんですね いやいや、実は特に「詳しい人」って訳じゃないんですよね (詳しそうな「ふり」して遊んでるだけで ^^;) コールバック自体使った事なかったし。 ミスったらすぐハングしたりクラッシュしたりするんで、あんまり使う気になれなかったんですが、 今回勉強するいい機会を与えて頂きました。 まだ私自身よく理解出来ていない(体感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 ---- （白茶）さん またまた、すごいですね（ユーザーフォームのみでOKですか） 使い方が、いまいちピンときません。です 確かにスクロールは確認できましたが 一度、ユーザーフォームをクリックしないとスクロールしないので・・・ 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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202305/20230502164009.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97039 documents and 608037 words.
訪問者：