Помогите разобраться, есть два компьютера оба 64-bit , на одном компьютере работает без проблем , на другом выдает ошибку
Код
'''''' normal module code
#If VBA7 Then
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 LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As LongPtr
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 LongPtr
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 LongPtr
'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 LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) 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 Long
Private mComboBoxHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control
Dim n As Long
Sub HookComboBoxScroll(frm As Object, ctl As MSForms.Control)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor WindowFromPoint(tPT.X, tPT.Y)
If Not frm.ActiveControl Is ctl Then
ctl.SetFocus
End If
If mComboBoxHwnd <> hwndUnderCursor Then
UnhookComboBoxScroll
Set mCtl = ctl
mComboBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mComboBoxHwnd, GWL_HINSTANCE)
' PostMessage mComboBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End Sub
Sub UnhookComboBoxScroll()
If mbHook Then
Set mCtl = Nothing
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mComboBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As Long
Dim idx As Long
On Error GoTo errH
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mComboBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
' If lParam.hwnd > 0 Then
' PostMessage mComboBoxHwnd, WM_KEYDOWN, VK_UP, 0
' Else
' PostMessage mComboBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
' End If
' PostMessage mComboBoxHwnd, WM_KEYUP, VK_UP, 0
If lParam.hwnd > 0 Then idx = -1 Else idx = 1
' idx = idx + mCtl.ListIndex
' If idx >= 0 Then mCtl.ListIndex = idx
idx = idx + mCtl.TopIndex
If idx >= 0 Then mCtl.TopIndex = idx
Exit Function
End If
Else
UnhookComboBoxScroll
End If
End If
End As Variant
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookComboBoxScroll
End Function
'''''''' end normal module code
End As Variant
#End If
ошибка тут
Код
Sub HookComboBoxScroll(frm As Object, ctl As MSForms.Control)
WindowFromPoint
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByValnIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
#Else
Private Declare Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If
Код
Public 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
Код
Public Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Код
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) 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 Function apiGetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Private Declare Function apiSetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long
Private Declare PtrSafe Function apiGetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" (ByVal hWnd As LongLong, _
ByVal nIndex As LongLong) As LongLong
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hWnd As LongPtr, _
ByVal nIndex As LongPtr) As LongPtr
#End If
#ElseIf VBA6 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
#End If
почему PtrSafe везде?? он должен быть только для VBA7 пишите так:
Код
#If VBA7 Then
' все функции внутри одного IF !!! а то код нечитаемый
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
' ...
#Else
Private Declare Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
' ...
#End If
приведете код в нормальный вид, с учетом вышеописанного, - потом будем искать ошибку (если она останется)
berlusconi, для условия "#If VBA7" для типа "Long" нужно использовать "LongPtr", чтобы работало и в 32 и 64 разрядных. Потому что в 32-х разрядных нет типа данных "LongLong". Для условия "#Else" для типа "Long" нужно писать "Long", т.к. в "Excel 2007-", нет типа данных "LongPtr". Исправьте это и будет работать. Я исправил и у меня стало работать.
И структуры, если содержат специфический тип данных, тоже нужно помещать внутрь #If:
Скрытый текст
Код
#If VBA7 Then
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
#Else
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
#End If
Я сначала тестировал на 32-х разрядной - работает. На 64 не работает. Для данной ситуации нужно написать полностью один и тот же код и для условия #If VBA7 и для #Else. То есть заключаете внутри #If VBA7 не только api-функции и структуры, но и процедуры "HookComboBoxScroll" и т.д. И то же самое делаете для #Else. Это нужно, чтобы работало в 2003 - 2016. Если нужно, чтобы работало в 2010 - 2016, то проще - нужно у переменных и функций заменить тип данных из Long в LongPtr. В "2007-" нет LngPtr.
Игорь написал: потому что вы не привели код в порядок
Используйте отступы нормально, а не копипаста без понимания из разных мест. За Вас приходится заниматься чистописанием ибо читабельность никакая, а в чужом коде тем более. Если Вы не хотите разбираться, то и работать само по себе ничего не будет. Даже если за Вас сделали, то любое Ваше изменение и опять все равно придется разбираться, тем более, что MouseScroll капризная штука. Всего лишь надо было отследить передачу переменных с учетом типа (не забываем про тип функций). Сделал на скорую руку... Надеюсь ничего не проглядел...
AAF написал: сего лишь надо было отследить передачу переменных с учетом типа (не забываем про тип функций). Сделал на скорую руку... Надеюсь ничего не проглядел...
спасибо большое, пытаюсь разобраться, сейчас ошибки нету, но и MouseScroll не работает
Тогда стоит указывать где работает, а где нет. Вот, например, у меня нигде не осталось 2007 и я иногда забываю его учесть, но и проверить не могу. Но как правило рабочий код для таких офисов в интернете есть. На 2013x32 работает и на 2016x64 работает Место для кода 2007 офиса я сопроводил комментариями в сообщении 24