Сто лет назад что то делал такое... но смотрю все поломано и не работает... может что поможет...
Код: Выделить всё
MEMBER
OMIT('***', _C55_)
_ABCDllMode_ EQUATE(0)
_ABCLinkMode_ EQUATE(1)
***
INCLUDE('EQUATES.CLW'),ONCE
INCLUDE('KEYCODES.CLW'),ONCE
INCLUDE('xcbutton.inc'),ONCE
MAP
MODULE('Windows API')
xcb_GetWindowText(ULONG, *CSTRING, SIGNED),SIGNED,PROC,PASCAL,RAW,NAME('GetWindowTextA')
xcb_DrawIconEx(UNSIGNED hDC,SIGNED xLeft,SIGNED yTop,UNSIGNED hIcon,SIGNED cxWidth,SIGNED cyWidth,UNSIGNED iStepIfAniCur,UNSIGNED hbrFlickerFreeDraw,UNSIGNED diFlags),SIGNED,RAW,PASCAL,PROC,NAME('DrawIconEx')
xcb_LoadIcon(UNSIGNED,LONG),UNSIGNED,PASCAL,NAME('LoadIconA')
xcb_memcpy(LONG lpDest, LONG lpSource, LONG nCount),LONG,PROC,NAME('_memcpy')
xcb_CallWindowProc(LONG,LONG,LONG,LONG,LONG),LONG,PASCAL,NAME('CallWindowProcA')
xcb_SetWindowLong(LONG,LONG,LONG),LONG, PASCAL,NAME('SetWindowLongA')
xcb_GetWindowLong(LONG hWnd, signed nIndex),long,pascal,name('GetWindowLongA')
xcb_PostMessage(LONG,LONG,LONG,LONG),LONG,PASCAL,NAME('PostMessageA')
xcb_GetCursorPos(*xcb_TPnt),BOOL,RAW,PASCAL,PROC,NAME('GetCursorPos')
xcb_GetClientRect(LONG hWnd, *xcb_RECT lpRect),BOOL,RAW,PASCAL,PROC,NAME('GetClientRect')
xcb_ClientToScreen(LONG hWnd, *xcb_TPnt lpPOINT),BOOL,RAW,PASCAL,PROC,NAME('ClientToScreen')
xcb_GetSysColorBrush(unsigned nIndex),LONG,PASCAL,NAME('GetSysColorBrush')
xcb_FillRect(LONG hdc, *xcb_RECT lprc, LONG hbr),BOOL,RAW,PASCAL,NAME('FillRect')
xcb_DrawEdge(LONG hdc, *xcb_RECT qrc, unsigned edge, unsigned grfFlags),BOOL,RAW,PASCAL,PROC,NAME('DrawEdge')
xcb_LoadImage(LONG hinst, long lpszName, unsigned uType, signed cxDesired, |
signed cyDesired, unsigned fuLoad),LONG,PASCAL,RAW,NAME('LoadImageA')
xcb_DrawFocusRect(LONG hdc, *xcb_RECT lprc),BOOL,RAW,PASCAL,NAME('DrawFocusRect')
xcb_SendMessage(LONG hWnd, long nMsg, long wParam, long lParam),BYTE,PASCAL,PROC,NAME('SendMessageA')
xcb_GetProp(ULONG hWnd,*CSTRING lpString),ULONG,RAW,PASCAL,NAME('GetPropA')
xcb_RemoveProp(ULONG hWnd,*CSTRING lpString),ULONG,PROC,RAW,PASCAL,NAME('RemovePropA')
xcb_SetProp(ULONG hWnd,*CSTRING lpString,ULONG hData),BOOL,PROC,RAW,PASCAL,NAME('SetPropA')
END
DrawClassicStyleBtn(LONG theWindow,UNSIGNED,UNSIGNED,LONG),LONG
CWindowCallBack(UNSIGNED,UNSIGNED,UNSIGNED,LONG)LONG,PASCAL
CButtonCallBack(UNSIGNED,UNSIGNED,UNSIGNED,LONG)LONG,PASCAL
END
lPropNameClass CSTRING('LKWEHFKJ')
!******************************************************************************
! xCButton Class
!******************************************************************************
xCButtonClass.Construct PROCEDURE
CODE
SELF.Controls &= NEW xcb_ControlsQueue
!******************************************************************************
xCButtonClass.Destruct PROCEDURE
CODE
FREE(SELF.Controls)
DISPOSE(SELF.Controls)
!******************************************************************************
xCButtonClass.Init PROCEDURE(WINDOW Window)
CODE
SELF.Window &= Window
!SELF.PrevCallBack = xcb_SetWindowLong(Window{PROP:ClientHandle}, xcb_GWL_WNDPROC, ADDRESS(CWindowCallBack))
!******************************************************************************
xCButtonClass.Kill PROCEDURE
CODE
!******************************************************************************
xCButtonClass.AddControl PROCEDURE(LONG Feq, LONG ControlType=0, <LONG ControlID>)
CODE
IF ~xcb_SetProp(Feq{PROP:Handle}, lPropNameClass, ADDRESS(SELF))
MESSAGE('Error on set prop')
END
IF xcb_SetWindowLong(Feq{PROP:Handle}, xcb_GWL_USERDATA, ADDRESS(SELF)) END
SELF.Controls.WndProc = xcb_SetWindowLong(Feq{PROP:Handle}, xcb_GWL_WNDPROC, ADDRESS(CButtonCallBack))
IF xcb_SetWindowLong(Feq{PROP:Handle}, xcb_GWL_STYLE, xcb_GetWindowLong(Feq{PROP:Handle}, xcb_GWL_STYLE) + xcb_BS_OWNERDRAW) END
SELF.Controls.Handle = Feq{PROP:Handle}
SELF.Controls.Feq = Feq
SELF.Controls.ControlType = ControlType
IF OMITTED(4)
SELF.Controls.ControlID = SELF.ControlID
ELSE
SELF.Controls.ControlID = ControlID
END
SELF.ControlID += 100
ADD(SELF.Controls)
!******************************************************************************
xCButtonClass.GetCallBack PROCEDURE(LONG hWnd)!,LONG,PRIVATE
CODE
SELF.Controls.Handle = hWnd
GET(SELF.Controls, SELF.Controls.Handle)
!ASSERT(~ERRORCODE(),'Unable to get callback procedure address')
RETURN SELF.Controls.WndProc
!******************************************************************************
xCButtonClass.GetWCallBack PROCEDURE()!,LONG,PRIVATE
CODE
RETURN SELF.PrevCallBack
!******************************************************************************
xCButtonClass.TakeAccepted PROCEDURE(USHORT ActionID, <LONG hWnd>, <LONG Wparam>, <LONG Lparam>)!,VIRTUAL
CODE
!******************************************************************************
xCButtonClass.AfterAccepted PROCEDURE(LONG hWnd)
CODE
SELF.Controls.Handle = hWnd
GET(SELF.Controls, SELF.Controls.Handle)
ASSERT(~ERRORCODE(),'Unable to get record')
SELF.Controls.PopupPresent = 0
PUT(SELF.Controls)
ASSERT(~ERRORCODE(),'Unable to put record')
IF xcb_SendMessage(hWnd, xcb_REFRESH, 0, 0)
END
!******************************************************************************
xCButtonClass.GetActionID PROCEDURE(LONG hWnd, LONG LocalAction)!,LONG
CODE
SELF.Controls.Handle = hWnd
GET(SELF.Controls, SELF.Controls.Handle)
ASSERT(~ERRORCODE(),'Unable to get record')
RETURN SELF.Controls.ControlID+LocalAction
!******************************************************************************
xCButtonClass.GetProp PROCEDURE(LONG hWnd, BYTE PropID)!,LONG
CODE
SELF.Controls.Handle = hWnd
GET(SELF.Controls, SELF.Controls.Handle)
ASSERT(~ERRORCODE(),'Unable to get record')
CASE PropID
OF 1
RETURN SELF.Controls.PopupPresent
END
ASSERT(1=2,'Unable to get this property')
!******************************************************************************
xCButtonClass.SetProp PROCEDURE(LONG hWnd, BYTE PropID, LONG Prop)
CODE
SELF.Controls.Handle = hWnd
GET(SELF.Controls, SELF.Controls.Handle)
ASSERT(~ERRORCODE(),'Unable to get record')
CASE PropID
OF 1
SELF.Controls.PopupPresent = Prop
END
PUT(SELF.Controls)
ASSERT(~ERRORCODE(),'Unable to put record')
!******************************************************************************
xCButtonClass.Msg PROCEDURE
CODE
MESSAGE('Msg!')
!******************************************************************************
! Other procedures
!******************************************************************************
CButtonCallBack PROCEDURE(theWindow, theMessage, theWparam, theLparam)
TPnt LIKE(xcb_TPnt)
rcClient LIKE(xcb_RECT)
CB &xCButtonClass,AUTO
CODE
CB &= xcb_GetWindowLong(theWindow, xcb_GWL_USERDATA)
IF xcb_GetCursorPos(TPnt) END
xcb_GetClientRect(theWindow, rcClient)
xcb_ClientToScreen(theWindow, rcClient)
IF theMessage = xcb_WM_GETDLGCODE
RETURN xcb_DLGC_WANTARROWS
END
CASE theMessage
OF xcb_WM_DRAWITEM OROF xcb_REFRESH
RETURN DrawClassicStyleBtn(theWindow, theMessage, theWparam, theLparam)
OF xcb_WM_LBUTTONDOWN
! кнопу нажали
IF TPnt.XPos >= (rcClient.left+(rcClient.right-CB.HeightRB)) AND TPnt.XPos <= (rcClient.left + rcClient.right) AND |
TPnt.YPos >= rcClient.top AND TPnt.YPos <= (rcClient.top + rcClient.bottom)
IF CB.GetProp(theWindow,1) = 1
CB.SetProp(theWindow,1,0)
ELSE
CB.SetProp(theWindow,1,1)
END
END
OF xcb_WM_LBUTTONUP
IF TPnt.XPos >= (rcClient.left+(rcClient.right-CB.HeightRB)) AND TPnt.XPos <= (rcClient.left + rcClient.right) AND |
TPnt.YPos >= rcClient.top AND TPnt.YPos <= (rcClient.top + rcClient.bottom)
IF CB.GetProp(theWindow,1) = 1
CB.TakeAccepted(CB.GetActionID(theWindow, 2),theWindow,rcClient.left,rcClient.top+rcClient.bottom)
END
ELSE
IF TPnt.XPos >= (rcClient.left) AND TPnt.XPos <= (rcClient.left + rcClient.right) AND |
TPnt.YPos >= rcClient.top AND TPnt.YPos <= (rcClient.top + rcClient.bottom)
CB.TakeAccepted(CB.GetActionID(theWindow, 1),theWindow,theWparam,theLparam)
END
END
OF xcb_WM_KEYUP
CB.SetProp(theWindow,1,0)
IF theWparam = xcb_VK_SPACE ! OR theWparam = xcb_VK_RETURN
CB.TakeAccepted(CB.GetActionID(theWindow, 1),theWindow,theWparam,theLparam)
END
OF xcb_WM_KEYDOWN
IF theWparam = xcb_VK_DOWN
IF CB.GetProp(theWindow,1) = 1
CB.SetProp(theWindow,1,0)
ELSE
CB.SetProp(theWindow,1,1)
END
CB.TakeAccepted(CB.GetActionID(theWindow, 2),theWindow,rcClient.left,rcClient.top+rcClient.bottom)
END
END
RETURN xcb_CallWindowProc(CB.GetCallBack(theWindow), theWindow, theMessage, theWparam, theLparam)
!******************************************************************************
CWindowCallBack PROCEDURE(theWindow, theMessage, theWparam, theLparam)
CB &xCButtonClass,AUTO
CODE
!CB &= xGButtonClass.GetAddress(theWindow)
CB &= xcb_GetProp(theWindow,lPropNameClass)
CASE theMessage
OF xcb_WM_DRAWITEM OROF xcb_REFRESH
RETURN DrawClassicStyleBtn(theWindow, theMessage, theWparam, theLparam)
ELSE
END
RETURN xcb_CallWindowProc(CB.GetWCallBack(), theWindow, theMessage, theWparam, theLparam)
!******************************************************************************
DrawClassicStyleBtn PROCEDURE(LONG theWindow, theMessage, theWparam, theLparam)!,LONG
CB &xCButtonClass,AUTO
tpis LIKE(xcb_DrawItemStruct)
pis &tpis
uState LONG(xcb_DSS_NORMAL)
uEdge LONG(xcb_EDGE_RAISED)
bFocus BYTE(FALSE)
rFocus LIKE(xcb_RECT)
Deflate BYTE(4)
BkBrush LONG
hDC LONG
IconName CSTRING(100)
hIcon LONG
IXPos USHORT
IYPos USHORT
CODE
CB &= xcb_GetWindowLong(theWindow, xcb_GWL_USERDATA)
pis &= (theLparam)
BkBrush = xcb_GetSysColorBrush(xcb_COLOR_BTNFACE)
IF xcb_FillRect(pis.hDC, pis.rcItem, BkBrush) END
CASE pis.itemAction
OF xcb_ODA_SELECT
IF BAND(pis.itemState, xcb_ODS_SELECTED)
uEdge = xcb_EDGE_SUNKEN
END
DO SetFocus
OF xcb_ODA_DRAWENTIRE
IF BAND(pis.itemState, xcb_ODS_DISABLED)
!uEdge = xcb_DSS_DISABLED
END
DO SetFocus
OF xcb_ODA_FOCUS
DO SetFocus
END
pis.rcItem.right -= CB.HeightRB
xcb_DrawEdge(pis.hDC, pis.rcItem, uEdge, xcb_BF_RECT);
IF CB.GetProp(theWindow,1) = 1
uEdge = xcb_EDGE_SUNKEN
ELSE
uEdge = xcb_EDGE_RAISED
END
pis.rcItem.right += CB.HeightRB
pis.rcItem.left = pis.rcItem.right - CB.HeightRB
xcb_DrawEdge(pis.hDC, pis.rcItem, uEdge, xcb_BF_RECT);
IconName = 'XCB_DROP_ICO'
hIcon = xcb_LoadImage(SYSTEM{PROP:AppInstance},ADDRESS(IconName),xcb_IMAGE_ICON,16,16,xcb_LR_SHARED)
IF hIcon
IXPos = pis.rcItem.left + ((CB.HeightRB/2)-8)
IYPos = pis.rcItem.top + ((pis.rcItem.bottom/2)-8)
IF BAND(pis.itemState,xcb_ODS_SELECTED) AND NOT BAND(pis.itemState,xcb_ODS_DISABLED)
xcb_DrawIconEx(pis.hDC,IXPos,IYPos,hIcon,0,0,0,0,xcb_DI_NORMAL)
ELSE
xcb_DrawIconEx(pis.hDC,IXPos-1,IYPos-1,hIcon,0,0,0,0,xcb_DI_NORMAL)
END
END
IF bFocus = TRUE
IF xcb_DrawFocusRect(pis.hDC, rFocus) END
END
RETURN TRUE
SetFocus ROUTINE
IF BAND(pis.itemState, xcb_ODS_FOCUS)
xcb_memcpy(ADDRESS(rFocus), ADDRESS(pis.rcItem), SIZE(xcb_RECT));
rFocus.left += deflate
rFocus.top += deflate
rFocus.right -= (deflate+CB.HeightRB)
rFocus.bottom -= deflate
bFocus = TRUE
END
а там написано, как можно указать хэндл иконки?