свой класс

[Naked]

создал свой класс, поместил на форму, вроде все нормально, но...
у него не обрабатывается большинство сообщений, таких как WM_SETFOCUS WM_KILLFOCUS WM_MOUSEWHEEL и т.д
в чем проблема?
и можно ли как-нибудь добавить сообщения?

[GSerg]

Название темы: твёрдая два.
Свой класс на форме - пять с плюсом. Достигнуто невозможное.
Описание проблемы: два. Не понятно ничего.

[Naked]

1. создаем свой класс

'module 1
Function Create(nLeft As Long, nTop As Long, nWidth As Long, nHeight As Long, nParent As Long) As Long
Dim hwnd As Long
Dim wndcls As WNDCLASS
wndcls.style = CS_DBLCLKS + CS_SAVEBITS
wndcls.lpfnwndproc = GetWndProc(AddressOf WndProc)
wndcls.hCursor = LoadCursor(0, IDC_ARROW)
wndcls.hbrBackground = 3
wndcls.lpszClassName = "xxx"
Call RegisterClass(wndcls)
hwnd = CreateWindowEx(0, "xxx", "", WS_CHILD Or WS_VISIBLE Or WS_CLIPSIBLINGS Or WS_CLIPCHILDREN, nLeft, nTop, nWidth, nHeight, nParent, 0, App.hInstance, ByVal 0&)
CreateClass = hwnd
Call UnregisterClass("xxx", App.hInstance)
End Function

Private Function WndProc(ByVal hwnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
select case message
case WM_SETFOCUS
form1.caption="setfocus"
case WM_KILLFOCUS
form1.caption="killfocus"
case WM_MOUSEWHEEL
form1.caption="mousewheel"
case else
WndProc = DefWindowProc(hwnd, message, wParam, lParam)
end select
End Function

'forma
2. Теперь помещаем на форму. Это делается примерно так

private sub form_load()
Create 0, 0, 100, 100, form1.hwnd
end sub

3. Запускаем и у нас необрабатываются сообщения, которые находятся в WndProc

почему они не обрабатываются, эти сообщения (и многие другие)?

надеюсь понятно будет

[beat_swamp]

может быть ты контрол создал?

[Viper]

Первое что бросается в глаза в этом "коде" - вызов функции UnregisterClass перед использованием класса.... И, кстати, что за функция такая GetWndProc?

[Kovu]

Первое что бросается в глаза в этом "коде" - вызов функции UnregisterClass перед использованием класса.... И, кстати, что за функция такая GetWndProc?

GetWndProc я так понимаю чтото вроде этого:

Код: Выделить всё

function GetWndProc(address as long) as long
GetWndProc=address
End function

2Naked А класс деригистрировать в принципе и не надо, т.к. ВБ во время закрытия делает это сам(т.к. у тя есть форма) .

[ANDLL]

1. CreateClass = hwnd -CreateClass не объявлен
2. UnregisterClass("xxx", App.hInstance) вернет ошибку, так как класс используеться
3. Вообще-то WndProc = DefWindowProc(hwnd, message, wParam, lParam) должно стоять вне всяких условий. Система должна же как-то обрабатывать сообщения.
4. А что этот код вообше по идее должен делать? Создавать одно окно внутри другого?

[Naked]

пишу как есть на самом деле (немножко изменил)

в VB создаю модуль класса, обзываю ClassXXX. В нем пишу
Option Explicit

Event Click()
Dim hwnd As Long
Dim hdc As Long
Dim ParentHwnd As Long
Dim mWndProcOrg As Long

Private Sub Hook(hwnd As Long)
mWndProcOrg = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf ProcXXX)
Call SetWindowLong(hwnd, GWL_USERDATA, ObjPtr(Me))
End Sub
Private Sub UnHook(hwnd As Long)
Call SetWindowLong(hwnd, GWL_WNDPROC, mWndProcOrg)
End Sub

Function Create(nLeft As Long, nTop as long, nWidth As Long, nHeight as long, nParent As Long) As Long
hwnd = CreateClass("xxx", "", COLOR_BTNFACE, CS_DBLCLKS + CS_PARENTDC, WS_CHILD Or WS_VISIBLE, 0, nLeft, nTop, nWidth, nHeight, nParent)
Call Hook(hwnd)
Create = hwnd
End Function

Private Sub Class_Terminate()
Call UnHook(hwnd)
Call DestroyWindow(hwnd)
End Sub

Friend Function WindowProc(ByVal hwnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case message
Case WM_LBUTTONDOWN
Call SetCapture(hwnd)
WindowProc = CallWindowProc(mWndProcOrg, hwnd, message, wParam, lParam)

Case WM_LBUTTONUP
Call ReleaseCapture
WindowProc = CallWindowProc(mWndProcOrg, hwnd, message, wParam, lParam)


Case WM_SETFOCUS
msgbox "SETFOCUS"
WindowProc = CallWindowProc(mWndProcOrg, hwnd, message, wParam, lParam)

Case WM_KILLFOCUS
msgbox "KILLFOCUS"
WindowProc = CallWindowProc(mWndProcOrg, hwnd, message, wParam, lParam)

Case Else
WindowProc = CallWindowProc(mWndProcOrg, hwnd, message, wParam, lParam)
End Select
End Function



Создаю модуль название не важно

Dim ctlXXX As ClassXXX
Dim ptrObject As Long

Function ProcXXX(ByVal hwnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
ptrObject = GetWindowLong(hwnd, GWL_USERDATA)
Call CopyMemory(ctlXXX, ptrObject, 4)
ProcXXX = ctlXXX.WindowProc(hwnd, message, wParam, lParam)
Call CopyMemory(ctlXXX, 0&, 4)
Set ctlXXX = Nothing
End Function

Function CreateClass(clsName As String, clsCaption As String, nBackgrd As Long, clsStyle As Long, nStyle As Long, nStyleEx As Long, nLeft As Long, nTop As Long, nWidth As Long, nHeight As Long, nParent As Long) As Long
Dim hwnd As Long
Dim wndcls As WNDCLASS
wndcls.style = clsStyle
wndcls.lpfnwndproc = GetWndProc(AddressOf WndProc)
wndcls.hInstance = App.hInstance
wndcls.hCursor = LoadCursor(0, IDC_ARROW)
wndcls.hbrBackground = nBackgrd
wndcls.lpszClassName = clsName
Call RegisterClass(wndcls)
hwnd = CreateWindowEx(nStyleEx, clsName, clsCaption, nStyle Or WS_CLIPSIBLINGS Or WS_CLIPCHILDREN, nLeft, nTop, nWidth, nHeight, nParent, 0, App.hInstance, ByVal 0&)
CreateClass = hwnd
Call UnregisterClass(clsName, App.hInstance)
End Function

Private Function WndProc(ByVal hwnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WndProc = DefWindowProc(hwnd, message, wParam, lParam)
End Function
Private Function GetWndProc(ByVal lWndProc As Long) As Long
GetWndProc = lWndProc
End Function


переходим к форме

Dim xxx As New ClassXXX

private sub form_load()
xxx.Create 0, 0, 100, 100, PalitraHwnd
end sub

ANDLL и ошибки вроде не выскакивают
ANDLL насчет 4 пункта, да, создается окно внутри другого

как только убираю WS_CHILD, все сообщения срабатывают, но при этом контрол не имеет родителя и болтается на рабочем столе

[ANDLL]

2Naked:У API-функции ошибки не "выскакивают". Их надо отлавливать.

[Naked]

каким способом?

[Viper]

1.

каким способом?

API-функции используют определенное возвращаемое значение указывающее на произошедшую ошибку. По конкретной функции смотри MSDN.

2. На кой тебе вызов UnregisterClass сразу же после его регистрации? Он же у тебя используется, а ты его пытаешься грохнуть...

З.Ы. Совет напоследок. Код плохо воспринимается, заключи его в теги VB

[ANDLL]

if UnregisterClass(clsName, App.hInstance)=0 then msgbox "Error!" & vbcrlf & err.lastdllerror

[Naked]

все?
больше никаких размышлений нет?

вот ошибка
ERROR_CLASS_HAS WINDOWS - 1412 Класс имеет открытые окна

и что мне это дает?

[GSerg]

Собственно, винда ткнула тебя носом в то, что ты пытаешься отрегистрировать класс, экземпляры которого существуют.
Что непонятно?

[ANDLL]

Касательно твоего вопроса: что бы отловить сообщения надо просто сабклассить свое окно, а не заниматься херомантией.

[Naked]

убрал я Call UnregisterClass(clsName, App.hInstance)
ничего не изменилось, все осталось на своих местах

ANDLL я и так сабкласю, все сообщения срабатывают, когда мое творение не имеет стиля WS_CHILD, но при этом оно болтается на рабочем столе.

[Kovu]

Код: Выделить всё

Private Sub Hook(hwnd As Long)
mWndProcOrg = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf ProcXXX)
Call SetWindowLong(hwnd, GWL_USERDATA, ObjPtr(Me))
End Sub
Private Sub UnHook(hwnd As Long)
Call SetWindowLong(hwnd, GWL_WNDPROC, mWndProcOrg)
End Sub

А что ты как-то по-китайски сабклассишь ?.
И зачем тебе сабклассить если сообщения будут приходить в процедуру класса