-Rem
-bbdoc: MaxGUI Drivers/Win32MaxGUIEx
-End Rem
-Module MaxGUI.Win32MaxGUIEx
-
-ModuleInfo "Version: 0.75"
-ModuleInfo "Author: Simon Armstrong, Seb Hollington"
-ModuleInfo "License: zlib/libpng"
-
-Strict
-
-?Win32
-Import MaxGUI.MaxGUI
-Import "winimports.bmx"
-
-' Import "xpmanifest.o"
-
-maxgui_driver = New TWindowsGUIDriver
-
-Type TWindowsGUIDriver Extends TMaxGUIDriver
-
- Global GadgetMap:TMap
- Global GDIDesktop:TWindowsDesktop
- Global GDIFont:TWindowsFont
- Global ClassAtom
- Global ClassAtom2
- Global KBMessageHook,MouseMessageHook
-
- Global windowtheme:Short Ptr
- Global _cursor, _commoncontrolversion[]
- Global _explorerstyle = False
- Global _activeWindow:TWindowsWindow = Null
-
- Global _customcolors[] = [$FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, ..
- $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF ]
-
- Global _hwndTooltips%
-
- Global intDontReleaseCapture% = False 'See WM_CAPTURECHANGED
-
- Method New()
-
- 'Initialize libraries
- OleInitialize(Null)
- Local icc:TINITCOMMONCONTROLSEX = New TINITCOMMONCONTROLSEX
- icc.dwSize = SizeOf(icc)
- icc.dwICC = ICC_WIN95_CLASSES|ICC_USEREX_CLASSES'|ICC_COOL_CLASSES'|ICC_DATE_CLASSES
- InitCommonControlsEx icc
-
- 'Initialize Global Variables
- GDIFont=TWindowsFont.DefaultFont()
- GadgetMap=New TMap
- GDIDesktop=New TWindowsDesktop
-
- 'Set-up Message Hooks
- KBMessageHook=SetWindowsHookExW(WH_KEYBOARD,KeyboardProc,GetModuleHandleW(Null),GetCurrentThreadId())
- MouseMessageHook=SetWindowsHookExW(WH_MOUSE,MouseProc,GetModuleHandleW(Null),GetCurrentThreadId())
-
- 'Gadget Tooltips
- _hwndTooltips = CreateWindowExW( 0,"tooltips_class32","",WS_POPUP|TTS_ALWAYSTIP,0,0,0,0,GDIDesktop._hwnd,0,GetModuleHandleW(Null),Null )
- SendMessageW( _hwndTooltips, TTM_SETMAXTIPWIDTH, 0, 300 )
- SetWindowPos( _hwndTooltips, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE | SWP_NOACTIVATE )
-
- EndMethod
-
- Method Delete()
- DestroyWindow( _hwndTooltips );_hwndTooltips = 0
- UnhookWindowsHookEx MouseMessageHook
- UnhookWindowsHookEx KBMessageHook
- EndMethod
-
- Method UserName$()
- Return getenv_("username")
- End Method
-
- Method ComputerName$()
- Return getenv_("userdomain")
- End Method
-
- 'Low-level Win32 interface
-
- Function RegisterHwnd(hwnd,gadget:TWindowsGadget)
- GadgetMap.Insert TIntWrapper.Create(hwnd),gadget
- EndFunction
-
- Function RemoveHwnd(hwnd)
- GadgetMap.Remove TIntWrapper.Create(hwnd)
- EndFunction
-
- Function GadgetFromHwnd:TWindowsGadget(hwnd) nodebug
- Return TWindowsGadget(GadgetMap.ValueForKey(TIntWrapper.Create(hwnd)))
- EndFunction
-
- Function ClassWndProc(hwnd,msg,wp,lp) "win32"
- Local owner:TWindowsGadget
- Local res
- Local nmhdr:Int Ptr
-
- '?Debug And Win32
- 'Print TWindowsDebug.ReverseLookupMsg(msg) + ", hwnd: " + hwnd + ", wp: " + wp + ", lp: " + lp
- '?Win32
-
- Select msg
-
- Case WM_MENUCHAR
-
- If HotKeyEventFromWp(wp & $FF) Then
- Return (MNC_CLOSE Shl 16)
- Else
- Return (MNC_IGNORE Shl 16)
- EndIf
-
- Case WM_SIZE
-
- owner = GadgetFromHwnd(hwnd)
- If owner And Not TWindowsWindow(owner) Then
- If hwnd = owner.Query(QUERY_HWND) Then owner.RethinkClient()
- If hwnd = owner.Query(QUERY_HWND_CLIENT) Then owner.LayoutKids()
- EndIf
-
- Case WM_CTLCOLORSTATIC, WM_CTLCOLOREDIT, WM_CTLCOLORBTN
-
- owner=GadgetFromHwnd(lp)
-
- Select True
-
- Case TWindowsLabel(owner) <> Null
-
- SetBkMode(wp, TRANSPARENT)
- If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())
- Return owner.CreateControlBrush( owner._hwnd, wp )
-
- Case TWindowsPanel(owner) <> Null
-
- If TWindowsPanel(owner)._type = TWindowsPanel.PANELGROUP Then
-
- SetBkMode(wp, TRANSPARENT)
- If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())
- Return owner.CreateControlBrush( lp, wp )
-
- EndIf
-
- Case TWindowsTextField(owner) <> Null, TWindowsComboBox(owner) <> Null
-
- If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())
- If owner.BgBrush() Then SetBkColor(wp, owner.BgColor());Return owner.BgBrush()
-
- Case TWindowsButton(owner) <> Null, TWindowsSlider(owner) <> Null
-
- SetBkMode(wp, TRANSPARENT)
- If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())
- Return owner.CreateControlBrush( owner._hwnd, wp )
-
- EndSelect
-
- owner = Null
-
- Case WM_COMMAND,WM_HSCROLL,WM_VSCROLL
- If lp Then
- owner=GadgetFromHwnd(lp)
- 'Fix for tab control's up/down arrow.
- If Not owner Then owner = GadgetFromHwnd(GetParent_(lp))
- Else
- owner=GadgetFromHwnd(hwnd) 'Fixed for menu events
- EndIf
-
- If Not owner Then owner = GadgetFromHwnd(hwnd)
-
- If owner Then
- res=owner.OnCommand(msg,wp)
- If Not res And owner._proc And owner._hwnd = hwnd Return CallWindowProcW(owner._proc,hwnd,msg,wp,lp)
- Return res
- Else
- Return DefWindowProcW( hwnd,msg,wp,lp )
- EndIf
-
- Case WM_NOTIFY
-
- 'Gadget tooltips
- nmhdr=Int Ptr(lp)
- owner=GadgetFromHwnd(nmhdr[0])
- If owner Then
- Select nmhdr[2]
- Case TTN_GETDISPINFOW
- If owner._wstrTooltip Then nmhdr[3] = Int(owner._wstrTooltip)
- EndSelect
- Return owner.OnNotify(wp,lp)
- EndIf
-
- Case WM_SETCURSOR
-
- If _cursor Then
- SetCursor(_cursor)
- Return 1
- EndIf
-
- Case WM_ACTIVATEAPP, WM_ACTIVATE
-
- SystemEmitOSEvent(hwnd,msg,wp,lp,Null)
-
- Case WM_DRAWITEM
-
- Local tmpDrawItemStruct:DRAWITEMSTRUCT = New DRAWITEMSTRUCT
- MemCopy tmpDrawItemStruct, Byte Ptr lp, SizeOf(tmpDrawItemStruct)
-
- owner = GadgetFromHwnd(tmpDrawItemStruct.hwndItem)
- If owner And owner.OnDrawItem( tmpDrawItemStruct ) Then Return True
-
- owner = Null
-
- 'Allow BRL.System to handle mouse/key events on sensitive gadgets.
-
- Case WM_CAPTURECHANGED
-
- 'For preventing problem where controls which called SetCapture() internally
- 'had their capture prematurely released by the ReleaseCapture() call in BRL.System.
- intDontReleaseCapture = False
- 'If SetCapture() is called again after BRL.System's call (when the new
- 'capture hwnd [lp] = old hwnd [hwnd]) then we dont want to call ReleaseCapture() in BRL.System
- 'when WM_MOUSEBUTTONUP is received by the system hook TWindowsGUIDriver.MouseProc().
- If (lp = hwnd) And (Not intEmitOSEvent) Then intDontReleaseCapture = True
-
- Default
-
- 'Added preliminary check to avoid searching for a gadget in GadgetMap un-necessarily.
- If (msg = WM_MOUSEWHEEL) Or (msg = WM_MOUSELEAVE) Or (msg>=WM_KEYFIRST And msg<=WM_KEYLAST) Then
- owner=GadgetFromHwnd(hwnd)
- If owner Then
- Select msg
- Case WM_MOUSELEAVE, WM_MOUSEWHEEL
- If (owner.sensitivity&SENSITIZE_MOUSE) Then SystemEmitOSEvent hwnd,msg,wp,lp,owner
- Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP, WM_CHAR, WM_SYSCHAR
- If (owner.sensitivity&SENSITIZE_KEYS) And Not GadgetDisabled(owner) Then
- SystemEmitOSEvent hwnd,msg,wp,lp,owner
- EndIf
- If (msg<>WM_CHAR And msg<>WM_SYSCHAR) And HotKeyEventFromWp(wp) Then Return 1
- EndSelect
- EndIf
- EndIf
-
- EndSelect
-
- If Not owner Then owner=GadgetFromHwnd(hwnd)
- If owner Return owner.WndProc(hwnd,msg,wp,lp)
-
- Return DefWindowProcW( hwnd,msg,wp,lp )
-
- EndFunction
-
- Function KeyboardProc( code,wparam,lparam ) "win32" nodebug
- Local ev:TEvent, hwnd%, tmpClassName:Short[16], mods:Int, key:Int = wparam
- If code>=0 Then
- 'Removed: http://www.blitzbasic.com/Community/posts.php?topic=72737
-' Rem
- If wparam = $D Then '$D: VK_RETURN
- hwnd = GetFocus()
- If hwnd And GetClassNameW(hwnd,tmpClassName,tmpClassName.length) And String.FromWString(tmpClassName).ToUpper() = "EDIT" Then
- SetFocus(GetParent_(hwnd))
- EndIf
- EndIf
-' EndRem
-
- ev = HotkeyEventFromWp(wparam)
- If ev
- 'Hot-key events shouldn't be emitted if the source gadget is disabled
- If Not(TGadget(ev.source) And GadgetDisabled(TGadget(ev.source))) Then
- If Not (lparam & $80000000) Then
- EmitEvent ev
- If ev.mods Then Return 1 'Key press events never reach active panels etc. if we return 1
- EndIf
- EndIf
- EndIf
- EndIf
- Return CallNextHookEx( KBMessageHook,code,wparam,lparam );
- EndFunction
-
- Function HotkeyEventFromWp:TEvent(wparam)
- Local key = wparam, mods = KeyMods()
- Select wparam
- Case VK_SHIFT, $A0, $A1
- If (wparam=VK_SHIFT) Then key = KEY_LSHIFT
- mods:&~MODIFIER_SHIFT
- Case VK_CONTROL, $A2, $A3
- If (wparam=VK_CONTROL) Then key = KEY_LCONTROL
- mods:&~MODIFIER_CONTROL
- Case VK_MENU, $A4, $A5
- If (wparam=VK_MENU) Then key = KEY_LALT
- mods:&~MODIFIER_ALT
- Case VK_LWIN, VK_RWIN
- mods:&~MODIFIER_SYSTEM
- EndSelect
- Return HotKeyEvent( key,mods,GetForegroundWindow() )
- EndFunction
-
- Global intButtonStates%[3]
-
- Function MouseProc( code,wparam,lparam ) "win32" nodebug
-
- If code>=0 And wparam >= WM_MOUSEFIRST And wparam <= WM_MOUSELAST Then 'Not needed as MouseProc only receives mouse messages!!!
-
- Local MOUSEHOOKSTRUCT:Int Ptr = Int Ptr(lparam), wp, lp, data
- Local hwnd% = MOUSEHOOKSTRUCT[2], msg% = wparam, owner:TWindowsGadget
- Local point:Int[] = [MOUSEHOOKSTRUCT[0],MOUSEHOOKSTRUCT[1]]
-
- Select msg
- Case WM_LBUTTONDOWN, WM_LBUTTONDBLCLK
- data = MOUSE_LEFT
- msg = WM_LBUTTONDOWN
- intButtonStates[MOUSE_LEFT] = True
- Case WM_LBUTTONUP
- data = MOUSE_LEFT
- intButtonStates[MOUSE_LEFT] = False
- Case WM_RBUTTONDOWN, WM_RBUTTONDBLCLK
- data = MOUSE_RIGHT
- msg = WM_RBUTTONDOWN
- intButtonStates[MOUSE_RIGHT] = True
- Case WM_RBUTTONUP
- data = MOUSE_RIGHT
- intButtonStates[MOUSE_RIGHT] = False
- Case WM_MBUTTONDOWN, WM_MBUTTONDBLCLK
- data = MOUSE_MIDDLE
- msg = WM_MBUTTONDOWN
- intButtonStates[MOUSE_MIDDLE] = True
- Case WM_MBUTTONUP
- data = MOUSE_MIDDLE
- intButtonStates[MOUSE_MIDDLE] = False
- EndSelect
-
- owner = GadgetFromHwnd(hwnd)
- If owner And ScreenToClient( hwnd, point ) Then
-
- If data And (Not intButtonStates[data]) And TGadget.dragGadget[data-1] Then
- PostGuiEvent EVENT_GADGETDROP, owner, data, KeyMods(), point[0], point[1], TGadget.dragGadget[data-1]
- TGadget.dragGadget[data-1] = Null
- EndIf
-
- If (owner.sensitivity&SENSITIZE_MOUSE) Then
-
- 'Fake wp parameter to pass onto bbSystemEmitOSEvent
- If intButtonStates[MOUSE_LEFT] Then wp:|MK_LBUTTON
- If intButtonStates[MOUSE_MIDDLE] Then wp:|MK_MBUTTON
- If intButtonStates[MOUSE_RIGHT] Then wp:|MK_RBUTTON
- If GetKeyState(VK_SHIFT)&$8000 Then wp:|MK_SHIFT
- If GetKeyState(VK_CONTROL)&$8000 Then wp:|MK_CONTROL
-
- lp = (Short(point[1]) Shl 16) | Short(point[0])
- 'Sort and determine whether to emit the event
- Select msg
- Case WM_MOUSEMOVE
- If (owner._oldcursorlp<>lp) Then
- owner._oldcursorlp=lp
- SystemEmitOSEvent hwnd,msg,wp,lp,owner
- EndIf
- Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP
- If intDontReleaseCapture Then
- PostGuiEvent EVENT_MOUSEUP, owner, data
- Else
- SystemEmitOSEvent hwnd,msg,wp,lp,owner
- EndIf
- Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
- SystemEmitOSEvent hwnd,msg,wp,lp,owner
- EndSelect
-
- EndIf
- EndIf
- EndIf
- Return CallNextHookEx( MouseMessageHook,code,wparam,lparam )
- EndFunction
-
- Global intEmitOSEvent
-
- Function SystemEmitOSEvent( hwnd, msg, wp, lp, owner:TGadget )
- intEmitOSEvent:+1
- If owner Then
- While owner.source
- owner = owner.source
- Wend
- EndIf
- Local tmpResult% = bbSystemEmitOSEvent( hwnd, msg, wp, lp, owner )
- intEmitOSEvent:-1
- Return tmpResult
- EndFunction
-
- Function ClassName$()
- Global _name$
- Global _wc:WNDCLASSW
- Global _icon
-
- If Not _name
- _name="BLITZMAX_WINDOW_CLASS"
- _icon=LoadIconW(GetModuleHandleW(Null),Short Ptr(101))
- _wc=New WNDCLASSW
- _wc.style=CS_OWNDC|CS_HREDRAW|CS_VREDRAW
- _wc.lpfnWndProc=ClassWndProc
- _wc.hInstance=GetModuleHandleW(Null)
- _wc.hIcon=_icon
- _wc.hCursor=LoadCursorW( 0,Short Ptr( IDC_ARROW ) )
- _wc.hbrBackground=COLOR_BTNSHADOW
- _wc.lpszMenuName=Null
- _wc.lpszClassName=_name.ToWString()
- _wc.cbWndExtra=DLGWINDOWEXTRA
- ClassAtom=RegisterClassW(_wc)
- EndIf
- Return _name
- EndFunction
-
- Function DialogClassName$()
- Global _dname$
- Global _dc:WNDCLASSW
-
- If Not _dname
- _dname="BLITZMAX_DIALOG_CLASS"
- _dc=New WNDCLASSW
- _dc.style=CS_OWNDC|CS_HREDRAW|CS_VREDRAW
- _dc.lpfnWndProc=ClassWndProc
- _dc.hInstance=GetModuleHandleW(Null)
- _dc.hCursor=LoadCursorW( 0,Short Ptr( IDC_ARROW ) )
- _dc.hbrBackground=COLOR_BTNSHADOW
- _dc.lpszMenuName=Null
- _dc.lpszClassName=_dname.ToWString()
- _dc.cbWndExtra=DLGWINDOWEXTRA
- ClassAtom2=RegisterClassW(_dc)
- EndIf
- Return _dname
- EndFunction
-
- 'TMaxGuiDriver interface
-
- Method CreateGadget:TGadget(class,Text$,x,y,w,h,group:TGadget,style)
-
- Select class
- Case GADGET_WINDOW
- If Not group group=GDIDesktop
- End Select
-
- Local gadget:TGadget = GadgetInstanceFromClass(class,group,style,Text)
-
- Select class
- Case GADGET_DESKTOP, GADGET_MENUITEM, GADGET_NODE
- Return gadget
- End Select
-
- If LocalizationMode() & LOCALIZATION_OVERRIDE Then
- LocalizeGadget(gadget,Text,"")
- Else
- gadget.SetText(Text)
- EndIf
-
- If group Then gadget._SetParent group
- If class <> GADGET_TOOLBAR Then gadget.SetShape(x,y,w,h)
-
- 'v0.51: Gadgets are now only shown when they have been sized, and the text set.
- If TWindowsGadget(gadget) Then
- If Not TWindowsWindow(gadget)
- gadget.SetFont(GDIFont)
- If TWindowsGadget(group) Then
- TWindowsGadget(gadget)._forceDisable = Not( TWindowsGadget(group)._enabled And Not TWindowsGadget(group)._forceDisable )
- gadget.SetEnabled(Not (gadget.State()&STATE_DISABLED))
- EndIf
- gadget.SetShow(True)
- ElseIf Not (style & WINDOW_HIDDEN) Then
- gadget.SetShow(True)
- EndIf
- EndIf
-
- If TWindowsGadget(gadget) Then TWindowsGadget(gadget).Sensitize()
-
- Return gadget
- EndMethod
-
- Method GadgetInstanceFromClass:TGadget(class, group:TGadget, style = 0, Text$ = "")
-
- Local gadget:TGadget
-
- Select class
- Case GADGET_DESKTOP
- gadget=GDIDesktop
- Case GADGET_MENUITEM
- gadget=New TWindowsMenu.Create(group,style,Text)
- Case GADGET_WINDOW
- gadget=New TWindowsWindow.Create(group,style)
- Case GADGET_BUTTON
- gadget=New TWindowsButton.Create(group,style)
- Case GADGET_TEXTFIELD
- gadget=New TWindowsTextField.Create(group,style,Text)
- Case GADGET_TEXTAREA
- gadget=New TWindowsTextArea.Create(group,style)
- Case GADGET_COMBOBOX
- gadget=New TWindowsComboBox.Create(group,style,Text)
- Case GADGET_LISTBOX
- gadget=New TWindowsListBox.Create(group,style)
- Case GADGET_TOOLBAR
- gadget=New TWindowsToolBar.Create(group,style,Text)
- Case GADGET_TABBER
- gadget=New TWindowsTabber.Create(group,style)
- Case GADGET_NODE
- gadget=New TWindowsTreeNode.Create(group,style,Text)
- Case GADGET_TREEVIEW
- gadget=New TWindowsTreeView.Create(group,style)
- Case GADGET_LABEL
- gadget=New TWindowsLabel.Create(group,style)
- Case GADGET_SLIDER
- gadget=New TWindowsSlider.Create(group,style)
- Case GADGET_PROGBAR
- gadget=New TWindowsProgressBar.Create(group,style)
- Case GADGET_PANEL
- gadget=New TWindowsPanel.Create(group,style)
- Case GADGET_CANVAS
- gadget=New TWindowsPanel.Create(group,style|PANEL_CANVAS|PANEL_ACTIVE)
- Case GADGET_HTMLVIEW
- gadget=New TWindowsHTMLView.Create(group,style)
- End Select
-
- Return gadget
-
- EndMethod
-
- Method ActiveGadget:TGadget()
- Local tmpHwnd:Int = GetFocus(), tmpGadget:TGadget
- While tmpHwnd
- tmpGadget = GadgetFromHwnd( tmpHwnd )
- If tmpGadget Then Exit
- tmpHwnd = GetParent_(tmpHwnd)
- Wend
- Return tmpGadget
- EndMethod
-
- Method RequestColor(red,green,blue)
- Local cc:CHOOSECOLOR = New CHOOSECOLOR
- cc.lStructSize=SizeOf(cc)
- cc.hwndOwner=GetActiveHwnd()
- cc.rgbResult=(red)|(green Shl 8)|(blue Shl 16)
- cc.lpCustColors=_customcolors
- cc.Flags=CC_RGBINIT|CC_FULLOPEN|CC_ANYCOLOR
- Local hwnd = GetFocus()
- Local n = ChooseColorW(cc)
- SetFocus(hwnd)
- If Not n Return 0
- n = ((cc.rgbResult Shr 16)&$ff) | (cc.rgbResult&$ff00) | ((cc.rgbResult Shl 16)&$ff0000)
- Return n|$ff000000
- EndMethod
-
- Method LookupColor( colorindex:Int, red:Byte Var, green:Byte Var, blue:Byte Var )
-
- Select colorindex
- Case GUICOLOR_WINDOWBG
- colorindex = COLOR_BTNFACE
- Case GUICOLOR_GADGETBG
- colorindex = COLOR_WINDOW
- Case GUICOLOR_GADGETFG
- colorindex = COLOR_WINDOWTEXT
- Case GUICOLOR_LINKFG
- colorindex = COLOR_HOTLIGHT
- Case GUICOLOR_SELECTIONBG
- colorindex = COLOR_HIGHLIGHT
- Default
- Return Super.LookupColor( colorindex, red, green, blue )
- EndSelect
-
- Local tmpColor:Int = GetSysColor( colorindex )
- red = tmpColor & $FF
- green = (tmpColor Shr 8) & $FF
- blue = (tmpColor Shr 16) & $FF
-
- Return True
-
- EndMethod
-
- Method LoadFont:TGuiFont(name$,size,flags)
- Return New TWindowsFont.Load(name,Double(size),flags)
- EndMethod
-
- Method LoadFontWithDouble:TGuiFont(name$,size:Double,flags)
- Return New TWindowsFont.Load(name,size,flags)
- EndMethod
-
- Method LibraryFont:TGuiFont( pFontType% = GUIFONT_SYSTEM, pFontSize:Double = 0, pFontStyle% = FONT_NORMAL )
- If pFontType = GUIFONT_SYSTEM Then Return TWindowsFont.DefaultFont( pFontSize, pFontStyle ) Else Return Super.LibraryFont( pFontType, pFontSize, pFontStyle )
- EndMethod
-
- Method RequestFont:TGuiFont(font:TGuiFont)
- Return TWindowsFont.Request(font)
- EndMethod
-
- Method SetPointer(shape)
- Global winptrs[]=[0,32512,32513,32514,32515,32516,32642,32643,32644,32645,32646,32648,32649,32650,32651]
- If shape<1 Or shape>14 Then _cursor = LoadCursorW( 0,Short Ptr( IDC_ARROW ) ) Else _cursor=LoadCursorW(0,Short Ptr(winptrs[shape]))
- SetCursor(_cursor)
- If TWindowsTextArea._oldCursor Then TWindowsTextArea._oldCursor = _cursor
- If shape = 0 Then _cursor = 0
- EndMethod
-
- Method LoadIconStrip:TIconStrip(source:Object)
- Return TWindowsIconStrip.Create(source)
- EndMethod
-
- Function CheckCommonControlVersion() 'Returns True if supports alpha/themes etc. or False if not.
- If Not _commoncontrolversion Then
- Local libComCtl = LoadLibraryW("comctl32.dll")
- Local GetCommonControlVersion( pDllVersionInfo:Byte Ptr ) "win32" = GetProcAddress(libComCtl, "DllGetVersion")
- If GetCommonControlVersion Then
- Local tmpDllVersion:DLLVERSIONINFO2 = New DLLVERSIONINFO2
- GetCommonControlVersion( tmpDllVersion )
- _commoncontrolversion = [tmpDllVersion.dwMajorVersion,tmpDllVersion.dwMinorVersion,tmpDLLVersion.dwBuildNo]
- EndIf
- GetCommonControlVersion = Null
- FreeLibrary( libComCtl )
- EndIf
- If _commoncontrolversion And _commoncontrolversion[0] >= 6 Then
- If (_commoncontrolversion[0] > 6) Or (_commoncontrolversion[1] > 0) Then Return 2 Else Return 1
- EndIf
- EndFunction
-
- Function GetThemeHandle(hwnd, pClass$ = "WINDOW")
- If OpenThemeData And CheckCommonControlVersion() Then Return OpenThemeData(hwnd, pClass)
- EndFunction
-
- Function CloseThemeHandle(hTheme)
- If CloseThemeData Then Return CloseThemeData(hTheme)
- EndFunction
-
- Function CreateExplorerStyleGadgets( pDisable = False )
- _explorerstyle = (pDisable <> True)
- EndFunction
-
- Function GetActiveHwnd()
- If _activeWindow Then Return _activeWindow._hwnd Else Return GetActiveWindow()
- EndFunction
-
-EndType
-
-Type TWindowsGadget Extends TGadget
-
- 'Flag that determines whether gadgets should redraw when they are resized (see Rethink()).
- Global _resizeRedraw = True
-
- 'Generic Unicode Strings to prevent memory-leak
- Global _wstrEmpty:Short Ptr = "".ToWString()
- Global _wstrSpace:Short Ptr = " ".ToWString()
- Global _wstrExplorer:Short Ptr = "Explorer".ToWString()
-
- 'Important gadget fields that store OS control handles etc..
-
- Field _class, _hwnd, _hwndclient, _tooltips
- Field _proc(hwnd,msg,wp,lp) "win32"
- Field _hotkey:THotKey
- Field _oldcursorlp 'Should track events
-
- Field _sensitive% = False 'Determines whether gadgets should generate events.
- 'Not to be confused with the sensitivity field of TGadget
- 'which specifies which type of events are fired.
-
- 'Aesthetics
- Field _bgbrush, _fgcolor = -1, _bgcolor = -1 'Background colour
- Field _hbrush, _hbitmap 'Background colour
- Field _bitmap 'Background bitmap
- Field _iconBitmap 'Icon bitmap
- Field _hTheme 'Open handle to XP Theme API (for use in button's WM_DRAWITEM etc.)
- Field _font:TWindowsFont 'Font (needs to be stored, otherwise it may be collected by GC)
- Field _wstrTooltip:Short Ptr, _toolAdded = False
- Field _clientX:Int, _clientY:Int, _enabled:Int = True, _forcedisable:Int = False
-
- Method Create:TWindowsGadget(group:TGadget, style, Text$="") Abstract
-
- Method SetColor(red,green,blue)
- If _bgbrush Then DeleteObject _bgbrush
- _bgcolor = (blue Shl 16) | (green Shl 8) | red
- _bgbrush=CreateSolidBrush(_bgcolor)
- RedrawGadget(Self)
- EndMethod
-
- Method RemoveColor()
- If _bgbrush Then DeleteObject _bgbrush
- _bgbrush=0
- RedrawGadget(Self)
- EndMethod
-
- Method FgColor()
- Return _fgcolor
- EndMethod
-
- Method BgColor()
- Return _bgcolor
- EndMethod
-
- Method BgBrush()
- Return _bgbrush
- EndMethod
-
- Method SetTextColor(r,g,b)
- _fgcolor = (b Shl 16) | (g Shl 8) | r
- RedrawGadget(Self)
- EndMethod
-
- Method Query(queryid)
- Select queryid
- Case QUERY_HWND
- Return _hwnd
- Case QUERY_HWND_CLIENT
- If _hwndclient Return _hwndclient
- Return _hwnd
- End Select
- EndMethod
-
- Method Register(class,hwnd,hwndclient=0,tips=False)
- _class=class
- _hwnd=hwnd
- _hwndclient=hwndclient
- TWindowsGUIDriver.RegisterHwnd(_hwnd,Self)
- If _hwndclient TWindowsGUIDriver.RegisterHwnd(_hwndclient,Self)
- Local atom=GetClassLongW(hwnd,GCW_ATOM)
- If atom<>TWindowsGUIDriver.ClassAtom And atom<>TWindowsGUIDriver.ClassAtom2 And Not _proc
- _proc=Byte Ptr(SetWindowLongW(hwnd,GWL_WNDPROC,Int Byte Ptr TWindowsGUIDriver.ClassWndProc))
- EndIf
- If tips Then SetupToolTips()
- EndMethod
-
- Method SetupToolTips()
- If _tooltips Then DestroyWindow _tooltips;TWindowsGUIDriver.RemoveHwnd(_tooltips);_tooltips = 0
- _tooltips = CreateWindowExW( 0,"tooltips_class32","",TTS_ALWAYSTIP,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,_hwnd,0,GetModuleHandleW(Null),Null )
- SendMessageW _tooltips,TTM_SETMAXTIPWIDTH,0,300
- TWindowsGUIDriver.RegisterHwnd( _tooltips, Self )
- EndMethod
-
- Method isTabbable()
- Local style:Int = GetWindowLongW(_hwnd,GWL_STYLE)&(WS_TABSTOP|WS_CHILD)
- Return (style=(WS_TABSTOP|WS_CHILD))
- EndMethod
-
- Method isControl()
- Return (GetWindowLongW(_hwnd,GWL_STYLE)&(WS_CHILD)=WS_CHILD)
- EndMethod
-
- Method Activate(cmd)
- Select cmd
- Case ACTIVATE_FOCUS
- If isTabbable()
- DefDlgProcW GetParent_(_hwnd),WM_NEXTDLGCTL,_hwnd,1
- Return 1
- EndIf
- Return SetFocus(_hwnd)
- Case ACTIVATE_BACK
- Return SendMessageW(_hwnd,WM_NEXTDLGCTL,1,0)
- Case ACTIVATE_FORWARD
- Return SendMessageW(_hwnd,WM_NEXTDLGCTL,0,0)
- Case ACTIVATE_REDRAW
- RefreshLook()
- Return RedrawWindow( _hwnd, Null, Null, RDW_INVALIDATE | RDW_ERASE | RDW_FRAME | RDW_ALLCHILDREN )
- End Select
- EndMethod
-
- Method Rethink()
- QueueResize(_hwnd,xpos,ypos,width,height)
- EndMethod
-
- Method RethinkClient(forceRedraw:Int = False)
- EndMethod
-
- Method SetArea(x,y,w,h)
- SetRect(x,y,w,h)
- Rethink()
- EndMethod
-
- Method LayoutKids()
-
- StartResize()
-
- 'Implemented hack to speed-up drawing considerably...
- Local tmpOldState = TWindowsGadget._resizeredraw
- TWindowsGadget._resizeredraw = False
-
- 'Child windows are laid-out like normal...
- Super.LayoutKids()
-
- 'Reposition all child gadgets together.
- EndResize()
-
- 'If this control is the first parent who started the resizing, then redraw parent and all controls now.
- If tmpOldState Then
- If (Not kids.IsEmpty()) Then Activate(ACTIVATE_REDRAW)
- TWindowsGadget._resizeredraw = True
- EndIf
-
- EndMethod
-
- Method ClientWidth()
- Local Rect[] = [xpos,ypos,xpos+width,ypos+height]
- SendMessageW Query(QUERY_HWND), WM_NCCALCSIZE, False, Int Byte Ptr Rect
- Return Rect[2]-Rect[0]-_clientX
- EndMethod
-
- Method ClientHeight()
- Local Rect[] = [xpos,ypos,xpos+width,ypos+height]
- SendMessageW Query(QUERY_HWND), WM_NCCALCSIZE, False, Int Byte Ptr Rect
- Return Rect[3]-Rect[1]-_clientY
- EndMethod
-
- Method SetText(Text$)
- Desensitize()
- SetWindowTextW _hwnd, Text
- Sensitize()
- EndMethod
-
- Method GetText$()
- Local strText:Short[GetWindowTextLengthW(_hwnd)+1] 'Must include NULL terminator.
- GetWindowTextW _hwnd, strText, strText.length
- Return String.FromWString( strText )
- EndMethod
-
- Method SetFont(font:TGuiFont)
- If TWindowsFont(font) Then _font = TWindowsFont(font) Else _font = TWindowsGUIDriver.GDIFont
- SendMessageW _hwnd,WM_SETFONT,font.handle,1
- EndMethod
-
- Method SetShow(show)
- If show
- ShowWindow _hwnd,SW_SHOW
- Else
- 'Requester fix - ShowWindow activates the last activated window when an active window is hidden, so if
- 'a file requester/child gadget was the last window to be activated, then the program will lose focus as it is
- 'trying to activate a non-existent window.
- If parent And HasDescendant(ActiveGadget()) Then ActivateGadget(parent)
- ShowWindow _hwnd,SW_HIDE
- EndIf
- EndMethod
-
- Method SetEnabled(enable)
- _enabled = enable
- enable = enable And Not _forceDisable
- If Not((EnableWindow(_hwnd,enable)<>0) ~ enable) Then
- For Local tmpGadget:TWindowsGadget = EachIn kids
- tmpGadget._forceDisable = Not enable
- If tmpGadget.isControl() Then tmpGadget.SetEnabled(tmpGadget._enabled)
- Next
- EndIf
- EndMethod
-
- Method SetTooltip( pTooltip$ )
-
- If _wstrTooltip Then MemFree _wstrTooltip;_wstrTooltip = Null
-
- Local tmpToolInfo:TOOLINFOW = New TOOLINFOW
- tmpToolInfo.cbSize = SizeOf(tmpToolInfo)
- tmpToolInfo.hwnd = GetParent_(_hwnd)
- tmpToolInfo.hinst = GetModuleHandleW(Null)
- tmpToolInfo.uID = _hwnd
-
- If pTooltip Then
- _wstrTooltip = pTooltip.Replace("~r","").Replace("~n","~r~n").ToWString()
-
- tmpToolInfo.uFlags = TTF_IDISHWND|TTF_TRANSPARENT|TTF_SUBCLASS
- tmpToolInfo.lpszText = _wstrTooltip
-
- If Not _toolAdded Then
- _toolAdded = SendMessageW(TWindowsGUIDriver._hwndTooltips, TTM_ADDTOOLW, 0, Int Byte Ptr tmpToolInfo)
- Else
- SendMessageW(TWindowsGUIDriver._hwndTooltips, TTM_UPDATETIPTEXTW, 0, Int Byte Ptr tmpToolInfo)
- EndIf
- ElseIf _tooladded Then
- SendMessageW(TWindowsGUIDriver._hwndTooltips, TTM_DELTOOLW, 0, Int Byte Ptr tmpToolInfo )
- _toolAdded = 0
- EndIf
-
- EndMethod
-
- Method GetTooltip$()
- If _wstrTooltip Then Return String.FromWString(_wstrTooltip)
- EndMethod
-
- Method State()
- Local t, style = GetWindowLongW(_hwnd, GWL_STYLE)
- If Not (style&WS_VISIBLE) Then t:|STATE_HIDDEN
- If Not _enabled Then t:|STATE_DISABLED
- Return t
- EndMethod
-
- Method Free()
- If _tooltips Then DestroyWindow _tooltips;_tooltips=0
- SetTooltip("") 'Free any tooltip memory allocations
- If _hwnd Then DestroyWindow _hwnd;TWindowsGUIDriver.RemoveHwnd(_hwnd);_hwnd=0
- If _hwndclient Then TWindowsGUIDriver.RemoveHwnd(_hwndclient);_hwndclient=0
- FlushBrushes(False)
- If _hotKey Then RemoveHotKey(_hotKey);_hotKey = Null
- If _iconBitmap Then DeleteObject(_iconBitmap);_iconBitmap = 0
- If _bitmap Then DeleteObject(_bitmap);_bitmap = 0
- If _bgbrush Then DeleteObject(_bgbrush);_bgbrush = 0
- If _htheme Then TWindowsGUIDriver.CloseThemeHandle(_hTheme);_hTheme = 0
- _font = Null
- _SetParent Null
- EndMethod
-
- Method OnNotify(wp,lp)
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- Case WM_WINDOWPOSCHANGING
- FlushBrushes()
- EndSelect
- If _proc And _hwnd = hwnd Then
- Return CallWindowProcW(_proc,hwnd,msg,wp,lp) 'fixed auto scrollbars
- EndIf
- Return DefWindowProcW( hwnd,msg,wp,lp )
- EndMethod
-
- Method OnCommand(msg,wp)
- EndMethod
-
- Method OnDrawItem( pDrawItemStruct:DRAWITEMSTRUCT )
- EndMethod
-
- Method SetHotKey(key,modifier)
- Local ev:TEvent = CreateEvent( EVENT_GADGETACTION,Self )
- If _hotKey Then RemoveHotKey(_hotKey);_hotKey = Null
- If key Then _hotkey=SetHotKeyEvent(key,modifier,ev,FindGadgetWindowHwnd(Self))
- EndMethod
-
- 'Slow back-up code for mimicking transparency for PANEL_GROUPs and when
- 'DrawThemeParentBackground() is not available (i.e. on Windows 9x/2000).
- Method CreateControlBrush( hWndControl, hdc = 0 )
-
- Local xOffset, yOffset
- Local hwndWindow = GetParent_(hwndControl)
- Local rectWindow[4], rectControl[4], rectClient[4]
-
- If _hbrush Then Return _hbrush
-
- If BgBrush() Then
- If hdc Then SetBkColor(hdc, BgColor())
- Return BgBrush()
- EndIf
-
- Local tmpDC = GetDC( hwndWindow )
-
- 'Fix required to offset background when controls are drawn with WS_EX_CLIENTEDGE (e.g. panel with PANEL_SUNKEN/PANEL_RAISED set)
- If GetWindowLongW(hwndWindow,GWL_EXSTYLE)&(WS_EX_CLIENTEDGE|WS_EX_WINDOWEDGE) Then
- xOffset = -GetSystemMetrics(SM_CXEDGE)
- yOffset = -GetSystemMetrics(SM_CYEDGE)
- EndIf
-
- GetClientRect( hwndControl, rectClient )
- GetWindowRect( hwndWindow, rectWindow )
- GetWindowRect( hwndControl, rectControl )
-
- Local x = rectControl[0]-rectWindow[0]
- Local y = rectControl[1]-rectWindow[1]
- Local w = rectControl[2]-rectControl[0]
- Local h = rectControl[3]-rectControl[1]
-
- Local dcBitmap = CreateCompatibleDC( tmpDC )
- Local bkgndBitmap = CreateCompatibleBitmap( tmpDC, rectWindow[2]-rectWindow[0], rectWindow[3]-rectWindow[1] )
- SelectObject( dcBitmap, bkgndBitmap )
-
- 'InvalidateRect( hwndWindow, Null, False )
- SendMessageW hwndWindow, WM_ERASEBKGND, dcBitmap, 0
-
- Local bkgndClientBitmap = CreateCompatibleBitmap( tmpDC, w, h )
- Local dcClientBitmap = CreateCompatibleDC( tmpDC )
- SelectObject( dcClientBitmap, bkgndClientBitmap )
-
- BitBlt( dcClientBitmap, 0,0 , w, h, dcBitmap, x+xOffset, y+yOffset, ROP_SRCCOPY )
-
- DeleteObject( bkgndBitmap )
- DeleteDC( dcBitmap )
- DeleteDC( dcClientBitmap )
-
- _hbrush = CreatePatternBrush( bkgndClientBitmap )
- _hbitmap = bkgndClientBitmap
-
- ReleaseDC( hwndWindow, tmpDC )
-
- Return _hbrush
-
- EndMethod
-
- 'Clears the parent background brushes.
- Method FlushBrushes(pRecurse:Int = True)
- Local tmpChanges:Int = 0
- If _hbrush Then
- DeleteObject( _hbrush )
- _hbrush = 0
- tmpChanges:|True
- EndIf
- If _hBitmap Then
- DeleteObject( _hBitmap )
- _hBitmap = 0
- tmpChanges:|True
- EndIf
- Return tmpChanges
- EndMethod
-
- 'Method that returns a brush for drawing backgrounds.
- Method DrawBackground( hdc, hwnd )
-
- If BgBrush() Then SetBkColor(hdc, BgColor());Return BgBrush()
-
- Return DrawParentBackground( hdc, hwnd )
-
- EndMethod
-
- 'Another method which mimics transparency on Windows Controls.
- Function DrawParentBackground( hdc, hwndControl, pForceHack = False )
-
- Local rectWindow[4], rectControl[4], rectClient[4]
- Local hwndWindow = GetParent_(hwndControl)
-
- GetClientRect( hwndControl, rectClient )
- GetClientRect( hwndWindow, rectWindow )
- GetWindowRect( hwndControl, rectControl )
-
- 'Ensures that the the drawing context is returned in exactly the same state that it was passed.
- Local tmpSaveState = SaveDC( hdc )
-
- If DrawThemeParentBackground And Not pForceHack Then
-
- DrawThemeParentBackground(hwndControl,hdc,rectClient)
-
- Else 'Again, slow back-up code in case DrawThemeParentBackground() is not available.
-
- Local tmpDC, xOffset, yOffset
-
- 'Fix required to offset background when controls are drawn with WS_EX_CLIENTEDGE (e.g. panel with PANEL_BORDER set)
- If GetWindowLongW(hwndWindow,GWL_EXSTYLE)&WS_EX_CLIENTEDGE Then
- xOffset = -GetSystemMetrics(SM_CXEDGE)
- yOffset = -GetSystemMetrics(SM_CYEDGE)
- EndIf
-
- tmpDC = GetDC( hwndWindow )
-
- ScreenToClient( hwndWindow, rectControl )
- ScreenToClient( hwndWindow, Int Ptr (rectControl)+2 )
-
- Local x = rectControl[0]+rectClient[0]
- Local y = rectControl[1]+rectClient[1]
- Local w = rectClient[2]-rectClient[0]
- Local h = rectClient[3]-rectClient[1]
-
- Local bkgndBitmap = CreateCompatibleBitmap( tmpDC, rectWindow[2]-rectWindow[0], rectWindow[3]-rectWindow[1] )
- Local dcBitmap = CreateCompatibleDC( tmpDC )
- SelectObject( dcBitmap, bkgndBitmap )
-
- InvalidateRect( hwndWindow, Null, False )
- SendMessageW hwndWindow, WM_ERASEBKGND, dcBitmap, 0
-
- BitBlt( hdc, 0,0 , w, h, dcBitmap, x+xOffset, y+yOffset, ROP_SRCCOPY )
-
- DeleteObject( bkgndBitmap )
- DeleteDC( dcBitmap )
- ReleaseDC( hwndWindow, tmpDC )
-
- EndIf
-
- 'Ensures that the the drawing context is returned in exactly the same state that it was passed.
- RestoreDC( hdc, tmpSaveState )
-
- Return GetStockObject( NULL_BRUSH )
-
- EndFunction
-
- Method Sensitize()
- _sensitive = True
- EndMethod
-
- Method DeSensitize()
- _sensitive = False
- EndMethod
-
- Method PostGuiEvent( pID%, pData%=0, pMods%=0, pX%=0, pY%=0, pExtra:Object = Null)
-
- Select True
- Case TWindowsListBox(Self) <> Null, TWindowsTabber(Self) <> Null, TWindowsToolbar(Self) <> Null, TWindowsCombobox(Self) <> Null
- If pData>-1 Then
- If (ItemFlags(pData) & GADGETITEM_TOGGLE) Then SelectItem(pData,2)
- EndIf
- End Select
-
- If _sensitive Then MaxGUI.MaxGUI.PostGuiEvent( pID, Self, pData, pMods, pX, pY, pExtra )
-
- EndMethod
-
- 'Resize Methods
-
- Field hdwpStruct
-
- Method StartResize()
- If Not hdwpStruct Then
- Local tmpCount = kids.Count()
- If tmpCount Then hdwpStruct = BeginDeferWindowPos( tmpCount )
- EndIf
- EndMethod
-
- Method QueueResize( hwnd, xpos, ypos, width, height )
- If parent And GetParent_(hwnd) = parent.Query(QUERY_HWND_CLIENT) And TWindowsGadget(parent).hdwpStruct Then
- Local tmpFlags = SWP_NOOWNERZORDER | SWP_NOZORDER | SWP_NOACTIVATE' | SWP_NOCOPYBITS
- If Not _resizeRedraw Then tmpFlags:| SWP_NOREDRAW
- TWindowsGadget(parent).hdwpStruct = DeferWindowPos( TWindowsGadget(parent).hdwpStruct, hwnd, Null, xpos, ypos, width, height, tmpFlags )
- Else
- MoveWindow( hwnd, xpos, ypos, width, height, _resizeRedraw )
- HasResized()
- EndIf
- EndMethod
-
- Method EndResize()
- If hdwpStruct Then
- EndDeferWindowPos( hdwpStruct );hdwpStruct = 0
- For Local tmpGadget:TWindowsGadget = EachIn kids
- Sensitize()
- tmpGadget.HasResized()
- Next
- EndIf
- EndMethod
-
- 'Required for resizing columns in listboxes (has to be done outside WM_SIZE)
- Method HasResized()
- EndMethod
-
- 'Required to ensure problematic controls are updated when parent aesthetics are changed:
- Method RefreshLook()
- FlushBrushes(False)
- For Local tmpGadget:TWindowsGadget = EachIn kids
- tmpGadget.RefreshLook()
- Next
- EndMethod
-
-Rem
- Method StartDoubleBuffer()
- For Local tmpGadget:TWindowsGadget = EachIn kids
- tmpGadget.StartDoubleBuffer()
- Next
- EndMethod
-
- Method EndDoubleBuffer()
- For Local tmpGadget:TWindowsGadget = EachIn kids
- tmpGadget.EndDoubleBuffer()
- Next
- EndMethod
-EndRem
-EndType
-
-
-Type TWindowsDesktop Extends TWindowsGadget
-
- Method New()
- Local Rect[4]
- Local hwnd = GetDesktopWindow()
- Register(GADGET_DESKTOP,hwnd,0,False)
- GetClientRect hwnd,Rect
- SetShape 0,0,Rect[2]-Rect[0],Rect[3]-Rect[1]
- EndMethod
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Return Self
- EndMethod
-
- Method SetTooltip( pTooltip$ )
- 'Shouldn't have tool-tips.
- EndMethod
-
- Method Free()
- 'Can't be free'd.
- EndMethod
-
- Method Class()
- Return GADGET_DESKTOP
- EndMethod
-
- Method ClientHeight()
- Local Rect[4]
- If Super.ClientHeight() = height And SystemParametersInfoW( SPI_GETWORKAREA, 0, Int Byte Ptr Rect, 0 )
- Return Rect[3]-Rect[1]
- Else
- Return Super.ClientHeight()
- EndIf
- EndMethod
-
- Method ClientWidth()
- Local Rect[4]
- If Super.ClientWidth() = width And SystemParametersInfoW( SPI_GETWORKAREA, 0, Int Byte Ptr Rect, 0 )
- Return Rect[2]-Rect[0]
- Else
- Return Super.ClientWidth()
- EndIf
- EndMethod
-
-EndType
-
-Type TWindowsWindow Extends TWindowsGadget
-
- Field _wstyle, _xstyle
- Field _minwidth,_minheight,_maxwidth = -1,_maxheight = -1
- Field _menu:TWindowsMenu
- Field _hmenu
- Field _status
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local hwnd, parent, client
- Local classname$ = TWindowsGUIDriver.ClassName()
-
- Self.style = style
- _wstyle=WS_CLIPSIBLINGS|WS_CLIPCHILDREN
- If group Then parent = group.Query(QUERY_HWND)
-
- If (style&WINDOW_TITLEBAR)
- _wstyle:|WS_OVERLAPPED|WS_SYSMENU
- If style&WINDOW_RESIZABLE _wstyle:|WS_MINIMIZEBOX|WS_MAXIMIZEBOX
- If group <> TWindowsGUIDriver.GDIDesktop And Not (style&WINDOW_TOOL) Then
- classname$ = TWindowsGUIDriver.DialogClassName()
- _xstyle:|WS_EX_DLGMODALFRAME
- EndIf
- Else
- _wstyle:|WS_POPUP
- EndIf
-
- If style&WINDOW_RESIZABLE Then _wstyle:|WS_SIZEBOX
- If style&WINDOW_MENU Then _hmenu=CreateMenu_();AppendMenuW( _hmenu,MF_STRING,Null,_wstrEmpty )
- If style&WINDOW_TOOL Then _xstyle:|WS_EX_TOOLWINDOW
-
- ' Note: No WINDOW_HIDDEN case as gadgets are always created hidden to hide initial resize flicker.
- ' TWindowsGUIDriver.CreateGadget() will later show window if WINDOW_HIDDEN is not specified.
-
- hwnd=CreateWindowExW(_xstyle,classname,"",_wstyle,0,0,0,0,parent,_hmenu,GetModuleHandleW(Null),Null)
-
- If style&WINDOW_STATUS
- _status=CreateWindowExW(0,"msctls_statusbar32","",WS_CHILD|WS_VISIBLE,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null)
- SetWindowPos( _status, HWND_TOPMOST,0,0,0,0,SWP_NOACTIVATE|SWP_NOMOVE|SWP_NOOWNERZORDER|SWP_NOSIZE)
- EndIf
-
- client=CreateWindowExW(0,TWindowsGUIDriver.ClassName(),"",WS_CHILD|WS_VISIBLE|WS_CLIPCHILDREN|WS_CLIPSIBLINGS,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null)
-
- Register GADGET_WINDOW,hwnd,client,False
-
- If style&WINDOW_ACCEPTFILES Then DragAcceptFiles _hwnd,True
- _wstyle = GetWindowLongW( hwnd, GWL_STYLE )
-
- Return Self
- EndMethod
-
- Method SetAlpha( alpha# )
- If SetLayeredWindowAttributes Then
- Local tmpStyle% = GetWindowLongW(_hwnd, GWL_EXSTYLE)
- If alpha = 1.0 Then
- SetLayeredWindowAttributes( _hwnd, 0, Byte(alpha*255), LWA_ALPHA)
- If (tmpStyle & WS_EX_LAYERED) Then SetWindowLongW(_hwnd, GWL_EXSTYLE, tmpStyle&~WS_EX_LAYERED)
- Else
- If Not (tmpStyle & WS_EX_LAYERED) Then SetWindowLongW(_hwnd, GWL_EXSTYLE, tmpStyle|WS_EX_LAYERED)
- SetLayeredWindowAttributes( _hwnd, 0, Byte(alpha*255), LWA_ALPHA)
- EndIf
- RedrawGadget(Self)
- EndIf
- EndMethod
-
- Method Rethink()
- Local dimensions[] = [xpos,ypos,width,height]
- ConvertToContainerDimensions( dimensions[0], dimensions[1], dimensions[2], dimensions[3] )
- MoveWindow _hwnd, dimensions[0], dimensions[1], dimensions[2], dimensions[3], True
- RethinkClient(True)
- EndMethod
-
- Method RethinkClient(forceRedraw:Int = False)
- If _hwndClient Then
- MoveWindow _hwndClient, _clientx,_clienty,ClientWidth(),ClientHeight(),forceRedraw
- EndIf
- LayoutKids()
- EndMethod
-
-
- Method ClientWidth()
- If (style & WINDOW_CLIENTCOORDS) Then Return width
- Local Rect:Int[4]
- GetClientRect _hwnd, Rect
- Return Max(Rect[2]-Rect[0]-_clientX,0)
- EndMethod
-
- Method ClientHeight()
- If (style & WINDOW_CLIENTCOORDS) Then Return height
- Local h:Int = height, Rect:Int[] = [0,0,width,height]
- AdjustWindowRectEx(Rect,GetWindowLongW(_hwnd, GWL_STYLE),_hmenu,GetWindowLongW(_hwnd, GWL_EXSTYLE))
- h:-(Rect[3]-Rect[1]+_clientY-height)
- If _status Then GetWindowRect _status,Rect;h:-(Rect[3]-Rect[1])
- Return Max(h,0)
- End Method
-
- Method Class()
- Return GADGET_WINDOW
- EndMethod
-
- Method State()
- Local t = Super.State()
- If IsIconic(_hwnd) t:|STATE_MINIMIZED
- If IsZoomed(_hwnd) t:|STATE_MAXIMIZED
- Return t
- EndMethod
-
- Method SetEnabled(enable)
- _enabled = enable
- EnableWindow(_hwnd,enable)
- EndMethod
-
- Method SetMinimumSize(w,h)
- 'Set minimum size for current window style
- _minwidth=w;_minheight=h
- 'Get window style
- Local tmpWStyle% = GetWindowLongW( _hwnd, GWL_STYLE )
- 'Update size border
- If (_maxwidth = _minwidth And _maxheight = _minheight) Then tmpWStyle:&~WS_SIZEBOX ElseIf (style&WINDOW_RESIZABLE) Then tmpWStyle:|WS_SIZEBOX
- 'Set new window style if necessary
- If tmpWStyle <> GetWindowLongW( _hwnd, GWL_STYLE ) Then
- SetWindowLongW( _hwnd, GWL_STYLE, tmpWStyle )
- Rethink()
- SetWindowPos( _hwnd, Null, 0, 0, 0, 0, SWP_DRAWFRAME|SWP_FRAMECHANGED|SWP_NOACTIVATE|SWP_NOMOVE|SWP_NOOWNERZORDER|SWP_NOZORDER|SWP_NOSIZE )
- EndIf
- EndMethod
-
- Method SetMaximumSize(w,h)
- 'Set maximum size for current window style
- _maxwidth=w;_maxheight=h
- 'Get window style
- Local tmpWStyle% = GetWindowLongW( _hwnd, GWL_STYLE )&~WS_MAXIMIZEBOX
- 'Update size border
- If (_maxwidth = _minwidth And _maxheight = _minheight) Then tmpWStyle:&~WS_SIZEBOX ElseIf (style&WINDOW_RESIZABLE) Then tmpWStyle:|WS_SIZEBOX
- 'Set new window style if necessary
- If tmpWStyle <> GetWindowLongW( _hwnd, GWL_STYLE ) Then
- SetWindowLongW( _hwnd, GWL_STYLE, tmpWStyle )
- Rethink()
- SetWindowPos( _hwnd, Null, 0, 0, 0, 0, SWP_DRAWFRAME|SWP_FRAMECHANGED|SWP_NOACTIVATE|SWP_NOMOVE|SWP_NOOWNERZORDER|SWP_NOZORDER|SWP_NOSIZE )
- EndIf
- EndMethod
-
- Method GetMenu:TGadget()
- If Not _menu Then
- _menu = New TWindowsMenu.Create(Null,0,"")
- _menu._setParent Self
- EndIf
- Return _menu
- EndMethod
-
- Method UpdateMenu()
-
- Local hmenu, oldMenu
- If _menu
- _menu.FreeKids
- _menu.Open
- hmenu=_menu._hmenu
- EndIf
-
- oldMenu = GetMenu_( _hwnd )
- SetMenu _hwnd,hmenu
- DrawMenuBar _hwnd
- DestroyMenu oldMenu
-
- EndMethod
-
- Field _statustext$
-
- Method GetStatusText$()
- If _status
- Return _statustext
- EndIf
- EndMethod
-
- Method SetStatusText(Text$)
- If _status
- _statustext = Text
- If (style&WINDOW_RESIZABLE) Then Text:+" " 'Cludge for size handle obfuscation
- Local tmpWString:Short Ptr = Text.ToWString()
- SendMessageW _status,WM_SETTEXT,0,Int(tmpWString)
- MemFree tmpWString
- EndIf
- EndMethod
-
- Field popupextra:Object
-
- Method PopupMenu(menu:TGadget,extra:Object)
- Local pt[2], wmenu:TWindowsMenu = TWindowsMenu(menu), tmpLink:TLink
- If wmenu
-
- GetCursorPos_ pt
- popupextra = extra
- wmenu.Open(True)
-
- Local hmenu:Int = TrackPopupMenu( wmenu._hmenu,TPM_LEFTALIGN|TPM_TOPALIGN|TPM_RETURNCMD|TPM_NONOTIFY,pt[0],pt[1],0,_hwnd,0 )
- If hmenu Then HandleMenuEvent( WM_COMMAND, hmenu )
-
- wmenu.Close()
- popupextra = Null
-
- EndIf
- EndMethod
-
- Function EnumChildProc(hwnd,lp) "win32"
- Local winfo:WINDOWINFO = New WINDOWINFO
- winfo.cbSize=SizeOf winfo
- GetWindowInfo hwnd,winfo
- If winfo.dwStyle&WS_TABSTOP
- _firsttab=hwnd
- Else
- EnumChildWindows hwnd,EnumChildProc,0
- EndIf
- If _firsttab Return 0
- Return 1
- EndFunction
-
- Global _firsttab
-
- Method Activate(cmd)
- Select cmd
- Case ACTIVATE_FOCUS
- _firsttab=0
- EnumChildWindows _hwnd,EnumChildProc,0
- If Not _firsttab _firsttab=_hwnd
- SetFocus _firsttab
- Case ACTIVATE_MINIMIZE
- ShowWindow _hwnd,SW_MINIMIZE
- Case ACTIVATE_MAXIMIZE
- ShowWindow _hwnd,SW_MAXIMIZE
- Case ACTIVATE_RESTORE
- ShowWindow _hwnd,SW_RESTORE
- Case ACTIVATE_REDRAW
- RefreshLook()
- Return RedrawWindow( _hwnd, Null, Null, RDW_INVALIDATE | RDW_UPDATENOW | RDW_ERASE | RDW_FRAME | RDW_ALLCHILDREN )
- End Select
- EndMethod
-
- Method OnCommand(msg,wp)
- If wp>100 Then HandleMenuEvent(msg,wp)
- EndMethod
-
- Method HandleMenuEvent( msg, wp )
-
- Local tmpMenuSource:TWindowsMenu = TWindowsMenu.GetMenuFromKey(wp), tmpMenuID
- If tmpMenuSource Then tmpMenuID = tmpMenuSource._tag
-
- Local tmpPopupExtra:Object = popupextra
- popupextra = Null
-
- MaxGUI.MaxGUI.PostGuiEvent EVENT_MENUACTION,tmpMenuSource,tmpMenuID,0,0,0,tmpPopupExtra
-
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Local x,y,w,h
- Local move,size
- Local Rect[4]
- Local winrect[4]
-
- Select msg
-
- Case WM_ERASEBKGND
- If BgBrush() Then
- Local Rect[4]
- If Not GetUpdateRect( hwnd, Rect, False ) Then GetClipBox( wp, Rect )
- FillRect( wp, Rect, BgBrush() )
- Return 1
- EndIf
-
- Case WM_SIZE
-
- If (hwnd = _hwnd) And (wp <> SIZE_MINIMIZED) Then
-
- If _status Then SendMessageW _status,WM_SIZE,0,0
-
- If (style & WINDOW_CLIENTCOORDS) Then
- GetClientRect _hwnd,Rect
- w=Rect[2]
- h=Rect[3]
- AdjustWindowRectEx(Rect,GetWindowLongW(_hwnd, GWL_STYLE),_hmenu,GetWindowLongW(_hwnd, GWL_EXSTYLE))
- x=-Rect[0]
- y=-Rect[1]
- GetWindowRect _hwnd,Rect
- x:+Rect[0]
- y:+Rect[1]
- If _status Then
- GetWindowRect _status,Rect
- h:-(Rect[3]-Rect[1])
- EndIf
- x:+_clientX;y:+_clientY
- w:-_clientX;h:-_clientY
- Else
- GetWindowRect(_hwnd,Rect)
- x=Rect[0];y=Rect[1]
- w=Rect[2]-Rect[0]
- h=Rect[3]-Rect[1]
- EndIf
-
- If x<>xpos Or y<>ypos Then move = True
- If w<>width Or h<>height Then size = True
-
- SetRect x,y,w,h
-
- If size Then RethinkClient()
-
- If move PostGuiEvent EVENT_WINDOWMOVE,0,0,x,y
- If size PostGuiEvent EVENT_WINDOWSIZE,0,0,w,h
-
- EndIf
-
- Case WM_MOVE
- If (hwnd = _hwnd) And Not (IsZoomed(hwnd) Or IsIconic(hwnd)) Then
-
- If (style & WINDOW_CLIENTCOORDS) Then
- GetClientRect _hwnd,Rect
- w=Rect[2]
- h=Rect[3]
- AdjustWindowRectEx(Rect,GetWindowLongW(_hwnd, GWL_STYLE),_hmenu,GetWindowLongW(_hwnd, GWL_EXSTYLE))
- x=-Rect[0]
- y=-Rect[1]
- GetWindowRect _hwnd,Rect
- x:+Rect[0]+_clientX
- y:+Rect[1]+_clientY
- Else
- GetWindowRect(_hwnd,Rect)
- x=Rect[0];y=Rect[1]
- w=Rect[2]-Rect[0]
- h=Rect[3]-Rect[1]
- EndIf
-
- If x<>xpos Or y<>ypos Then
- SetRect x,y,width,height
- PostGuiEvent EVENT_WINDOWMOVE,0,0,x,y
- EndIf
-
- EndIf
-
- Case WM_GETMINMAXINFO
- If hwnd = _hwnd And lp Then
- Local minmax:Int Ptr = Int Ptr(lp), tmpZero% = 0
-
- minmax[6]=_minwidth
- minmax[7]=_minheight
- ConvertToContainerDimensions(tmpZero,tmpZero,minmax[6],minmax[7])
-
- If (_maxwidth >= _minwidth) And (_maxheight >= _minheight) Then
- minmax[8]=_maxwidth
- minmax[9]=_maxheight
- ConvertToContainerDimensions(tmpZero,tmpZero,minmax[8],minmax[9])
- EndIf
-
- EndIf
-
- Case WM_ACTIVATE
- If (wp = WA_ACTIVE) Or (wp = WA_CLICKACTIVE) Then
- TWindowsGUIDriver._ActiveWindow = Self
- PostGuiEvent EVENT_WINDOWACTIVATE
- EndIf
-
- Case WM_COMMAND
- If wp>100 Then HandleMenuEvent(wp,msg)
-
- Case WM_CLOSE
- PostGuiEvent EVENT_WINDOWCLOSE
- Return 1
-
- Case WM_DROPFILES
- Local hdrop,pt[2],path$
- Local pbuffer:Short[MAX_PATH]
- Local i,n,l
- DragQueryPoint wp,pt
- n=DragQueryFileW(wp,$ffffffff,Null,0);
- For i=0 Until n
- l=DragQueryFileW(wp,i,pbuffer,MAX_PATH)
- path=String.FromShorts(pbuffer,l)
- PostGuiEvent EVENT_WINDOWACCEPT,0,0,pt[0],pt[1],path
- Next
- DragFinish wp
-
- End Select
-
- Return Super.WndProc(hwnd,msg,wp,lp)
-
- EndMethod
-
- Method DoLayout()
- 'Don't do anything!
- EndMethod
-
- Method SetTooltip( pTooltip$ )
- 'Windows shouldn't have tool-tips!
- EndMethod
-
- Method SetSensitivity(flags)
- 'Problems with resizing/moving sensitive windows.
- Super.SetSensitivity(flags&~SENSITIZE_MOUSE)
- 'Easy to create an active panel in client area as a work around.
- EndMethod
-
- Method SetPixmap(pPixmap:TPixmap, pFlags)
- If Not (pFlags & GADGETPIXMAP_ICON) Then Return False
- If _iconBitmap Then DestroyIcon(_iconBitmap);_iconBitmap = 0
- If pPixmap Then _iconBitmap = TWindowsGraphic.IconFromPixmap32( pPixmap )
- SendMessageW (_hwnd, WM_SETICON, 0, _iconBitmap)
- SendMessageW (_hwnd, WM_SETICON, 1, _iconBitmap)
- Return True
- EndMethod
-
- ' Needed otherwise SetEnabled() locks if modal child window is opened and parent is disabled.
- Method isControl()
- Return False
- EndMethod
-
- Method ConvertToContainerDimensions%( pX Var, pY Var, pW Var , pH Var )
-
- If Not (style & WINDOW_CLIENTCOORDS) Then Return 0
-
- Local Rect[4], menu = GetMenu_(_hwnd)
-
- If menu Then menu = True
- If _status Then GetWindowRect _status,Rect;pH:+(Rect[3]-Rect[1])
- pW:+_clientX;pH:+_clientY;pX:-_clientX;pY:-_clientY
-
- Rect = [pX,pY,pX+pW,pY+pH]
- AdjustWindowRectEx Rect,GetWindowLongW(_hwnd, GWL_STYLE),menu,GetWindowLongW(_hwnd, GWL_EXSTYLE)
-
- pX = Rect[0];pY = Rect[1];pW = Rect[2]-Rect[0];pH = Rect[3]-Rect[1]
-
- Return 1
-
- EndMethod
-
- Method FlushBrushes(pRecurse:Int = True)
- Super.FlushBrushes()
- If Not pRecurse Then Return
- For Local tmpGadget:TWindowsGadget = EachIn kids
- tmpGadget.FlushBrushes()
- Next
- EndMethod
-
-EndType
-
-Type TWindowsButton Extends TWindowsGadget
-
- Field _buttonImageList[] = [-1,0,0,0,0,0], _strButtonText$, _mouseoverbutton
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
- Self.style = style
- wstyle=WS_CHILD|WS_TABSTOP|WS_CLIPSIBLINGS|BS_MULTILINE
- Select style&7
- Case 0 wstyle:|BS_PUSHBUTTON;style = BUTTON_PUSH
- Case BUTTON_CHECKBOX wstyle:|BS_3STATE;If (style&BUTTON_PUSH) Then wstyle:|BS_PUSHLIKE
- Case BUTTON_RADIO wstyle:|BS_AUTORADIOBUTTON;If (style&BUTTON_PUSH) Then wstyle:|BS_PUSHLIKE
- Case BUTTON_OK wstyle:|BS_DEFPUSHBUTTON;hotkey=IDOK
- Case BUTTON_CANCEL wstyle:|BS_PUSHBUTTON;hotkey=IDCANCEL
- End Select
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"BUTTON","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- Register GADGET_BUTTON,hwnd
- Return Self
- EndMethod
-
- Method SetTextColor(r,g,b)
- If Not (style&7) Then
- SetWindowLongW(_hwnd,GWL_STYLE,GetWindowLongW(_hwnd,GWL_STYLE)|BS_OWNERDRAW)
- If Not _hTheme Then _hTheme = TWindowsGUIDriver.GetThemeHandle( _hwnd, "Button" )
- ElseIf Not (style&BUTTON_PUSH) And ((style&7=BUTTON_CHECKBOX) Or (style&7=BUTTON_RADIO))
- If SetWindowThemeW Then SetWindowThemeW(_hwnd,_wstrSpace,_wstrSpace)
- EndIf
- Super.SetTextColor(r,g,b)
- EndMethod
-
- Method SetColor(r,g,b)
- If Not (style&7) Then
- SetWindowLongW(_hwnd,GWL_STYLE,GetWindowLongW(_hwnd,GWL_STYLE)|BS_OWNERDRAW)
- If Not _hTheme Then _hTheme = TWindowsGUIDriver.GetThemeHandle( _hwnd, "Button" )
- EndIf
- Super.SetColor(r,g,b)
- EndMethod
-
- Method RemoveColor()
- If Not (style&7) Then
- SetWindowLongW(_hwnd,GWL_STYLE,GetWindowLongW(_hwnd,GWL_STYLE)&~BS_OWNERDRAW)
- _hTheme=0
- EndIf
- Super.RemoveColor()
- EndMethod
-
- Method State()
- Local t=Super.State()
- Select SendMessageW( _hwnd,BM_GETCHECK,0,0 )
- Case BST_CHECKED;t:|STATE_SELECTED
- Case BST_INDETERMINATE;t:|STATE_INDETERMINATE
- EndSelect
- Return t
- EndMethod
-
- Method SetSelected(bool)
- Local state = BST_UNCHECKED
- If bool Then
- If (style&7 = BUTTON_CHECKBOX) And (bool = CHECK_INDETERMINATE) Then
- state = BST_INDETERMINATE
- Else
- state = BST_CHECKED
- EndIf
- EndIf
- SendMessageW _hwnd,BM_SETCHECK,state,0
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- Case WM_THEMECHANGED
- If _hTheme Then
- TWindowsGUIDriver.CloseThemeHandle(_hTheme)
- _hTheme = TWindowsGUIDriver.GetThemeHandle(_hwnd,"BUTTON")
- EndIf
- Case WM_LBUTTONDBLCLK
- PostMessageW(_hwnd, WM_LBUTTONDOWN, wp, lp)
- Case WM_MOUSEMOVE
- If Not _mouseoverbutton Then
- _mouseoverbutton = True
- InvalidateRect(_hwnd,Null,False)
- Local tmpTrackMouseEvent:Int[] = [ 16, $2, hwnd, 0 ] 'TME_LEAVE: $2
- _TrackMouseEvent( tmpTrackMouseEvent )
- EndIf
- Case WM_MOUSELEAVE
- If _mouseoverbutton Then
- _mouseoverbutton = False
- InvalidateRect(_hwnd,Null,False)
- EndIf
- Case WM_ERASEBKGND
- Return 1
- EndSelect
-
- Return Super.WndProc(hwnd,msg,wp,lp)
-
- EndMethod
-
- Method OnDrawItem(pDrawItemStruct:DRAWITEMSTRUCT)
-
- Local tmpDc = pDrawItemStruct.hDc, txtWidth%, txtHeight%
- Local tmpDcState = SaveDC(tmpDC)
-
- ' button state
- Local tmpIsPressed = (pDrawItemStruct.ItemState & ODS_SELECTED)
- Local tmpIsFocused = (pDrawItemStruct.ItemState & ODS_FOCUS)
- Local tmpIsDisabled = (pDrawItemStruct.ItemState & ODS_DISABLED)
- Local tmpDrawFocusRect = Not (pDrawItemStruct.ItemState & ODS_NOFOCUSRECT)
-
- Local itemRect:Int Ptr = Int Ptr Varptr pDrawItemStruct.rcItem_left, txtRect:Int[4], clientRect:Int[4]
-
- Local tmpBgMode = SetBkMode(tmpDc, TRANSPARENT)
-
- ' Prepare draw... paint button background
-
- If _hTheme Then
-
- Local tmpState = PBS_NORMAL
- If tmpIsDisabled Then
- tmpState = PBS_DISABLED
- ElseIf tmpIsPressed Then
- tmpState = PBS_PRESSED
- ElseIf _mouseoverbutton Then
- tmpState = PBS_HOT
- ElseIf tmpIsFocused Then
- tmpState = PBS_DEFAULTED
- EndIf
-
- If IsThemeBackgroundPartiallyTransparent(_hTheme, BP_PUSHBUTTON, tmpState) Then
- DrawThemeParentBackground( _hwnd, tmpDc, itemRect )
- EndIf
- DrawThemeBackground(_hTheme, tmpDc, BP_PUSHBUTTON, tmpState, itemRect, Null)
- GetThemeBackgroundContentRect(_hTheme, tmpDc, BP_PUSHBUTTON, tmpState, itemRect, clientRect)
-
- Else
-
- clientRect = [itemRect[0], itemRect[1], itemRect[2], itemRect[3]]
- InflateRect(clientRect, -GetSystemMetrics(SM_CXEDGE), -GetSystemMetrics(SM_CYEDGE))
-
- If tmpIsFocused Then
-
- Local tmpBr = CreateSolidBrush($000000)
- FrameRect(tmpDc, itemRect , tmpBr)
- InflateRect(itemRect, -1, -1)
- DeleteObject(tmpBr)
-
- EndIf
-
- Local crColor
- If BgColor() < 0 Then crColor = GetSysColor(COLOR_BTNFACE) Else crColor = BgColor()
-
- Local brBackground = CreateSolidBrush(crColor)
-
- FillRect(tmpDc, itemRect, brBackground)
-
- DeleteObject(brBackground)
-
- ' Draw pressed button
- If tmpIsPressed
-
- Local brBtnShadow = CreateSolidBrush(GetSysColor(COLOR_BTNSHADOW))
- FrameRect(tmpDc, itemRect, brBtnShadow)
- DeleteObject(brBtnShadow)
-
- OffsetRect( clientRect, 1, 1 )
-
- Else ' ...Else draw non pressed button
-
- Local tmpUState = DFCS_BUTTONPUSH
- If _mouseoverbutton Then tmpUState :| DFCS_HOT
- If tmpIsPressed Then tmpUState :| DFCS_PUSHED
-
- DrawFrameControl(tmpDc, itemRect, DFC_BUTTON, tmpUState)
-
- EndIf
-
- EndIf
-
- If BgColor() > -1 Then
- Local brBackground = CreateSolidBrush(BgColor())
- FillRect(tmpDc, clientRect, brBackground)
- DeleteObject(brBackground)
- EndIf
-
- txtRect = clientRect[..]
-
- clientRect[RECT_RIGHT]:-clientRect[RECT_LEFT]
- clientRect[RECT_BOTTOM]:-clientRect[RECT_TOP]
-
- ' Read the button's title
- Local tmpText$ = Super.GetText()
-
- ' Draw the icon
- 'DrawTheIcon(GetDlgItem(hDlg, IDC_OWNERDRAW_BTN), &dc, bHasTitle, &lpDIS.rcItem, &captionRect, bIsPressed, bIsDisabled)
-
- ' Write the button title (if any)
- If tmpText Then
-
- Local tmpFlags = DT_CENTER|DT_WORDBREAK
-
- DrawTextW( tmpDc, tmpText, -1, txtRect, DT_CALCRECT|tmpFlags )
-
- txtWidth = txtRect[RECT_RIGHT]-txtRect[RECT_LEFT]
- txtHeight = txtRect[RECT_BOTTOM]-txtRect[RECT_TOP]
-
- txtRect[RECT_LEFT] = clientRect[RECT_LEFT] + (clientRect[RECT_RIGHT] - txtWidth)/2
- txtRect[RECT_TOP] = clientRect[RECT_TOP] + (clientRect[RECT_BOTTOM] - txtHeight)/2
- txtRect[RECT_RIGHT] = txtRect[RECT_LEFT] + txtWidth
- txtRect[RECT_BOTTOM] = txtRect[RECT_TOP] + txtHeight
-
- Local tmpTextColor
- If tmpIsDisabled Then
- tmpTextColor = GetSysColor(COLOR_GRAYTEXT)
- Else
- If FgColor() < 0 Then tmpTextColor = GetSysColor(COLOR_BTNTEXT) Else tmpTextColor = FgColor()
- EndIf
- tmpTextColor = SetTextColor_(tmpDc,tmpTextColor)
-
- DrawTextW( tmpDc, tmpText, -1, txtRect, tmpFlags )
-
- SetTextColor_(tmpDc,tmpTextColor)
-
- EndIf
-
- RestoreDC(tmpDc,tmpDcState)
-
- ' Draw the focus rect
- If tmpIsFocused And tmpDrawFocusRect Then
- Local focusRect:Int[4]
- CopyRect(focusRect, itemRect)
- InflateRect(focusRect, -3, -3)
- SetMapMode(tmpDc, MM_TEXT)
- DrawFocusRect(tmpDc, focusRect)
- EndIf
-
- Return True
- EndMethod
-
- Method OnCommand(msg,wp)
- Select wp Shr 16
- Case BN_CLICKED
- Select (style&7)
- Case BUTTON_CHECKBOX
- Select State()&STATE_INDETERMINATE
- Case 0, STATE_INDETERMINATE
- SetSelected(True)
- Case STATE_SELECTED
- SetSelected(False)
- EndSelect
- EndSelect
-
- PostGuiEvent EVENT_GADGETACTION,ButtonState(Self)
-
- 'Fix so that tooltips reappear on Windows XP
- Local tmpTooltip$ = GetTooltip()
- If tmpTooltip Then SetTooltip("");SetTooltip(tmpTooltip)
-
- EndSelect
- EndMethod
-
- Method SetPixmap(pixmap:TPixmap,pFlags)
-
- Local tmpWindowStyle = GetWindowLongW(_hwnd,GWL_STYLE)
-
- If (pFlags & GADGETPIXMAP_ICON) And (((style&BUTTON_PUSH)=BUTTON_PUSH) Or (style = BUTTON_CANCEL)) Then
-
- 'To remove an image from a button, a handle-list of -1 should be passed.
- If _buttonImageList[0] >= 0 Then ImageList_Destroy(_buttonImageList[0]);_buttonImageList[0] = -1
- If pixmap Then _buttonImageList[0] = BuildImageList( pixmap )
-
- If (pFlags & GADGETPIXMAP_NOTEXT) Then
- _buttonImageList[5] = BUTTON_IMAGELIST_ALIGN_CENTER
- Else
- _buttonImageList[5] = BUTTON_IMAGELIST_ALIGN_LEFT
- EndIf
-
- 'If running Windows XP/Vista, let's use BCM_SETIMAGELIST
-
- If Not SendMessageW (_hwnd, BCM_SETIMAGELIST, 0, Int Byte Ptr _buttonImageList) Then
- 'Otherwise, if this fails we should use BM_SETIMAGE.
-
- If _buttonImageList[0] >= 0 Then ImageList_Destroy(_buttonImageList[0]);_buttonImageList[0] = -1
-
- If _iconBitmap Then DeleteObject(_iconBitmap);_iconBitmap = 0
- If pixmap Then _iconBitmap = TWindowsGraphic.BitmapFromPixmap( pixmap, True )
-
- SendMessageW (_hwnd, BM_SETIMAGE, IMAGE_BITMAP, _iconBitmap)
-
- EndIf
-
- 'Show the text if there isn't a pixmap or if we haven't specified GADGETPIXMAP_NOTEXT.
- If (Not pixmap) Or Not(pFlags & GADGETPIXMAP_NOTEXT) Then
- tmpWindowStyle:&(~BS_BITMAP)
-
- 'Text isn't hidden on XP image buttons regardless of whether BS_BITMAP is set
- 'so we have to hack this in - they must have fixed it on Vista though as it works fine there.
-
- Super.SetText( GetText() )
- Else
- tmpWindowStyle:|BS_BITMAP
-
- 'Text isn't hidden on XP image buttons regardless of whether BS_BITMAP is set
- 'so we have to hack this in - they must have fixed it on Vista though as it works fine there.
-
- Super.SetText( "" )
- EndIf
-
- SetWindowLongW _hwnd,GWL_STYLE,tmpWindowStyle
-
- InvalidateRect _hwnd, Null, False
-
- Return True
-
- EndIf
-
- EndMethod
-
- Method SetText(pText$)
- Local oldText$ = _strButtonText
- _strButtonText = pText
- If (_buttonImageList[0] < 0 And Not _iconBitmap) Or (oldText = Super.GetText()) Then Super.SetText(pText)
- EndMethod
-
- Method GetText$()
- Return _strButtonText
- EndMethod
-
- Method Free()
- If _buttonImageList[0] >= 0 Then ImageList_Destroy(_buttonImageList[0])
- If _iconBitmap Then DestroyIcon( _iconBitmap );_iconBitmap = 0
- _buttonImageList = Null
- Super.Free()
- EndMethod
-
- Function BuildImageList(pixmap:TPixmap)
- Local bitmap,imagelist,mask
- If TWindowsGUIDriver.CheckCommonControlVersion() And (Pixmap.format=PF_RGBA8888 Or pixmap.format=PF_BGRA8888)
- imagelist=ImageList_Create(pixmap.width,pixmap.height,ILC_COLOR32,0,1)
- If imagelist
- bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, True)
- ImageList_Add(imagelist,bitmap,0)
- EndIf
- EndIf
- If imagelist=0
- bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, False)
- mask=TWindowsGraphic.BitmapMaskFromPixmap(pixmap)
- imagelist=ImageList_Create(pixmap.width,pixmap.height,ILC_COLOR24|ILC_MASK,0,1)
- ImageList_Add(imagelist,bitmap,mask)
- DeleteObject(mask)
- EndIf
- DeleteObject(bitmap)
- Return imagelist
- EndFunction
-
- Method Class()
- Return GADGET_BUTTON
- EndMethod
-
-EndType
-
-Type TWindowsTextField Extends TWindowsGadget
-
- Field _busy
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
- Self.style = style
- xstyle=WS_EX_CLIENTEDGE
- wstyle=WS_CHILD|WS_TABSTOP|ES_AUTOHSCROLL|WS_CLIPSIBLINGS
- If style&TEXTFIELD_PASSWORD Then wstyle:|ES_PASSWORD
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"EDIT","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- 'SendMessageW hwnd,WM_SETFONT,TWindowsGUIDriver.GDIFont.handle,1
- Register GADGET_TEXTFIELD,hwnd
- SetColor(255,255,255)
- Return Self
- EndMethod
-
- Method SetText(Text$)
- Local p0,p1
- _busy:+1
- SendMessageW _hwnd,EM_GETSEL,Int Byte Ptr Varptr p0,Int Byte Ptr Varptr p1
- Super.SetText(Text)
- SendMessageW _hwnd,EM_SETSEL,p0,p1
- _busy:-1
- EndMethod
-
- Method Activate(cmd)
- Select cmd
- Case ACTIVATE_CUT
- SendMessageW _hwnd,WM_CUT,0,0
- Case ACTIVATE_COPY
- SendMessageW _hwnd,WM_COPY,0,0
- Case ACTIVATE_PASTE
- SendMessageW _hwnd,WM_PASTE,0,0
- Case ACTIVATE_FOCUS
- SendMessageW _hwnd,EM_SETSEL,0,-1
- End Select
- Return Super.Activate(cmd)
- EndMethod
-
- Method OnCommand(msg,wp)
- If Not _busy
- Select (wp Shr 16)
- Case EN_UPDATE
- PostGuiEvent EVENT_GADGETACTION
- Case EN_KILLFOCUS
- SendMessageW _hwnd,EM_SETSEL,0,0
- End Select
- EndIf
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Local event:TEvent
- Select msg
- Case WM_ERASEBKGND
- Return 1
- Case WM_KEYDOWN
- If eventfilter<>Null
- event=CreateEvent(EVENT_KEYDOWN,Self,wp,keymods())
- If Not eventfilter(event,context) Return True
- EndIf
- Case WM_CHAR
- If eventfilter<>Null
- event=CreateEvent(EVENT_KEYCHAR,Self,wp,keymods())
- If Not eventfilter(event,context) Return True
- EndIf
- Case WM_KILLFOCUS
- PostGuiEvent EVENT_GADGETLOSTFOCUS
- End Select
- Return Super.WndProc(hwnd,msg,wp,lp)
- EndMethod
-
- Method Class()
- Return GADGET_TEXTFIELD
- EndMethod
-
-EndType
-
-Type TWindowsTextArea Extends TWindowsGadget
-
- Global _ClassName:String = Null 'See InitializeLibrary().
-
- Global _pagemargin# = 0.5 'Page margin for print-out in inches
-
- Field _locked
-
- Field cr1:CHARRANGE=New CHARRANGE
- Field cr2:CHARRANGE=New CHARRANGE
- Field cf:CHARFORMATW=New CHARFORMATW
-
- Field ole:IRichEditOLE
- Field idoc:ITextDocument
- Field busy,readonly
-
- Field IID_ITextDocument:GUID = New GUID
-
- Function _InitializeLibrary()
-
- If Not _ClassName Then
-
- 'Load RichEdit DLL
- If Not LoadLibraryW("msftedit.dll") Then
- If LoadLibraryW("riched20.dll") _ClassName = "RichEdit20W"
- Else
- _ClassName = "RICHEDIT50W"
- EndIf
-
- EndIf
-
- EndFunction
-
- Method New()
- _InitializeLibrary()
- EndMethod
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
- Local res
-
- xstyle=WS_EX_CLIENTEDGE
- wstyle=WS_CHILD|WS_VSCROLL|WS_CLIPSIBLINGS
- wstyle:|ES_MULTILINE|ES_NOOLEDRAGDROP|ES_NOHIDESEL|ES_LEFT
- If Not (style&TEXTAREA_WORDWRAP) wstyle:|WS_HSCROLL|ES_AUTOHSCROLL
-' If (style&TEXTAREA_READONLY) wstyle:|ES_READONLY
- If (style&TEXTAREA_READONLY) readonly=True
-
- Self.style = style
-
- parent=group.query(QUERY_HWND_CLIENT)
-
- 'RichText control should be made have dimensions of 1x1 pixels to fix Windows XP vertical scrollbar drawing bug.
- hwnd=CreateWindowExW(xstyle,_ClassName,"",wstyle,0,0,1,1,parent,hotkey,GetModuleHandleW(Null),Null)
-
- SendMessageW hwnd,EM_SETLIMITTEXT,4*1024*1024,0
- SendMessageW hwnd,EM_SETEVENTMASK,0,ENM_CHANGE|ENM_MOUSEEVENTS|ENM_SELCHANGE|ENM_KEYEVENTS
- SendMessageW hwnd,EM_SETUNDOLIMIT,0,0
-
- SendMessageW hwnd,EM_GETOLEINTERFACE,0,Int Byte Ptr Varptr ole
- res=IIDFromString(ITextDocument_UUID,IID_ITextDocument)
-
- res=ole.QueryInterface(IID_ITextDocument,Varptr idoc)
-
- Register GADGET_TEXTAREA,hwnd
- Return Self
- EndMethod
-
- Method Free()
- If ole Then ole.Release_
- If idoc Then idoc.Release_
- Super.Free()
- EndMethod
-
- Method Activate(cmd)
- Select cmd
- Case ACTIVATE_CUT
- SendMessageW _hwnd,WM_CUT,0,0
- Case ACTIVATE_COPY
- SendMessageW _hwnd,WM_COPY,0,0
- SetFocus _hwnd
- Case ACTIVATE_PASTE
- DoPaste
- Case ACTIVATE_PRINT
- DoPrint
- Default
- Return Super.Activate(cmd)
- End Select
- EndMethod
-
- Method DoPaste()
- Local h,handle,n
- Local w:Short Ptr,cp:Short Ptr
- Local tp:Byte Ptr,bp:Byte Ptr
-
- If OpenClipboard(_hwnd)
- If IsClipboardFormatAvailable(CF_UNICODETEXT)
- handle=GetClipboardData(CF_UNICODETEXT)
- n=GlobalSize(handle)
- w=Short Ptr GlobalLock(handle)
- h=GlobalAlloc(GMEM_MOVEABLE,n)
- cp=Short Ptr GlobalLock(h)
- memcpy_(cp,w,n)
- If cp[n/2-2]=10 Then cp[n/2-2]=13
- GlobalUnlock h
- GlobalUnlock handle
- If h
- EmptyClipboard
- SetClipboardData CF_UNICODETEXT,h
- EndIf
- ElseIf IsClipboardFormatAvailable(CF_OEMTEXT)
- handle=GetClipboardData(CF_OEMTEXT)
- n=GlobalSize(handle)
- tp=Byte Ptr GlobalLock(handle)
- h=GlobalAlloc(GMEM_MOVEABLE,n)
- bp=Byte Ptr GlobalLock(h)
- memcpy_(bp,tp,n)
- If bp[n-2]=10 Then bp[n-2]=13
- GlobalUnlock h
- GlobalUnlock handle
- If h
- EmptyClipboard
- SetClipboardData CF_OEMTEXT,h
- EndIf
- EndIf
- CloseClipboard
- SendMessageW _hwnd,WM_PASTE,0,0
- SetFocus _hwnd
- EndIf
- EndMethod
-
- Method DoPrint()
-
- Local tmpTextSelLen = TextAreaSelLen(Self)
-
- Local tmpPrintDialog:PRINTDLGW = New PRINTDLGW
-
- tmpPrintDialog.flags = PD_RETURNDC | PD_HIDEPRINTTOFILE | PD_NOPAGENUMS
- If Not tmpTextSelLen Then tmpPrintDialog.flags:|PD_NOSELECTION
-
- tmpPrintDialog.hwndOwner = _hwnd
-
- If Not PrintDlg( Byte Ptr tmpPrintDialog ) Then Return 0
-
- Local hdcPrinter = tmpPrintDialog.hdc
-
- Local tmpDoc:DOCINFOW = New DOCINFOW
- Local tmpDocTitle:Short Ptr = AppTitle.ToWString()
- tmpDoc.lpszDocName = tmpDocTitle
-
- Local tmpSuccess = (StartDocW( hdcPrinter, Byte Ptr tmpDoc ) > 0)
-
- If tmpSuccess Then
-
- Local _cursor = TWindowsGUIDriver._cursor
-
- SetPointer( POINTER_WAIT )
-
- SetMapMode( hdcPrinter, MM_TEXT )
-
- Local wPage = GetDeviceCaps( hdcPrinter, PHYSICALWIDTH )
- Local hPage = GetDeviceCaps( hdcPrinter, PHYSICALHEIGHT )
- Local xPPI = GetDeviceCaps( hdcPrinter, LOGPIXELSX )
- Local yPPI = GetDeviceCaps( hdcPrinter, LOGPIXELSY )
-
- Local tmpTextLengthStruct[] = [GTL_DEFAULT,1200]
- Local tmpTextLength = SendMessageW (_hwnd, EM_GETTEXTLENGTHEX, Int Byte Ptr tmpTextLengthStruct, 0)
-
- Local tmpTextPrinted, tmpFormatRange:FORMATRANGE = New FORMATRANGE
-
- tmpFormatRange.hdc = hdcPrinter
- tmpFormatRange.hdcTarget = hdcPrinter
-
- tmpFormatRange.rcPageRight = (wPage*1440:Long)/xPPI
- tmpFormatRange.rcPageBottom = (hPage*1440:Long)/yPPI
-
- tmpFormatRange.rcLeft = (1440*_pagemargin);tmpFormatRange.rcTop = (1440*_pagemargin)
- tmpFormatRange.rcRight = tmpFormatRange.rcPageRight - (2880*_pagemargin)
- tmpFormatRange.rcBottom = tmpFormatRange.rcPageBottom - (2880*_pagemargin)
-
- If tmpPrintDialog.flags & PD_SELECTION Then
- tmpTextPrinted = TextAreaCursor(Self)
- tmpFormatRange.CHARRANGE_cpMax = tmpTextPrinted+tmpTextSelLen
- Else
- tmpFormatRange.CHARRANGE_cpMax = tmpTextLength
- EndIf
-
- SendMessageW (_hwnd, EM_FORMATRANGE, False, 0)
-
- While tmpSuccess And ( tmpTextPrinted < tmpFormatRange.CHARRANGE_cpMax )
-
- tmpFormatRange.CHARRANGE_cpMin = tmpTextPrinted
-
- tmpSuccess = (StartPage(hdcPrinter) > 0)
- If Not tmpSuccess Then Exit
-
- tmpTextPrinted = SendMessageW( _hwnd, EM_FORMATRANGE, True, Int Byte Ptr tmpFormatRange )
-
- tmpSuccess = (EndPage(hdcPrinter) > 0)
-
- Wend
-
- If tmpSuccess Then EndDoc( hdcPrinter ) Else AbortDoc( hdcPrinter )
-
- SendMessageW (_hwnd, EM_FORMATRANGE, False, 0)
-
- TWindowsGUIDriver._cursor = _cursor
- SetCursor _cursor
-
- EndIf
-
- GlobalFree( tmpPrintDialog.hDevMode )
- GlobalFree( tmpPrintDialog.hDevNames )
- DeleteDC( hdcPrinter )
-
- MemFree tmpDocTitle
-
- Return tmpSuccess
-
- EndMethod
-
- Global gt[] = [GTL_DEFAULT, CP_ACP]
-
- Method CharCount()
- Return SendMessageW(_hwnd,EM_GETTEXTLENGTHEX,Int Byte Ptr gt,0)
- EndMethod
-
- Method SetStyle(r,g,b,flags,pos,length,units)
- Local iifont:ITextFont
- Local iirange:ITextRange
- Local res, tmpOutput
- If units=TEXTAREA_LINES
- Local n=pos
- pos=CharAt(pos)
- If length>=0 length=CharAt(n+length)-pos
- EndIf
- If length<0 length=charcount()-pos
- busy:+1
- res=idoc.Range(pos,pos+length,iirange)
- res=iirange.GetFont(iifont)
- res=iifont.SetForeColor(((b Shl 16)|(g Shl 8)|r))
- If (flags&TEXTFORMAT_BOLD) Then iifont.SetBold(TOMTRUE) Else iifont.SetBold(TOMFALSE)
- If (flags&TEXTFORMAT_ITALIC) Then iifont.SetItalic(TOMTRUE) Else iifont.SetItalic(TOMFALSE)
- If (flags&TEXTFORMAT_UNDERLINE) Then iifont.SetUnderline(TOMSINGLE) Else iifont.SetUnderline(TOMFALSE)
- If (flags&TEXTFORMAT_STRIKETHROUGH) Then iifont.SetStrikeThrough(TOMTRUE) Else iifont.SetStrikeThrough(TOMNONE)
- iifont.Release_
- iirange.Release_
- busy:-1
- EndMethod
-
- Method InsertText(Text$,pos,count)
- Local iirange:ITextRange
- Local bstr:Short Ptr, tmpWString:Short Ptr = Text.toWString()
- Local res, bool
- busy:+1
- res=idoc.Range(pos,pos+count,iirange)
- bstr=SysAllocStringLen(tmpWString,Text.length);MemFree tmpWString
- LockText()
- res=iirange.SetText(bstr)
- UnlockText()
- SysFreeString bstr
- iirange.Release_
- busy:-1
- EndMethod
-
- Method ReplaceText(pos,length,Text$,units)
- If units=TEXTAREA_LINES
- Local n=pos
- pos=CharAt(pos)
- If length>=0 length=CharAt(n+length)-pos
- EndIf
- If length<0 Then length=charcount()-pos
- InsertText Text,pos,length
- EndMethod
-
- Method AreaText$(pos,length,units)
- Local iirange:ITextRange
- Local bstr:Short Ptr
-
- If units=TEXTAREA_LINES
- Local n=pos
- pos=CharAt(pos)
- If length>=0 length=CharAt(n+length)-pos
- EndIf
- If length<0 length=charcount()-pos
- idoc.Range(pos,pos+length,iirange)
- iirange.GetText(Varptr bstr)
- Local Text$=String.FromWString(bstr)
- SysFreeString bstr
- iirange.Release_
- Text=Text.Replace(Chr(13),Chr(10))
- Return Text
- EndMethod
-
- Method SetSelection(pos,length,units)
- If units=TEXTAREA_LINES
- Local n=pos
- pos=CharAt(pos)
- If length>0
- length=CharAt(n+length)
- length=length-pos
- EndIf
- EndIf
- If length<0 length=charcount()-pos
- Local cr:CHARRANGE = New CHARRANGE
- cr.cpMin=pos
- cr.cpMax=pos+length
- Desensitize()
- SendMessageW _hwnd,EM_EXSETSEL,0,Int Byte Ptr(cr)
- Sensitize()
- EndMethod
-
- Method SetMargins(leftmargin)
- SendMessageW _hwnd,EM_SETMARGINS,EC_LEFTMARGIN,leftmargin
- EndMethod
-
- ' 72 points per inch
-
- Method SetTabs(tabs)
- Local hdc=GetDC( 0 )
- idoc.SetDefaultTabStop tabs * 72.0 / GetDeviceCaps( hdc,LOGPIXELSX )
- ReleaseDC 0,hdc
- EndMethod
-
- Method SetTextColor(r,g,b)
- cf.cbSize=SizeOf(CHARFORMATW)
- cf.dwMask=CFM_COLOR|CFM_BOLD|CFM_ITALIC
- cf.crTextColor=(b Shl 16)|(g Shl 8)|r
- SendMessageW _hwnd,EM_SETCHARFORMAT,SCF_DEFAULT,Int Byte Ptr cf
- SendMessageW _hwnd,EM_SETCHARFORMAT,SCF_ALL,Int Byte Ptr cf
- EndMethod
-
- Method SetColor(r,g,b)
- SendMessageW _hwnd,EM_SETBKGNDCOLOR,0,((b Shl 16)|(g Shl 8)|r)
- EndMethod
-
- Method RemoveColor()
- SendMessageW _hwnd,EM_SETBKGNDCOLOR,1,0
- EndMethod
-
- Method GetCursorPos(units)
- Local cr:CHARRANGE = New CHARRANGE
- SendMessageW _hwnd,EM_EXGETSEL,0,Int Byte Ptr(cr)
- Local pos=cr.cpMin
- If units=TEXTAREA_LINES pos=LineAt(pos)
- Return pos
- EndMethod
-
- Method GetSelectionLength(units)
- Local cr:CHARRANGE = New CHARRANGE
- SendMessageW _hwnd,EM_EXGETSEL,0,Int Byte Ptr(cr)
- If units=TEXTAREA_LINES
- Return LineAt(cr.cpMax-1)-LineAt(cr.cpMin)+1
- Else
- Return cr.cpMax-cr.cpMin
- EndIf
- EndMethod
-
- Method CharAt(Line)
- If Line<0 Return
- If Line>AreaLen(TEXTAREA_LINES) Return charcount()
- Return SendMessageW(_hwnd,EM_LINEINDEX,Line,0)
- EndMethod
-
- Method LineAt(pos)
- If pos<0 Return
- If pos>charcount() Return AreaLen(TEXTAREA_LINES)
- Return SendMessageW(_hwnd,EM_EXLINEFROMCHAR,0,pos)
- EndMethod
-
- Method AreaLen(units)
- If units=TEXTAREA_LINES Return LineAt(charcount())
- Return charcount()
- EndMethod
-
- Method CharX( char )
- Local tmpPoint[2]
- SendMessageW(_hwnd, EM_POSFROMCHAR, Int Byte Ptr tmpPoint, char )
- Return tmpPoint[0]
- EndMethod
-
- Method CharY( char )
- Local tmpPoint[2]
- SendMessageW(_hwnd, EM_POSFROMCHAR, Int Byte Ptr tmpPoint, char )
- Return tmpPoint[1]
- EndMethod
-
- Method SetText(Text$)
- InsertText Text,0,charcount()
- EndMethod
-
- Method AddText(Text$)
- InsertText Text,charcount(),0
- Local cr:CHARRANGE = New CHARRANGE
- Local p = charcount()
- cr.cpMin=p
- cr.cpMax=p
- SendMessageW _hwnd,EM_EXSETSEL,0,Int Byte Ptr(cr)
- EndMethod
-
- Method GetText$()
- Return AreaText(0,charcount(),TEXTAREA_CHARS)
- EndMethod
-
- Global _oldCursor = 0
- Field _oldSelPos%, _oldSelLen% = 0
-
- Method LockText()
-
- If Not idoc.Freeze(_locked)
- _oldSelPos = GetCursorPos(TEXTAREA_CHARS)
- _oldSelLen = GetSelectionLength(TEXTAREA_CHARS)
- If Not _oldCursor Then _oldCursor = GetCursor()
- EndIf
-
- EndMethod
-
- Method UnlockText()
-
- If idoc.Unfreeze(_locked) = S_OK Then
- SetSelection( _oldSelPos, _oldSelLen, TEXTAREA_CHARS )
- If _oldCursor And (_oldCursor <> GetCursor()) Then
- SetCursor(_oldCursor)
- EndIf
- _oldCursor = 0
- EndIf
-
- EndMethod
-
- Method OnCommand(msg,wp)
- If busy Then Return
- Select wp Shr 16
- Case EN_CHANGE
- If Not _locked Then PostGuiEvent EVENT_GADGETACTION
- End Select
- EndMethod
-
- Method OnNotify(wp,lp)
- Local nmhdr:Int Ptr
- Local event:TEvent
-
- Super.OnNotify(wp,lp) 'Tooltip
-
- nmhdr=Int Ptr(lp)
- Select nmhdr[2]
-' Case EN_PROTECTED
-' DebugStop
- Case EN_SELCHANGE
- If Not (busy Or _locked)
- PostGuiEvent EVENT_GADGETSELECT
- EndIf
- Case EN_MSGFILTER
- Select nmhdr[3]
- Case WM_RBUTTONDOWN
- If GetSelectionLength(TEXTAREA_CHARS)=0 nmhdr[3]=WM_LBUTTONDOWN
- Case WM_RBUTTONUP
- Local mx=nmhdr[5] & $ffff
- Local my=nmhdr[5] Shr 16
- PostGuiEvent EVENT_GADGETMENU,0,0,mx,my
- Case WM_KEYDOWN
-
- Local k=nmhdr[4]
-
- 'Filtering out special shortcut combinations
- If (keymods()&MODIFIER_CONTROL) Then
- Select k
- Case 76,69,82 'ctrl+l, ctrl+e, ctrl+r
- Return 1 'Alignment shortcuts
-
- Case 188,190 'ctrl+<, ctrl+>
- 'Font size shortcuts
- If (keymods()&MODIFIER_SHIFT) Then Return 1
- EndSelect
- EndIf
-
- 'Read-only
- If readonly
- If k>=33 And k<=40 Return 0 'selection keys
- If (keymods()&MODIFIER_CONTROL) Then
- Select k
- Case 65, 67;Return 0 'ctrl-a, ctrl+c
- EndSelect
- EndIf
- Return 1
- EndIf
-
- 'Event Filter
- If eventfilter<>Null
- event=CreateEvent(EVENT_KEYDOWN,Self,k,keymods())
- Return Not eventfilter(event,context)
- EndIf
-
- Case WM_CHAR
- If readonly Return 1
- If eventfilter<>Null
- event=CreateEvent(EVENT_KEYCHAR,Self,nmhdr[4],keymods())
- Return Not eventfilter(event,context)
- EndIf
- End Select
- End Select
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
-
- Case WM_MOUSEWHEEL
- If (wp&MK_CONTROL) Then SendMessageW _hwnd, EM_SETZOOM, 0, 0
-
- Case WM_KILLFOCUS
- PostGuiEvent EVENT_GADGETLOSTFOCUS
-
- End Select
-
- Return Super.WndProc(hwnd,msg,wp,lp)
-
- EndMethod
-
- Method Class()
- Return GADGET_TEXTAREA
- EndMethod
-
-EndType
-
-Type TWindowsListBox Extends TWindowsGadget
-
- Field _icons:TWindowsIconStrip
- Field _selected = -1
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
-
- Self.style = style
-
- xstyle=WS_EX_CLIENTEDGE
- wstyle=WS_CHILD|WS_TABSTOP|LVS_REPORT|LVS_NOCOLUMNHEADER|LVS_SHOWSELALWAYS|LVS_SHAREIMAGELISTS
- wstyle:|WS_CLIPSIBLINGS
-
- If (style&LISTBOX_MULTISELECT<>LISTBOX_MULTISELECT) Then wstyle:|LVS_SINGLESEL
-
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"SysListView32","",wstyle,0,0,20,20,parent,hotkey,GetModuleHandleW(Null),Null)
-
- Local column:LVCOLUMNW
- column=New LVCOLUMNW
- SendMessageW hwnd,LVM_INSERTCOLUMNW,0,Int Byte Ptr(column)
-
- SendMessageW hwnd,LVM_SETEXTENDEDLISTVIEWSTYLE,LVS_EX_FULLROWSELECT|LVS_EX_INFOTIP,LVS_EX_FULLROWSELECT|LVS_EX_INFOTIP
-
- If TWindowsGUIDriver.CheckCommonControlVersion() Then SendMessageW hwnd,LVM_SETEXTENDEDLISTVIEWSTYLE,LVS_EX_DOUBLEBUFFER,LVS_EX_DOUBLEBUFFER
-
- Register GADGET_LISTBOX,hwnd,0,False 'Set to True for normal Tooltips
-
- If TWindowsGUIDriver._explorerstyle Then UseExplorerTheme()
-
- Return Self
- EndMethod
-
- Method SetColor(r,g,b)
- SendMessageW _hwnd,LVM_SETBKCOLOR ,0,(b Shl 16)|(g Shl 8)|r
- SendMessageW _hwnd,LVM_SETTEXTBKCOLOR ,0,(b Shl 16)|(g Shl 8)|r
- EndMethod
-
- Method RemoveColor()
- SendMessageW _hwnd,LVM_SETBKCOLOR ,1,0
- SendMessageW _hwnd,LVM_SETTEXTBKCOLOR ,1,0
- EndMethod
-
- Method SetTextColor(r,g,b)
- SendMessageW _hwnd,LVM_SETTEXTCOLOR,0,(b Shl 16)|(g Shl 8)|r
- EndMethod
-
- 'Hack: When image lists are removed from listviews, the items don't
- 'reposition themselves automatically. Hack involves first setting a tiny
- 'blank image-list to update item size, before attempting to remove it.
- Method SetIconStrip(iconstrip:TIconStrip)
- Local imagelist
- If Not iconstrip Then
- _icons = TWindowsIconStrip.CreateBlank()
- Else
- _icons = TWindowsIconStrip(iconstrip)
- EndIf
- If _icons Then imagelist = _icons._imagelist
- SendMessageW _hwnd,LVM_SETIMAGELIST,LVSIL_SMALL,imagelist
- If Not iconstrip Then
- SendMessageW _hwnd,LVM_SETIMAGELIST,LVSIL_SMALL,0
- _icons = Null
- EndIf
- EndMethod
-
- Method ClearListItems()
- _selected=-1
- DeSensitize()
- SendMessageW _hwnd,LVM_DELETEALLITEMS,0,0
- If Not IsSingleSelect() Then SelectionChanged()
- Sensitize()
- EndMethod
-
- Method InsertListItem(index,Text$,tip$,icon,tag:Object)
-
- Local it:LVITEMW
- it=New LVITEMW
- it.mask=LVIF_TEXT|LVIF_DI_SETITEM
- it.iItem=index
- it.pszText=Text.toWString()
-
- 'If icon>=0 Then
- it.mask:|LVIF_IMAGE
- it.iImage=icon
- 'EndIf
-
- Desensitize()
- SendMessageW _hwnd,LVM_INSERTITEMW,0,Int Byte Ptr(it)
- SendMessageW _hwnd,LVM_SETCOLUMNWIDTH,0,-2
- If Not IsSingleSelect() Then SelectionChanged()
- Sensitize()
- MemFree it.pszText
-
- EndMethod
-
- Method SetListItem(index,Text$,tip$,icon,tag:Object)
- Local tmpReselect
- If ListItemState(index) & STATE_SELECTED Then tmpReselect = True
- RemoveListItem index
- InsertListItem index,Text,tip,icon,tag
- If tmpReselect Then SetItemState(index,STATE_SELECTED)
- EndMethod
-
- Method RemoveListItem(index)
- Desensitize()
- If ListItemState(index) & STATE_SELECTED Then _selected = -1
- SendMessageW _hwnd,LVM_DELETEITEM,index,0
- SendMessageW _hwnd,LVM_SETCOLUMNWIDTH,0,-2
- If Not IsSingleSelect() Then SelectionChanged()
- Sensitize()
- EndMethod
-
- Method SetListItemState(index,state)
- Local it:LVITEMW = New LVITEMW
- it.mask=LVIF_STATE
- it.iItem=index
- If state&STATE_SELECTED
- it.state=LVIS_SELECTED
- If IsSingleSelect() Then _selected=index
- ElseIf _selected=index
- _selected=-1
- EndIf
- it.stateMask=LVIS_SELECTED
- Desensitize()
- SendMessageW _hwnd,LVM_SETITEMSTATE,index,Int Byte Ptr(it)
- If it.state Then SendMessageW _hwnd,LVM_ENSUREVISIBLE,index,False
- If Not IsSingleSelect() Then SelectionChanged()
- Sensitize()
- EndMethod
-
- Method ListItemState(index)
- Local state = SendMessageW(_hwnd,LVM_GETITEMSTATE,index,LVIS_SELECTED)
- If state&LVIS_SELECTED Return STATE_SELECTED
- EndMethod
-
- Method SetTooltip( pTooltip$ )
- 'ToolTips should be set on an item-by-item basis instead.
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- Case WM_MAXGUILISTREFRESH
- Local index
-
- If IsSingleSelect() Then
- index=SendMessageW(_hwnd,LVM_GETNEXTITEM,-1,LVNI_SELECTED)
- Else
- index = SelectionChanged()
- EndIf
- If index <> _selected Then
- If IsSingleSelect() Then _selected = index
- Local item:TGadgetItem = New TGadgetItem
- If index>=0 And index<items.length item=items[index]
- PostGuiEvent EVENT_GADGETSELECT,index,0,0,0,item.extra
- EndIf
-
- 'If we are using XP Common Controls or higher, then the listbox will be double-buffered
- 'and so we don't need to clear the background (performance tweak).
- Case WM_ERASEBKGND
- If TWindowsGUIDriver.CheckCommonControlVersion() Then Return 1
- EndSelect
- Return Super.WndProc(hwnd,msg,wp,lp)
- EndMethod
-
- Method OnNotify(wp,lp)
- Local nmhdr:Int Ptr = Int Ptr(lp)
- Local index, code = nmhdr[2]
- Select code
-
- Case LVN_GETINFOTIPW
- Local tmpItemIndex = nmhdr[6]
- Local tmpMaxCharCount = nmhdr[5]-1
- Local tmpTipOutput:Short Ptr = Short Ptr(nmhdr[4])
-
- If tmpItemIndex < items.length Then
-
- Local tmpTipString$ = items[tmpItemIndex].tip
- If (items[tmpItemIndex].flags&GADGETITEM_LOCALIZED) Then tmpTipString = LocalizeString(tmpTipString)
-
- tmpTipString = tmpTipString[..Min(tmpTipString.length,tmpMaxCharCount)]
-
- Local tmpBufferMem:Short Ptr = tmpTipString.ToWString()
- MemCopy tmpTipOutput, tmpBufferMem, (tmpTipString.length+1) * 2
- MemFree tmpBufferMem
-
- EndIf
-
- Case LVN_ITEMCHANGED
- 'We need to postpone processing until after *all* item states have been updated by the OS.
- If Not(nmhdr[7]&LVIF_STATE) Then Return
- PostMessageW( _hwnd, WM_MAXGUILISTREFRESH, 0, 0 )
- Case NM_DBLCLK
- index=nmhdr[3]
- Local item:TGadgetItem
- If index>=0 And index<items.length
- item=items[index]
- PostGuiEvent EVENT_GADGETACTION,index,0,0,0,item.extra
- EndIf
- Case NM_CLICK
- index=nmhdr[3]
- If index=-1 And _selected<>-1
- _selected=-1
- PostGuiEvent EVENT_GADGETSELECT,-1
- EndIf
- Case NM_RCLICK
- index=nmhdr[3]
- Local item:TGadgetItem
- If index>=0 And index<items.length
- item=items[index]
- PostGuiEvent EVENT_GADGETMENU,index,0,0,0,item.extra
- EndIf
- 'Return true to tell the OS not to send individual LVN_DELETEITEM notifications for each and every item when clearing list.
- Case LVN_DELETEALLITEMS
- Return True
- End Select
- EndMethod
-
- Method IsSingleSelect()
- Return (style&LISTBOX_MULTISELECT<>LISTBOX_MULTISELECT)
- EndMethod
-
- Method Class()
- Return GADGET_LISTBOX
- EndMethod
-
- Method HasResized()
- SendMessageW _hwnd,LVM_SETCOLUMNWIDTH,0,-2
- EndMethod
-
- Method UseExplorerTheme()
- If TWindowsGUIDriver.CheckCommonControlVersion() And SetWindowThemeW Then SetWindowThemeW( _hwnd, _wstrExplorer, Null )
- EndMethod
-
-EndType
-
-Type TWindowsComboBox Extends TWindowsGadget
-
- Field _icons:TWindowsIconStrip
- Field _editHwnd, _comboHwnd
- Field _selected = -1
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey,hwnd
- Local parent,editstyle,combostyle
-
- Self.style = style
- wstyle=WS_CHILD|WS_TABSTOP|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|CBS_AUTOHSCROLL
- If (style & COMBOBOX_EDITABLE) Then wstyle:|CBS_DROPDOWN Else wstyle:|CBS_DROPDOWNLIST
-
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"ComboBoxEx32","",wstyle,0,0,0,180,parent,hotkey,GetModuleHandleW(Null),Null)
-
- If (style & COMBOBOX_EDITABLE) Then
- _editHwnd=SendMessageW(hwnd,CBEM_GETEDITCONTROL,0,0)
- If _editHwnd Then
- editstyle=GetWindowLongW(_editHwnd,GWL_STYLE)
- SetWindowLongW _editHwnd,GWL_STYLE,editstyle|WS_TABSTOP
- EndIf
- EndIf
-
- _comboHwnd=SendMessageW(hwnd,CBEM_GETCOMBOCONTROL,0,0)
- comboStyle=GetWindowLongW(_comboHwnd,GWL_STYLE)
- SetWindowLongW _comboHwnd,GWL_STYLE,comboStyle|WS_TABSTOP
-
- Register GADGET_COMBOBOX,hwnd
-
- TWindowsGUIDriver.RegisterHwnd(_combohwnd,Self)
- If _edithwnd Then TWindowsGUIDriver.RegisterHwnd(_edithwnd,Self)
-
- SetColor(255,255,255)
-
- Return Self
-
- EndMethod
-
- Method SetText(Text$)
- If Not _editHwnd Then
- Local tmpWString:Short Ptr = Text.ToWString()
- Local tmpResult = SendMessageW(_comboHwnd, CB_SETCUEBANNER, 0, Int(tmpWString))
- MemFree tmpWString;Return tmpResult
- Else
- Return Super.SetText(Text)
- EndIf
- EndMethod
-
- Method GetText$()
- If Not _editHwnd Then
- If _selected > -1 Then Return items[_selected].Text Else Return ""
- Else
- Return Super.GetText()
- EndIf
- EndMethod
-
- Method Activate(cmd)
- If _editHwnd Then
- Select cmd
- Case ACTIVATE_CUT
- SendMessageW _editHwnd,WM_CUT,0,0
- Case ACTIVATE_COPY
- SendMessageW _editHwnd,WM_COPY,0,0
- SetFocus _hwnd
- Case ACTIVATE_PASTE
- SendMessageW _editHwnd,WM_PASTE,0,0
- Case ACTIVATE_FOCUS
- SendMessageW _editHwnd,EM_SETSEL,0,-1
- End Select
- EndIf
- Return Super.Activate(cmd)
- EndMethod
-
- Method SetIconStrip(iconstrip:TIconStrip)
- Local imagelist
- _icons=TWindowsIconStrip(iconstrip)
- If _icons Then imagelist = _icons._imagelist
- SendMessageW _hwnd,CBEM_SETIMAGELIST,LVSIL_SMALL,imagelist
- EndMethod
-
- Method ClearListItems()
- _selected=-1
- Desensitize()
- SendMessageW _hwnd,CB_RESETCONTENT,0,0
- Sensitize()
- EndMethod
-
- Method InsertListItem(index,Text$,tip$,icon,tag:Object)
- Local it:COMBOBOXEXITEMW = New COMBOBOXEXITEMW
- it.mask=CBEIF_TEXT
- it.iItem=index
- it.pszText=Text.toWString()
- If icon>=0
- it.mask:|CBEIF_IMAGE|CBEIF_SELECTEDIMAGE
- it.iImage=icon
- it.iSelectedImage=icon
- EndIf
- Desensitize()
- SendMessageW(_hwnd,CBEM_INSERTITEMW,0,Int Byte Ptr(it))
- Sensitize()
- MemFree it.pszText
- EndMethod
-
- Method SetListItem(index,Text$,tip$,icon,tag:Object)
- Local it:COMBOBOXEXITEMW = New COMBOBOXEXITEMW
- it.mask=CBEIF_TEXT
- it.iItem=index
- it.pszText=Text.toWString()
- If _icons And icon>-1
- it.mask:|CBEIF_IMAGE|CBEIF_SELECTEDIMAGE
- it.iImage=icon
- it.iSelectedImage=icon
- EndIf
- Desensitize()
- SendMessageW(_hwnd,CBEM_SETITEMW,0,Int Byte Ptr(it))
- Sensitize()
- MemFree it.pszText
- EndMethod
-
- Method RemoveListItem(index)
- Desensitize()
- SendMessageW _hwnd,CBEM_DELETEITEM,index,0
- Sensitize()
- EndMethod
-
- Method SetListItemState(index,state)
- If state&STATE_SELECTED
- _selected=index
- Else
- If _selected=index _selected=-1
- index=-1
- EndIf
- Desensitize()
- SendMessageW _hwnd,CB_SETCURSEL,index,0
- Sensitize()
- EndMethod
-
- Method ListItemState(index)
- Local Current,state
- Current=SendMessageW(_hwnd,CB_GETCURSEL,0,0)
- If Current=CB_ERR Current=-1
- If Current=index state=STATE_SELECTED
- Return state
- EndMethod
-
- Method OnCommand(msg,wp)
- Local index
- Select wp Shr 16
- Case CBN_SELCHANGE
- index=SendMessageW(_hwnd,CB_GETCURSEL,0,0)
- If index=CB_ERR
- index=-1
- Else
- If _selected<>index 'user generated event
- _selected=index
- Local extra:Object
- If index>=0 And index<items.length extra=items[index].extra
- PostGuiEvent EVENT_GADGETACTION,index,0,0,0,extra
- EndIf
- EndIf
- Case CBN_EDITCHANGE
- _selected=-1
- PostGuiEvent EVENT_GADGETACTION,-1
- End Select
- EndMethod
-
- Method Class()
- Return GADGET_COMBOBOX
- EndMethod
-
-EndType
-
-Type TWindowsToolbar Extends TWindowsGadget
- Field _icons:TWindowsIconStrip
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
- Self.style = style
- xstyle=TBSTYLE_EX_DOUBLEBUFFER|TBSTYLE_EX_HIDECLIPPEDBUTTONS
- wstyle=TBSTYLE_FLAT|WS_CHILD|WS_CLIPSIBLINGS|TBSTYLE_TRANSPARENT
- Self.parent = group
- parent=Self.parent.query(QUERY_HWND)
- hwnd=CreateWindowExW(xstyle,"ToolbarWindow32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- DragAcceptFiles(hwnd,False) 'For some reason, toolbars may accept files by default!
- Register GADGET_TOOLBAR,hwnd,0,True
- SendMessageW _hwnd,TB_SETTOOLTIPS,_tooltips,0
- Rethink()
- Return Self
- EndMethod
-
- Method SetIconStrip(iconstrip:TIconStrip)
- _icons=TWindowsIconStrip(iconstrip)
- SendMessageW _hwnd,TB_SETIMAGELIST,0,_icons._imagelist
- SendMessageW _hwnd,TB_AUTOSIZE,0,0
- Rethink
- EndMethod
-
- Method SetShow(truefalse)
- Super.SetShow(truefalse)
- UpdateWindowClient()
- EndMethod
-
- Method Free()
- SetShow(False)
- Super.Free()
- EndMethod
-
- Method Rethink()
-
- Local tmpRect[4]
- GetWindowRect _hwnd,tmpRect
- SetRect(0,0,parent.ClientWidth(),(tmpRect[3]-tmpRect[1]))
- QueueResize _hwnd,xpos,ypos,width,height
- UpdateWindowClient()
-
- EndMethod
-
- Method UpdateWindowClient()
- Local tmpHeight:Int = height
- If (State()&STATE_HIDDEN) Then tmpHeight = 0
- If TWindowsGadget(parent)._clientY <> tmpHeight Then
- TWindowsGadget(parent)._clientY = tmpHeight
- parent.Rethink()
- TWindowsGadget(parent).RethinkClient()
- parent.LayoutKids()
- EndIf
- EndMethod
-
- Method DoLayout()
- Rethink()
- EndMethod
-
- Method SetTooltip( pTooltip$ )
- 'ToolTips should be set on an item-by-item basis instead.
- EndMethod
-
- Method ClearListItems()
- While SendMessageW(_hwnd,TB_BUTTONCOUNT,0,0)
- RemoveListItem(0)
- Wend
- EndMethod
-
- Method InsertListItem(index,Text$,tip$,icon,tag:Object)
- Local but:TBBUTTON
- but=New TBBUTTON
- but.fsState=TBSTATE_ENABLED
- If icon = -2 Or (icon>-1 And _icons.IsBlankIcon(icon))
- but.idCommand=0
- but.fsStyle=TBSTYLE_SEP
- Else
- but.iBitmap=icon
- but.idCommand=index+1
- but.fsStyle=TBSTYLE_BUTTON
- EndIf
- Desensitize()
- SendMessageW _hwnd,TB_INSERTBUTTON,index,Int Byte Ptr(but)
- Sensitize()
- If tip
- Local ti:TOOLINFOW=New TOOLINFOW
- ti.cbSize=SizeOf(ti)
- ti.uFlags=TTF_SUBCLASS
- ti.hwnd=_hwnd
- ti.lpszText=tip.towstring()
- ti.uId=index+1
- SendMessageW _hwnd,TB_GETITEMRECT,index,Int(Varptr ti.rect_left)
- SendMessageW _tooltips,TTM_ADDTOOLW,0,Int Byte Ptr(ti)
- MemFree ti.lpszText
- EndIf
- EndMethod
-
- Method SetListItem(index,Text$,tip$,icon,tag:Object)
- Local tmpState:Int = ListItemState(index)
- RemoveListItem index
- InsertListItem index,Text,tip,icon,tag
- SetListItemState(index,tmpState)
- EndMethod
-
- Method RemoveListItem(index)
- Local ti:TOOLINFOW=New TOOLINFOW
- ti.cbSize=SizeOf(ti)
- ti.hwnd=_hwnd
- ti.uId=index+1
- Desensitize()
- SendMessageW _tooltips,TTM_DELTOOLW,0,Int(Varptr ti)
- SendMessageW _hwnd,TB_DELETEBUTTON,index,0
- Sensitize()
- EndMethod
-
- Method SetListItemState(index,state)
- Local enable,pressed
- If state&STATE_DISABLED=0 enable=$1
- If state&STATE_SELECTED pressed=$1
- SendMessageW _hwnd,TB_ENABLEBUTTON,index+1,enable
- SendMessageW _hwnd,TB_CHECKBUTTON,index+1,pressed
- EndMethod
-
- Method ListItemState(index)
- Local state,flags
- state=SendMessageW(_hwnd,TB_GETSTATE,index+1,0)
- If state=-1 Return 0
- If Not (state&TBSTATE_ENABLED) flags:|STATE_DISABLED
- If state&TBSTATE_CHECKED flags:|STATE_SELECTED
- Return flags
- EndMethod
-
- Method OnCommand(msg,wp)
- Local index=wp-1
- Local extra:Object
- If index>=0 And index<items.length extra=items[index].extra
- PostGuiEvent EVENT_GADGETACTION,index,0,0,0,extra
- EndMethod
-
- Method Class()
- Return GADGET_TOOLBAR
- EndMethod
-
-EndType
-
-Type TWindowsTabber Extends TWindowsGadget
-
- Field _icons:TWindowsIconStrip
- Field _tabcount
- Field _blank:Short Ptr
- Field _selected = -1
- Field _tipbuffer:Short Ptr
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent,client
- Self.style = style
- xstyle=WS_EX_CONTROLPARENT
- wstyle=WS_CHILD|TCS_HOTTRACK|WS_TABSTOP|TCS_FOCUSNEVER|WS_CLIPCHILDREN|WS_CLIPSIBLINGS
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"SysTabControl32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- client=CreateWindowExW(xstyle,TWindowsGUIDriver.ClassName(),"",WS_CHILD|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null )
- SendMessageW hwnd,TCM_INSERTITEMW,0,Int(_wstrSpace)
- Register GADGET_TABBER,hwnd,client,True
- SendMessageW _hwnd,TCM_SETTOOLTIPS,_tooltips,0
- Return Self
- EndMethod
-
- Method SetIconStrip(iconstrip:TIconStrip)
- Local imagelist
- _icons=TWindowsIconStrip(iconstrip)
- If _icons Then imagelist = _icons._imagelist
- SendMessageW _hwnd,TCM_SETIMAGELIST,0,imagelist
- RethinkClient()
- EndMethod
-
- Method ClientWidth()
- Local Rect[] = [0,0,width,height]
- SendMessageW _hwnd,TCM_ADJUSTRECT,False,Int Byte Ptr(Rect)
- If Rect[2]>Rect[0] Then Return Rect[2]-Rect[0]
- EndMethod
-
- Method ClientHeight()
- Local Rect[] = [0,0,width,height]
- SendMessageW _hwnd,TCM_ADJUSTRECT,False,Int Byte Ptr(Rect)
- If Rect[3]>Rect[1] Then Return Rect[3]-Rect[1]
- EndMethod
-
- Method ClearListItems()
- _tabcount=0
- _selected=-1
- Desensitize()
- SendMessageW _hwnd,TCM_DELETEALLITEMS, 0, 0
- Sensitize()
- RethinkClient()
- EndMethod
-
- Method InsertListItem(index,Text$,tip$,icon,tag:Object)
- If _tabcount=0 SendMessageW _hwnd,TCM_DELETEALLITEMS,0,0
- Local t:TCITEMW=New TCITEMW
- t.mask=TCIF_TEXT|TCIF_IMAGE
- t.pszText=Text.toWString()
- t.iImage=icon
- Desensitize()
- SendMessageW _hwnd,TCM_INSERTITEMW,index,Int Byte Ptr(t)
- Sensitize()
- MemFree t.pszText
- _tabcount:+1
- RethinkClient()
- EndMethod
-
- Method SetListItem(index,Text$,tip$,icon,tag:Object)
- Local t:TCITEMW=New TCITEMW
- t.mask=TCIF_TEXT|TCIF_IMAGE
- t.pszText=Text.toWString()
- t.iImage=icon
- Desensitize()
- SendMessageW _hwnd,TCM_SETITEMW,index,Int Byte Ptr(t)
- Sensitize()
- MemFree t.pszText
- RethinkClient()
- EndMethod
-
- Method RemoveListItem(index)
- Desensitize()
- SendMessageW _hwnd,TCM_DELETEITEM,index,0
- _tabcount:-1
- _selected=SendMessageW(_hwnd,TCM_GETCURSEL,0,0)
- If _tabcount=0 SendMessageW _hwnd,TCM_INSERTITEMW,0,Int(_blank)
- Sensitize()
- RethinkClient()
- EndMethod
-
- Method SetListItemState(index,state)
- Desensitize()
- If state&STATE_SELECTED
- _selected=index
- SendMessageW _hwnd,TCM_SETCURSEL,index,0
- ElseIf _selected=index
- _selected=-1
- EndIf
- Sensitize()
- EndMethod
-
- Method ListItemState(index)
- Local state,Current
- Current=-1
- If _tabcount Current=SendMessageW(_hwnd,TCM_GETCURSEL,0,0)
- If Current=index state:|STATE_SELECTED
- Return state
- EndMethod
-
- Method OnNotify(wp,lp)
- Local nmhdr:Int Ptr 'hwnd,id,code
- Local index
- nmhdr=Int Ptr(lp)
- Select nmhdr[2]
-
- Case TTN_GETDISPINFOW
-
- Local TCHITTESTINFO[3], Rect[4]
-
- GetCursorPos_( TCHITTESTINFO );GetWindowRect( _hwnd, Rect )
- TCHITTESTINFO = [TCHITTESTINFO[0]-Rect[0],TCHITTESTINFO[1]-Rect[1],0]
-
- Local tmpItem = SendMessageW( _hwnd, TCM_HITTEST, 0, Int Byte Ptr TCHITTESTINFO )
-
- If (tmpItem > -1) And (tmpItem < items.length) Then
- Local tmpTooltip$ = items[tmpItem].tip
- If (items[tmpItem].flags&GADGETITEM_LOCALIZED) Then tmpTooltip = LocalizeString(tmpTooltip)
- SetTipBuffer( tmpTooltip )
- If tmpTooltip Then nmhdr[3] = Int(_tipbuffer)
- EndIf
-
- Case TCN_SELCHANGE
- If _tabcount
- index=SendMessageW(_hwnd,TCM_GETCURSEL,0,0)
- If index<>_selected
- Local extra:Object
- If index>=0 And index<items.length
- extra=items[index].extra
- Else
- index=-1
- EndIf
- _selected=index
-
- PostGuiEvent EVENT_GADGETACTION,index,0,0,0,extra
- EndIf
- EndIf
-
- Case NM_RCLICK
-
- Local TCHITTESTINFO[3], Rect[4], extra:Object
-
- GetCursorPos_( TCHITTESTINFO );GetWindowRect( _hwnd, Rect )
- TCHITTESTINFO = [TCHITTESTINFO[0]-Rect[0],TCHITTESTINFO[1]-Rect[1],0]
-
- Local index = SendMessageW( _hwnd, TCM_HITTEST, 0, Int Byte Ptr TCHITTESTINFO )
- If (index < 0) Or (index >= items.length) Then index = -1 Else extra = items[index].extra
-
- PostGuiEvent EVENT_GADGETMENU,index,0,TCHITTESTINFO[0],TCHITTESTINFO[1],extra
-
- EndSelect
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- Case WM_ERASEBKGND
- Select hwnd
- Case _hwndclient
- If DrawThemeParentBackground Then
- DrawParentBackground(wp,hwnd)
- Return 1
- EndIf
- EndSelect
- End Select
- Return Super.WndProc(hwnd,msg,wp,lp)
- EndMethod
-
- Method RethinkClient(forceRedraw:Int = False)
- Local Rect[] = [0,0,width,height]
- SendMessageW _hwnd,TCM_ADJUSTRECT,False, Int Byte Ptr(Rect)
- MoveWindow _hwndclient,Rect[RECT_LEFT],Rect[RECT_TOP],Rect[RECT_RIGHT]-Rect[RECT_LEFT],Rect[RECT_BOTTOM]-Rect[RECT_TOP],forceRedraw
- EndMethod
-
- Method SetTipBuffer( pTip$ )
- If _tipbuffer Then MemFree _tipbuffer
- If pTip Then _tipbuffer = pTip.ToWString()
- EndMethod
-
- Method SetTooltip( pTooltip$ )
- 'ToolTips should be set on an item-by-item basis instead.
- EndMethod
-
- Method Class()
- Return GADGET_TABBER
- EndMethod
-
-EndType
-
-Type TWindowsTreeNode Extends TGadget
- Field _parent:TWindowsTreeNode
- Field _tree 'HWND
- Field _item 'HTREEITEM
- Field _expanded
- Field _icon
- Field _handle
-
- Method Activate(cmd)
- Local tmpTree:TWindowsTreeView = TWindowsTreeView(TWindowsGUIDriver.GadgetFromHwnd(_tree))
- If tmpTree Then tmpTree.Desensitize()
- Select cmd
- Case ACTIVATE_SELECT
- If _item <> TVI_ROOT Then
- SendMessageW _tree,TVM_SELECTITEM,TVGN_CARET,_item
- Else
- SendMessageW _tree,TVM_SELECTITEM,TVGN_CARET,0
- EndIf
- Case ACTIVATE_EXPAND
- SendMessageW _tree,TVM_EXPAND,TVE_EXPAND,_item
- _expanded=True
- Case ACTIVATE_COLLAPSE
- SendMessageW _tree,TVM_EXPAND,TVE_COLLAPSE,_item
- _expanded=False
- Case ACTIVATE_REDRAW
- RedrawNode()
- End Select
- If tmpTree Then tmpTree.Sensitize()
- EndMethod
-
- Method CreateRoot:TWindowsTreeNode(owner:TWindowsTreeView)
- _tree=owner._hwnd
- _item=TVI_ROOT
- Return Self
- EndMethod
-
- Method CountKids()
- Return kids.count()
- EndMethod
-
- Method Create:TWindowsTreeNode(group:TGadget,style,Text$="",index=-1,icon = -1)
- _parent=TWindowsTreeNode(group)
- If Not _parent Throw "Parent isn't a treeview node. Use TreeViewRoot() when creating a root node."
- Self.style = style
- _tree=_parent._tree
- _icon = icon
- Spawn(Text,index)
- _SetParent group,index
- If (LocalizationMode()&LOCALIZATION_OVERRIDE) Then
- LocalizeGadget(Self, Text, "")
- EndIf
- Return Self
- EndMethod
-
- Method GetText$()
- Local item[10]
- Local buffer:Short[260]
- item[0]=TVIF_TEXT
- item[1]=_item
- item[4]=Int Byte Ptr buffer
- item[5]=256
- SendMessageW _tree,TVM_GETITEMW,0,Int Byte Ptr(item)
- Return String.FromWString(buffer)
- EndMethod
-
- Method SetText(Text$)
- Local tv:TVITEMW=New TVITEMW
- tv.mask=TVIF_HANDLE|TVIF_TEXT
- tv.hItem = _item
- If _icon > -1 Then
- tv.mask:|TVIF_IMAGE|TVIF_SELECTEDIMAGE
- tv.iImage=_icon
- tv.iSelectedImage=tv.iImage
- EndIf
- tv.pszText=Text.ToWString()
- SendMessageW(_tree,TVM_SETITEMW,0,Int Byte Ptr tv)
- MemFree tv.pszText
- EndMethod
-
- Method DoLayout()
- 'Don't do anything!
- EndMethod
-
- Method Free()
- 'If we don't have a parent then the node must have previously been freed.
- If Not _parent Then Return
- 'Avoid firing events when freeing a treenode that is selected.
- If SendMessageW(_tree,TVM_GETNEXTITEM,TVGN_CARET,0) Then DeSelect()
- 'Free treenode
- If _item Then SendMessageW(_tree,TVM_DELETEITEM,0,_item);_item=0
- 'Redraw parent if we were its last child node
- If Not SendMessageW(_tree, TVM_GETNEXTITEM, TVGN_CHILD, _parent._item) Then _parent.RedrawNode()
- 'Cleanup variables that could be circular references
- _parent = Null;_tree = 0;_SetParent Null
- 'Release any handle we created using HandleFromObject() in Spawn()
- If _handle Then Release _handle
- EndMethod
-
- Method DeSelect()
- SendMessageW _tree,TVM_SELECTITEM,TVGN_CARET,0
- EndMethod
-
- Method InsertNode:TGadget(index,Text$,icon)
- Return New TWindowsTreeNode.Create(Self,0,Text,index,icon)
- EndMethod
-
- Method ModifyNode(Text$,icon)
- _icon = icon
- SetText Text
- EndMethod
-
- Method tviatindex(index)
- If kids.IsEmpty() Then Return TVI_FIRST
- If index<0 Or index>=kids.count() Return TVI_LAST
- Local child:TWindowsTreeNode
- child=TWindowsTreeNode(kids.valueatindex(index))
- Return child._item
- EndMethod
-
- Method Spawn(name$,index=-1)
-
- Local it:TVINSERTSTRUCTW
- Local hitem
- it=New TVINSERTSTRUCTW
- it.hParent=_parent._item
- If index = 0 Then
- it.hInsertAfter = TVI_FIRST
- Else
- it.hInsertAfter=_parent.tviatindex(index-1)
- EndIf
- it.item_mask=TVIF_TEXT|TVIF_PARAM
-
- If _icon > -1 Then
- it.item_mask:|TVIF_IMAGE|TVIF_SELECTEDIMAGE
- it.item_iImage=_icon
- it.item_iSelectedImage=it.item_iImage
- EndIf
-
- Local tmpParentHadKids = SendMessageW(_tree, TVM_GETNEXTITEM, TVGN_CHILD, _parent._item)
-
- it.item_pszText=name.ToWString()
- it.item_lparam=HandleFromObject(Self)
-
- 'Make sure that we store handle so we can release it later.
- If _handle Then Release _handle
- _handle = it.item_lparam
-
- _item=SendMessageW(_tree,TVM_INSERTITEMW,0,Int Byte Ptr it)
-
- MemFree it.item_pszText
-
- 'Fix for tree-view parent status update problem.
- If Not tmpParentHadKids Then _parent.RedrawNode()
-
- Return _item
-
- EndMethod
-
- Method RedrawNode()
-
- If _item = TVI_ROOT Then
- InvalidateRect _tree, Null, True
- Else
- Local Rect[] = [_item,0,0,0]
- If SendMessageW(_tree, TVM_GETITEMRECT, False, Int Byte Ptr Rect) Then
- InvalidateRect _tree, Rect, True
- EndIf
- EndIf
-
- EndMethod
-
- Method SetTooltip( pTooltip$ )
- 'At the moment, nodes don't support tooltips.
- EndMethod
-
- Method Class()
- Return GADGET_NODE
- EndMethod
-
-EndType
-
-Type TWindowsTreeView Extends TWindowsGadget
-
- Field _root:TWindowsTreeNode
- Field _selected:TWindowsTreeNode
- Field _icons:TWindowsIconStrip
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
-
- Self.style = style
- xstyle=WS_EX_CLIENTEDGE
- wstyle=WS_CHILD|TVS_HASLINES|TVS_HASBUTTONS|TVS_LINESATROOT|TVS_SHOWSELALWAYS|TVS_NOTOOLTIPS|WS_CLIPSIBLINGS
- If Not(style&TREEVIEW_DRAGNDROP) wstyle:|TVS_DISABLEDRAGDROP
-
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"SysTreeView32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- If TWindowsGUIDriver.CheckCommonControlVersion() Then SendMessageW hwnd, TVM_SETEXTENDEDSTYLE, TVS_EX_DOUBLEBUFFER, TVS_EX_DOUBLEBUFFER
- Register GADGET_TREEVIEW,hwnd
- _root=New TWindowsTreeNode.CreateRoot(Self)
-
- If TWindowsGUIDriver._explorerstyle Then UseExplorerTheme()
-
- Return Self
-
- EndMethod
-
- Method SetIconStrip(iconstrip:TIconStrip)
- _icons=TWindowsIconStrip(iconstrip)
- SendMessageW _hwnd,TVM_SETIMAGELIST,TVSIL_NORMAL,_icons._imagelist
- EndMethod
-
- Method SetColor(r,g,b)
- SendMessageW _hwnd,TVM_SETBKCOLOR,0,(b Shl 16)|(g Shl 8)|r
- EndMethod
-
- Method RemoveColor()
- SendMessageW _hwnd,TVM_SETBKCOLOR,1,0
- EndMethod
-
- Method SetTextColor(r,g,b)
- SendMessageW _hwnd,TVM_SETTEXTCOLOR,0,(b Shl 16)|(g Shl 8)|r
- EndMethod
-
- Method RootNode:TGadget()
- Return _root
- EndMethod
-
- Method SelectedNode:TGadget()
- Return _selected
- EndMethod
-
- Method CountKids()
- Return _root.CountKids()
- EndMethod
-
- Method OnNotify(wp,lp)
- Local nmhdr:Int Ptr
- Local itemnew:Int Ptr
- Local node:TWindowsTreeNode
-
- Super.OnNotify(wp,lp) 'Tool-tips
-
- nmhdr=Int Ptr(lp)
- Select nmhdr[2] 'code
-
- 'MSLU glitch requires handling of ANSI equivalent
- Case TVN_SELCHANGEDW, TVN_SELCHANGEDA
- itemnew=nmhdr+14 'Int Ptr(nmhdr[5]) 'itemNew
- If itemnew[1]=TVI_ROOT 'hItem
- _selected=_root
- Else
- _selected=TWindowsTreeNode(HandleToObject(itemnew[9])) 'lParaM
- EndIf
- PostGuiEvent EVENT_GADGETSELECT,0,0,0,0,_selected
-
- Case TVN_ITEMEXPANDEDW, TVN_ITEMEXPANDEDA
- itemnew=nmhdr+14 'Int Ptr(nmhdr[5]) 'itemNew.TVITEM
- If itemnew[1]=TVI_ROOT 'hItem
- node=_root
- Else
- node=TWindowsTreeNode(HandleToObject(itemnew[9] )) 'lParaM
- EndIf
- Select nmhdr[3] 'action itemnew[2]&TVIS_EXPANDED 'state
- Case 1
- PostGuiEvent EVENT_GADGETCLOSE,0,0,0,0,node
- node._expanded=False
- Case 2
- PostGuiEvent EVENT_GADGETOPEN,0,0,0,0,node
- node._expanded=True
- End Select
- Return True
-
- Case TVN_BEGINDRAGW, TVN_BEGINRDRAGW, TVN_BEGINDRAGA, TVN_BEGINRDRAGA
-
- If (style&TREEVIEW_DRAGNDROP) Then
-
- Local data% = 1
- If (nmhdr[2] = TVN_BEGINRDRAGW) Or (nmhdr[2] = TVN_BEGINRDRAGA) Then data = 2
-
- itemnew=nmhdr+14 'Int Ptr(nmhdr[5]) 'itemNew
-
- If itemnew[1]<>TVI_ROOT Then
- TGadget.dragGadget[data-1]=TWindowsTreeNode(HandleToObject(itemnew[9]))
- PostGuiEvent EVENT_GADGETDRAG, data, KeyMods(), itemnew[10], itemnew[11], TGadget.dragGadget[data-1]
- Else
- TGadget.dragGadget[data-1]=Null
- EndIf
-
- EndIf
-
- Case NM_DBLCLK, NM_RETURN
- PostGuiEvent EVENT_GADGETACTION,0,0,0,0,_selected
-
- Case NM_RCLICK
- Local Rect[4]
- Local pt[2]
- Local hittest[4]
- Local item[10]
- GetWindowRect _hwnd,Rect
- GetCursorPos_ pt
- hittest[0]=pt[0]-Rect[0]
- hittest[1]=pt[1]-Rect[1]
- If SendMessageW(_hwnd,TVM_HITTEST,0,Int Byte Ptr(hittest))
- If hittest[3]=TVI_ROOT
- node=_root
- Else
- item[0]=TVIF_PARAM
- item[1]=hittest[3]
- SendMessageW _hwnd,TVM_GETITEMW,0,Int Byte Ptr(item)
- node=TWindowsTreeNode(HandleToObject(item[9]))
- EndIf
- PostGuiEvent EVENT_GADGETMENU,0,hittest[0],hittest[1],0,node
- EndIf
- Return True
-
- EndSelect
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- 'If we are using Vista's common controls, then the treeview will be double-buffered and so
- 'we don't need to clear the background when redrawing (performance tweak).
- Case WM_ERASEBKGND
- If TWindowsGUIDriver.CheckCommonControlVersion() >= 2 Then Return 1
- EndSelect
- Return Super.WndProc(hwnd,msg,wp,lp)
- EndMethod
-
- Method UseExplorerTheme()
-
- If TWindowsGUIDriver.CheckCommonControlVersion() And SetWindowThemeW Then
- SetWindowThemeW( _hwnd, _wstrExplorer, Null )
- SendMessageW _hwnd, TVM_SETEXTENDEDSTYLE, TVS_EX_FADEINOUTEXPANDOS, TVS_EX_FADEINOUTEXPANDOS
- EndIf
-
- EndMethod
-
- Method Class()
- Return GADGET_TREEVIEW
- EndMethod
-
-EndType
-
-Type TWindowsLabel Extends TWindowsGadget
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
-
- Self.style = style
- wstyle=WS_CHILD|SS_NOPREFIX|WS_CLIPSIBLINGS|SS_NOTIFY
-
- Select style&24
- Case LABEL_LEFT wstyle:|SS_LEFT
- Case LABEL_RIGHT wstyle:|SS_RIGHT
- Case LABEL_CENTER wstyle:|SS_CENTER
- End Select
- Select style&7
- Case LABEL_FRAME wstyle:|WS_BORDER
- Case LABEL_SUNKENFRAME wstyle:|SS_SUNKEN
- Case LABEL_SEPARATOR wstyle:|SS_SUNKEN|SS_GRAYRECT
- End Select
-
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"STATIC","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- Register GADGET_LABEL,hwnd
-
- Return Self
- EndMethod
-
- Method SetArea(x,y,w,h)
- If ((style & 7) = LABEL_SEPARATOR) Then
- If (w > h) Then h = 2 Else w = 2
- EndIf
- Return Super.SetArea(x,y,w,h)
- EndMethod
-
- Method SetText(Text$)
- If ((style & 7) <> LABEL_SEPARATOR) Then Return Super.SetText(Text)
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- Case WM_ERASEBKGND
- Return 1
- EndSelect
- Return Super.WndProc(hwnd,msg,wp,lp)
- EndMethod
-
- Method Class()
- Return GADGET_LABEL
- EndMethod
-
-EndType
-
-Type TWindowsSlider Extends TWindowsGadget
- Field _slidertype,_ishorizontal,_visible = 5,_total = 10,_value
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,class$
- Local hwnd,parent,hotkey
-
- _slidertype=style&$fffc
- _ishorizontal=style&SLIDER_HORIZONTAL
-
- Self.style = style
- wstyle=WS_CHILD|WS_CLIPSIBLINGS|WS_CLIPCHILDREN
- parent=group.query(QUERY_HWND_CLIENT)
- Select _slidertype
- Case SLIDER_SCROLLBAR
- If _ishorizontal wstyle:|SBS_HORZ;Else wstyle:|SBS_VERT
- class$="SCROLLBAR"
- Case SLIDER_TRACKBAR
- wstyle:|TBS_AUTOTICKS|WS_TABSTOP
- xstyle:|WS_EX_COMPOSITED 'Reduces flicker when resizing (doesn't like scrollbars/up-down controls)
- If _ishorizontal wstyle:|TBS_HORZ Else wstyle:|TBS_VERT
- class$=TRACKBAR_CLASS
- Case SLIDER_STEPPER
- If _ishorizontal wstyle:|UDS_HORZ
- class$="msctls_updown32"
- Default
- Return Null
- End Select
-
- hwnd=CreateWindowExW(xstyle,class,"",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- Register GADGET_SLIDER,hwnd
- RefreshLook()
-
- Return Self
- EndMethod
-
- Method SetRange(visible,total)
- _visible = visible
- _total = total
- Local tmpEnabled:Int = Not( State() & STATE_DISABLED )
- Desensitize()
- Select _slidertype
- Case SLIDER_SCROLLBAR
- Local info:SCROLLINFO=New SCROLLINFO
- info.cbSize=SizeOf(SCROLLINFO)
- info.fMask=SIF_PAGE|SIF_RANGE
- info.nMax=total-1
- info.nPage=visible
- SendMessageW _hwnd,SBM_SETSCROLLINFO,True,Int Byte Ptr info
- Case SLIDER_TRACKBAR
-
- SendMessageW _hwnd,TBM_SETRANGEMIN,False,visible
- SendMessageW _hwnd,TBM_SETRANGEMAX,True,total
-
- ' Aesthetic tweak that should stop black tick bands forming when
- ' large ranges are used on small trackbars.
-
- Local tmpFirstTick% = SendMessageW( _hwnd, TBM_GETTICPOS, 0, 0 )
- Local tmpNumTicks% = SendMessageW( _hwnd, TBM_GETNUMTICS, 0, 0)
- Local tmpLastTick% = SendMessageW( _hwnd, TBM_GETTICPOS, tmpNumTicks-3, 0 )
- If Not( tmpLastTick < 0 Or tmpFirstTick < 0 Or (total-visible-2) < 1) Then
- If (tmpLastTick-tmpFirstTick)/(total-visible-2) < 4 Then
- SendMessageW( _hwnd, TBM_CLEARTICS, True, 0 )
- EndIf
- EndIf
-
- Case SLIDER_STEPPER
- SendMessageW _hwnd,UDM_SETRANGE32,visible,total
- End Select
- _value = GetProp()
- SetEnabled(tmpEnabled)
- Sensitize()
- EndMethod
-
- Method SetProp(value)
- Desensitize()
- Select _slidertype
- Case SLIDER_SCROLLBAR
- Local info:SCROLLINFO=New SCROLLINFO
- info.cbSize=SizeOf(SCROLLINFO)
- info.fMask=SIF_POS
- info.nPos=value
- SendMessageW _hwnd,SBM_SETSCROLLINFO,True,Int Byte Ptr info
- Case SLIDER_TRACKBAR
- If _ishorizontal Then
- SendMessageW _hwnd,TBM_SETPOS,True,value
- Else
- 'Flip the value so that the scale starts from the bottom
- SendMessageW _hwnd,TBM_SETPOS,True,_visible + _total - value
- EndIf
- Case SLIDER_STEPPER
- SendMessageW _hwnd,UDM_SETPOS,True,value
- End Select
- _value = value
- Sensitize()
- EndMethod
-
- Method GetProp()
- Local value
- Select _slidertype
- Case SLIDER_SCROLLBAR
- value=GetScrollPos(_hwnd,SB_CTL)
- Case SLIDER_TRACKBAR
- value=SendMessageW(_hwnd,TBM_GETPOS,0,0)
- 'Flip the value so that the scale starts from the bottom
- If Not _ishorizontal Then value = _visible + _total - value
- Case SLIDER_STEPPER
- value=SendMessageW(_hwnd,UDM_GETPOS32,0,Null)
- End Select
- Return value
- EndMethod
-
- Method OnCommand(msg,wp)
- If _slidertype=SLIDER_SCROLLBAR
- If msg=WM_COMMAND Return
- Local info:SCROLLINFO=New SCROLLINFO
- info.cbSize=SizeOf(SCROLLINFO)
- Select wp&$ffff
- Case SB_THUMBTRACK,SB_THUMBPOSITION
- info.fMask=SIF_TRACKPOS
- SendMessageW _hwnd,SBM_GETSCROLLINFO,0,Int Byte Ptr info
- SetScrollPos _hwnd,SB_CTL,info.nTrackPos,True
- Default
- info.fMask=SIF_POS|SIF_PAGE|SIF_RANGE
- SendMessageW _hwnd,SBM_GETSCROLLINFO,0,Int Byte Ptr info
- Local pos=info.nPos
- Local vis=info.nPage
- Select wp&$ffff
- Case SB_LINEUP pos:-1
- Case SB_LINEDOWN pos:+1
- Case SB_PAGEUP pos:-vis
- Case SB_PAGEDOWN pos:+vis
- Default Return 0
- End Select
- SetScrollPos _hwnd,SB_CTL,pos,True
- End Select
- EndIf
- Local index=GetProp()
- If (index <> _value) Then
- PostGuiEvent EVENT_GADGETACTION,index
- _value = index
- EndIf
- Return 1
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- Case WM_ERASEBKGND
- Return 1
- EndSelect
- Return Super.WndProc(hwnd,msg,wp,lp)
- EndMethod
-
- Method RefreshLook()
- Super.RefreshLook()
- SetRange(_visible,_total)
- EndMethod
-
- Method Class()
- Return GADGET_SLIDER
- EndMethod
-
-EndType
-
-Type TWindowsProgressBar Extends TWindowsGadget
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,parent
- Self.style = style
- wstyle=WS_CHILD|PBS_SMOOTH|WS_CLIPSIBLINGS
- parent=group.query(QUERY_HWND_CLIENT)
- hwnd=CreateWindowExW(xstyle,"msctls_progress32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- Register GADGET_PROGBAR,hwnd
- Return Self
- EndMethod
-
- Method SetValue(value#)
- SendMessageW _hwnd,PBM_SETPOS,value*100,0
- EndMethod
-
- Method SetColor(r,g,b)
- 'Only works in Classic mode, but it's better than nothing.
- SendMessageW _hwnd,PBM_SETBKCOLOR ,0,(b Shl 16)|(g Shl 8)|r
- EndMethod
-
- Method RemoveColor()
- 'Only works in Classic mode, but it's better than nothing.
- SendMessageW _hwnd,PBM_SETBKCOLOR ,1,0
- EndMethod
-
- Method SetTextColor(r,g,b)
- 'Only works in Classic mode, but it's better than nothing.
- SendMessageW _hwnd,PBM_SETBARCOLOR ,0,(b Shl 16)|(g Shl 8)|r
- EndMethod
-
- Method Class()
- Return GADGET_PROGBAR
- EndMethod
-
-EndType
-
-Type TWindowsPanel Extends TWindowsGadget
-
- Const PANELPANEL=0
- Const PANELGROUP=1
- Const PANELCANVAS=2
-
- Field _type
- Field _alpha#=1.0
- Field _bitmapwidth,_bitmapheight,_bitmapflags
- Field _canvas:TGraphics
- Field _hasalpha
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Local xstyle,wstyle,hotkey
- Local hwnd,client,parent
- Self.style = style
-
- parent=group.query(QUERY_HWND_CLIENT)
- If (style&3=PANEL_GROUP) Then
- _type=PANELGROUP
- hwnd=CreateWindowExW(WS_EX_CONTROLPARENT,"BUTTON","",BS_GROUPBOX|WS_CHILD|WS_CLIPSIBLINGS|WS_CLIPCHILDREN,0,0,0,0,parent,0,GetModuleHandleW(Null),Null )
- client=CreateWindowExW(WS_EX_CONTROLPARENT,TWindowsGUIDriver.ClassName(),"",WS_CHILD|WS_VISIBLE|WS_CLIPCHILDREN|WS_CLIPSIBLINGS,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null)
- Else
- _type=PANELPANEL
- xstyle=WS_EX_CONTROLPARENT
- wstyle=WS_CHILD|WS_CLIPCHILDREN|WS_CLIPSIBLINGS
- Select (style&3)
- Case PANEL_SUNKEN xstyle:|WS_EX_CLIENTEDGE
- Case PANEL_RAISED xstyle:|WS_EX_WINDOWEDGE ; wstyle:|WS_DLGFRAME
- EndSelect
- If (style&PANEL_CANVAS) Then _type=PANELCANVAS
- hwnd=CreateWindowExW(xstyle,TWindowsGUIDriver.ClassName(),"",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)
- EndIf
-
- Register GADGET_PANEL,hwnd,client
- If (style & PANEL_ACTIVE) Then sensitivity = SENSITIZE_ALL
-
- Return Self
- EndMethod
-
- Method SetAlpha( alpha# )
- _alpha=alpha
- RedrawGadget(Self)
- EndMethod
-
- Method Activate( cmd )
- Select cmd
- Case ACTIVATE_REDRAW
- If (_type = PANELCANVAS) Then
- InvalidateRect _hwnd, Null, False
- Return True
- EndIf
- EndSelect
- Return Super.Activate(cmd)
- EndMethod
-
- Method SetPixmap(pixmap:TPixmap,flags)
- If _bitmap Then DeleteObject _bitmap;_bitmap = 0
- If pixmap Then
- If pixmap.format=PF_RGBA8888 Or pixmap.format=PF_BGRA8888
- _bitmap=TWindowsGraphic.PreMultipliedBitmapFromPixmap32( pixmap )
- EndIf
- If _bitmap
- _hasalpha=True
- Else
- _bitmap=TWindowsGraphic.BitmapFromPixmap( pixmap, False )
- _hasalpha=False
- EndIf
- _bitmapflags=flags
- _bitmapwidth=pixmap.width
- _bitmapheight=pixmap.height
- EndIf
- RedrawGadget(Self)
- EndMethod
-
- Method AttachGraphics:TGraphics( flags )
- _canvas=brl.Graphics.AttachGraphics( _hwnd,flags )
- EndMethod
-
- Method CanvasGraphics:TGraphics()
- Return _canvas
- EndMethod
-
- Method Free()
- If _canvas Then CloseGraphics(_canvas);_canvas = Null
- Super.Free()
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
-
- Case WM_ERASEBKGND
-
- If _type = PANELCANVAS Then Return 1
-
- Local hdc=wp,hdcCanvas,hdcBitmap,srcw,srch,x,y,xoffset,yoffset
- Local clientRect[4], updateRect[4], clipRect[4], windowRect[4]
-
- GetClipBox( hdc, clipRect )
- GetWindowRect( hwnd, windowRect)
- GetClientRect( hwnd, clientRect )
-
- If Not GetUpdateRect( hwnd, updateRect, False) Then updateRect = clipRect
- If IsRectEmpty(updateRect) Then updateRect = [0,0,windowRect[2]-windowRect[0],windowRect[3]-windowRect[1]]
-
- 'If we are drawing a bitmap or using alpha then let's do some double-buffering stuff
-
- If (hwnd <> _hwndclient) And ((_bitmap And _bitmapwidth And _bitmapheight) Or _alpha<1.0) Then
-
- hdc = CreateCompatibleDC(wp)
- hdcCanvas = CreateCompatibleBitmap(wp,windowRect[2]-windowRect[0],windowRect[3]-windowRect[1])
- SelectObject( hdc, hdcCanvas )
-
- EndIf
-
- 'Fill the drawing context with the background colour, or the background of the parent
-
- If BgBrush() And (hwnd <> _hwndclient) Then FillRect(hdc,updateRect,BgBrush()) Else DrawParentBackground(hdc,hwnd)
-
- 'If we aren't drawing to a bitmap or using alpha, then we can return now.
-
- If Not ((hwnd <> _hwndclient) And ((_bitmap And _bitmapwidth And _bitmapheight) Or _alpha<1.0)) Then Return 1
-
- If _bitmap And _bitmapwidth And _bitmapheight
- hdcBitmap=CreateCompatibleDC(hdc)
- SelectObject(hdcBitmap,_bitmap)
- srcw=_bitmapwidth
- srch=_bitmapheight
- Select (_bitmapflags & (GADGETPIXMAP_ICON-1))
- Case PANELPIXMAP_TILE
- While y<windowRect[RECT_BOTTOM]-windowRect[RECT_TOP]
- x=0
- While x<windowRect[RECT_RIGHT]-windowRect[RECT_LEFT]
- If _hasalpha
- AlphaBlend_ hdc,x,y,srcw,srch,hdcBitmap,0,0,srcw,srch,$01ff0000
- Else
- BitBlt hdc,x,y,srcw,srch,hdcBitmap,0,0,ROP_SRCCOPY
- EndIf
- x:+srcw
- Wend
- y:+srch
- Wend
- Case PANELPIXMAP_CENTER
- x=(windowRect[RECT_RIGHT]-windowRect[RECT_LEFT]-srcw)/2
- y=(windowRect[RECT_BOTTOM]-windowRect[RECT_TOP]-srch)/2
- If _hasalpha
- AlphaBlend_ hdc,x,y,srcw,srch,hdcBitmap,0,0,srcw,srch,$01ff0000
- Else
- BitBlt hdc,x,y,srcw,srch,hdcBitmap,0,0,ROP_SRCCOPY
- EndIf
-
- Case PANELPIXMAP_FIT, PANELPIXMAP_FIT2
-
- Local mx# = Float(windowRect[RECT_RIGHT]-windowRect[RECT_LEFT])/srcw
- Local my# = Float(windowRect[RECT_BOTTOM]-windowRect[RECT_TOP])/srch
-
- If mx>my Then
- If (_bitmapflags&(GADGETPIXMAP_ICON-1)) = PANELPIXMAP_FIT Then mx=my Else my=mx
- EndIf
- Local w=mx*srcw
- Local h=mx*srch
- x=(windowRect[RECT_RIGHT]-windowRect[RECT_LEFT]-w)/2
- y=(windowRect[RECT_BOTTOM]-windowRect[RECT_TOP]-h)/2
- SetStretchBltMode hdc,COLORONCOLOR
-
- If _hasalpha
- AlphaBlend_ hdc,x,y,w,h,hdcBitmap,0,0,srcw,srch,$01ff0000
- Else
- StretchBlt hdc,x,y,w,h,hdcBitmap,0,0,srcw,srch,ROP_SRCCOPY
- EndIf
-
- Case PANELPIXMAP_STRETCH
- SetStretchBltMode hdc,COLORONCOLOR
-
- If _hasalpha
- AlphaBlend_ hdc,0,0,windowRect[RECT_RIGHT]-windowRect[RECT_LEFT],windowRect[RECT_BOTTOM]-windowRect[RECT_TOP],hdcBitmap,0,0,srcw,srch,$01ff0000
- Else
- StretchBlt hdc,0,0,windowRect[RECT_RIGHT]-windowRect[RECT_LEFT],windowRect[RECT_BOTTOM]-windowRect[RECT_TOP],hdcBitmap,0,0,srcw,srch,ROP_SRCCOPY
- EndIf
-
- EndSelect
-
- DeleteDC(hdcBitmap)
-
- EndIf
-
- If _alpha < 1.0 Then
-
- DrawParentBackground( wp, hwnd )
- Local blendfunction = ((Int(_alpha*255)&$FF) Shl 16)
- AlphaBlend_(wp,updateRect[0],updateRect[1],updateRect[2]-updateRect[0],updateRect[3]-updateRect[1],hdc,updateRect[0],updateRect[1],updateRect[2]-updateRect[0],updateRect[3]-updateRect[1],blendfunction)
-
- Else
-
- BitBlt(wp,0,0,windowRect[2]-windowRect[0],WindowRect[3]-windowRect[1],hdc,0,0,ROP_SRCCOPY)
-
- EndIf
-
- Assert hdc <> wp, "hdc == wp! Please post a MaxGUI bug report."
-
- DeleteObject( hdcCanvas )
- DeleteDC( hdc )
-
- Return 1
-
- Case WM_PAINT
-
- Select _type
- Case PANELCANVAS
- PostGuiEvent EVENT_GADGETPAINT
- ValidateRect _hwnd, Null
- Return 1
- EndSelect
-
- Case WM_LBUTTONDOWN
-
- SetFocus Query(QUERY_HWND_CLIENT)
-
- End Select
-
- Return Super.WndProc(hwnd,msg,wp,lp)
-
- EndMethod
-
- Method FlushBrushes(pRecurse:Int = True)
- Super.FlushBrushes()
- If Not pRecurse Then Return
- For Local tmpGadget:TWindowsGadget = EachIn kids
- tmpGadget.FlushBrushes()
- Next
- EndMethod
-
- Method ClientWidth()
- If _hwndClient Then Return (Super.ClientWidth()-8) Else Return Super.ClientWidth()
- EndMethod
-
- Method ClientHeight()
- If _hwndClient Then Return (Super.ClientHeight()-20) Else Return Super.ClientHeight()
- EndMethod
-
- Method RethinkClient(forceRedraw:Int = False)
- If _hwndClient Then
- MoveWindow( _hwndClient, 4+_clientX,16+_clientY,ClientWidth(),ClientHeight(),forceRedraw)
- EndIf
- EndMethod
-
- Method Class()
- If _type = PANELCANVAS Then Return GADGET_CANVAS Else Return GADGET_PANEL
- EndMethod
-
-EndType
-
-
-Type TWindowsHTMLView Extends TWindowsGadget
-
- Field mshtml
- Field browser:IWebBrowser2
-
- Field IID_IHTMLDocument2:GUID=New GUID
-
- Method Create:TWindowsGadget(group:TGadget,style,Text$="")
- Self.style = style
- Local parent=group.query(QUERY_HWND_CLIENT)
- mshtml=msHtmlCreate(Self,TWindowsGUIDriver.ClassName(),parent,style)
- browser=msHTMLBrowser(mshtml)
- Register GADGET_HTMLVIEW,msHtmlHwnd(mshtml)
-
- Local res = IIDFromString(IHTMLDocument2_UUID,IID_IHTMLDocument2)
-
- Return Self
- EndMethod
-
- Method Rethink()
- msHtmlSetShape mshtml,xpos,ypos,width,height
- EndMethod
-
- Method SetText(Text$) 'sets document url
- If Text Then msHtmlGo mshtml,Text
- EndMethod
-
- Method GetText$()
- Local bstr:Short Ptr
- browser.lfget_LocationURL(Varptr bstr)
- Local result$ = String.FromWString(bstr)
- SysFreeString(bstr)
- Return result
- EndMethod
-
- Method GetTitleText$() 'returns document title
-
- Local bstr:Short Ptr
- Local res
-
- Local disp:IDispatch
- Local doc:IHTMLDOCUMENT2
-
- res=browser.lfget_Document(Varptr disp)
- If res RuntimeError "no document"
-
- res=disp.QueryInterface(IID_IHTMLDocument2,Varptr doc)
- If res RuntimeError "no document2 interface"
-
- If doc
- doc.get_Title(Varptr bstr)
- Else
- browser.lfget_LocationName(Varptr bstr)
- EndIf
-
- Local result$ = String.FromWString(bstr)
- SysFreeString(bstr)
- Return result
-
- End Method
-Rem
- Method Run$(script$)
- Local res
- Local disp:IDispatch
- Local doc:IHTMLDOCUMENT2
- Local win:IHTMLWindow2
- Local result:VARIANT
-
- res=browser.lfget_Document(Varptr disp)
- If res RuntimeError "no document"
- res=disp.QueryInterface(IID_IHTMLDocument2,Varptr doc)
- If res RuntimeError "no document2 interface"
- res=doc.get_parentWindow(Varptr win)
- If res RuntimeError "no parent window"
- result=New VARIANT
- result.vt=VT_EMPTY
- Local bstr:Short Ptr
- bstr=SysAllocStringLen(script.toWString(),script.length)
- res=win.execScript(bstr,Null,result)
- SysFreeString bstr
- Return res
- End Method
-
-EndRem
- Method Activate(cmd)
- Return msHtmlActivate(mshtml,cmd)
- EndMethod
-
- Method State()
- Return msHtmlStatus(mshtml)
- EndMethod
-
- Method Run$(script$)
- msHtmlRun(mshtml,script)
- EndMethod
-
- Method WndProc(hwnd,msg,wp,lp)
- Select msg
- 'Reduces flicker on HTMLViews
- Case WM_ERASEBKGND
- Return 1
- EndSelect
- Return Super.WndProc(hwnd,msg,wp,lp)
- EndMethod
-
- Method Class()
- Return GADGET_HTMLVIEW
- EndMethod
-
-EndType
-
-Type TWindowsMenu Extends TGadget
- Field _hmenu
- Field _pmenu
- Field _item
- Field _state
- Field _tag
- Field _hotkeycode
- Field _modifier
- Field _shortcut$
- Field _hotkey:THotKey
- Field _key = SetNewKey()
- Field _iconBitmap
-
- Global iteminfo:MENUITEMINFOW
-
- Global keymap:TMap=New TMap 'key,gadget
- Global keycount=100
-
- Method SetNewKey%()
- keycount:+1
- keymap.Insert( TIntWrapper.Create(keycount), Self )
- Return keycount
- EndMethod
-
- Function GetMenuFromKey:TWindowsMenu(pKey%)
- Return TWindowsMenu(keymap.ValueForKey(TIntWrapper.Create(pKey)))
- EndFunction
-
- Method SetText(pText$)
- name = pText
- EndMethod
-
- Method GetText$()
- Return name
- EndMethod
-
- Method Free()
- Close
- _setparent Null
- keymap.Remove(TIntWrapper.Create(_key))
- If _iconBitmap Then DeleteObject(_iconBitmap)
- EndMethod
-
- Method DoLayout()
- 'Don't do anything!
- EndMethod
-
- Method State()
- Return _state
- EndMethod
-
- Method SetEnabled(enable)
- If enable
- If _pmenu EnableMenuItem(_pmenu,_item,MF_BYPOSITION|MF_ENABLED)
- _state:&~STATE_DISABLED
- Else
- If _pmenu EnableMenuItem(_pmenu,_item,MF_BYPOSITION|MF_GRAYED)
- _state:|STATE_DISABLED
- EndIf
- EndMethod
-
- Method SetSelected(bool)
- If bool
- If _pmenu CheckMenuItem(_pmenu,_item,MF_BYPOSITION|MF_CHECKED)
- _state:|STATE_SELECTED
- Else
- If _pmenu CheckMenuItem(_pmenu,_item,MF_BYPOSITION|MF_UNCHECKED)
- _state:&~STATE_SELECTED
- EndIf
- EndMethod
-
- Method SetHotKey(keycode,modifier)
- _hotkeycode=keycode
- _modifier=modifier
-
- Local pre$, suf$, m$
-
- If LocalizationMode()&LOCALIZATION_ON Then
- pre="{{"
- suf="}}"
- EndIf
-
- If keycode>=KEY_0 And keycode<=KEY_9
- m$=Chr(keycode)
- ElseIf keycode>=KEY_A And keycode<=KEY_Z
- m$=Chr(keycode)
- ElseIf keycode>=KEY_F1 And keycode<=KEY_F12
- m$="F"+(keycode+1-KEY_F1)
- ElseIf keycode>=KEY_NUM0 And keycode<=KEY_NUM9
- m$="Num "+(keycode+1-KEY_NUM0)
- Else
- Select keycode
- Case KEY_BACKSPACE;m = pre+"Backspace"+suf
- Case KEY_TAB;m = pre+"Tab"+suf
- Case KEY_ESCAPE;m = pre+"Esc"+suf
- Case KEY_SPACE;m = pre+"Space"+suf
- Case KEY_ENTER;m = pre+"Enter"+suf
- Case KEY_PAGEUP;m = pre+"PageUp"+suf
- Case KEY_PAGEDOWN;m = pre+"PageDown"+suf
- Case KEY_END;m = pre+"End"+suf
- Case KEY_HOME;m = pre+"Home"+suf
- Case KEY_LEFT;m = pre+"Left"+suf
- Case KEY_RIGHT;m = pre+"Right"+suf
- Case KEY_UP;m = pre+"Up"+suf
- Case KEY_DOWN;m = pre+"Down"+suf
- Case KEY_INSERT;m = pre+"Insert"+suf
- Case KEY_DELETE;m = pre+"Delete"+suf
- Case KEY_TILDE;m = "~~"
- Case KEY_MINUS;m = "-"
- Case KEY_EQUALS;m = "="
- Case KEY_OPENBRACKET;m = "["
- Case KEY_CLOSEBRACKET;m = "]"
- Case KEY_BACKSLASH;m = "\"
- Case KEY_SEMICOLON;m = ";"
- Case KEY_QUOTES;m = "'"
- Case KEY_COMMA;m = ","
- Case KEY_PERIOD;m = "."
- Case KEY_SLASH;m = "/"
- Case KEY_NUMMULTIPLY;m = "Num *"
- Case KEY_NUMADD;m = "Num +"
- Case KEY_NUMSUBTRACT;m = "Num -"
- Case KEY_NUMDECIMAL;m = "Num ."
- Case KEY_NUMDIVIDE;m = "Num /"
- EndSelect
- EndIf
-
- If m
- If modifier&MODIFIER_SHIFT m$=pre+"Shift"+suf+"+"+m$
- If modifier&MODIFIER_CONTROL m$=pre+"Ctrl"+suf+"+"+m$
- If modifier&MODIFIER_ALT m$=pre+"Alt"+suf+"+"+m$
- m="~t"+m
- EndIf
- _shortcut$=LocalizeString(m)
-
- If Not iteminfo
- iteminfo=New MENUITEMINFOW
- iteminfo.cbSize=SizeOf(iteminfo)
- EndIf
- iteminfo.fMask=MIIM_TYPE
- iteminfo.dwTypeData=(name+_shortcut).toWString()
- SetMenuItemInfoW _pmenu,_item,True,iteminfo
-
- MemFree iteminfo.dwTypeData
-
- Local ev:TEvent=CreateEvent( EVENT_MENUACTION, Self,_tag )
- If _hotKey RemoveHotKey(_hotKey);_hotKey = Null
- If keycode Then _hotkey=SetHotKeyEvent(keycode,modifier,ev,FindGadgetWindowHwnd(Self))
- EndMethod
-
- Method Create:TWindowsMenu(group:TGadget,tag,Text$="")
- If Not iteminfo Then
- iteminfo=New MENUITEMINFOW
- iteminfo.cbSize=SizeOf(iteminfo)
- EndIf
- name=Text
- _tag=tag
- Local window:TWindowsWindow = TWindowsWindow(group)
- If window group=window.GetMenu()
- _SetParent(group)
- If (LocalizationMode()&LOCALIZATION_OVERRIDE) Then
- LocalizeGadget(Self, name, "")
- EndIf
- Return Self
- EndMethod
-
- Method Open(popup=False)
-
- Local dad:TWindowsMenu = TWindowsMenu(parent)
-
- If dad
- _pmenu=dad._hmenu
- If Not _pmenu Throw "Parent doesn't have a handle - the desktop heap may have run out of memory!"
- _item=GetMenuItemCount(_pmenu)
- If name
- Local tmpWString:Short Ptr = (LocalizeString(name)+_shortcut).ToWString()
- AppendMenuW _pmenu,MF_STRING,_key,tmpWString
- MemFree tmpWString
- Else
- AppendMenuW _pmenu,MF_SEPARATOR,_key,Null
- EndIf
- If kids.count()
- _hmenu=CreateMenu_()
- Local tmpMenuInfo:MENUINFO = New MENUINFO
-
- tmpMenuInfo.fMask = MIM_APPLYTOSUBMENUS|MIM_STYLE
- tmpMenuInfo.dwStyle = MNS_CHECKORBMP|MNS_MODELESS
- SetMenuInfo(_hmenu, tmpMenuInfo)
-
- iteminfo.fMask=MIIM_SUBMENU
- iteminfo.hSubMenu=_hmenu
- SetMenuItemInfoW _pmenu,_item,True,iteminfo
- EndIf
-
- If _state&STATE_DISABLED SetEnabled(False)
- If _state&STATE_SELECTED SetSelected(True)
-
- If _iconBitmap Then SetMenuItemBitmaps(_pMenu,_key,MF_BYCOMMAND,_iconBitmap,Null)
- Else
- If popup
- _hmenu=CreatePopupMenu()
- Else
- If kids _hmenu=CreateMenu_()
- EndIf
- EndIf
-
- For Local kid:TWindowsMenu = EachIn kids
- kid.Open
- Next
-
- EndMethod
-
- Method FreeKids()
- For Local kid:TWindowsMenu = EachIn kids
- kid.Close
- Next
- EndMethod
-
- Method Close()
- FreeKids()
- If _hmenu
- DestroyMenu _hmenu
- _hmenu=0
- EndIf
- EndMethod
-
- Method SetPixmap(pixmap:TPixmap,pFlags)
- If Not (pFlags & GADGETPIXMAP_ICON) Then Return
- If _iconBitmap Then DeleteObject(_iconBitmap);_iconBitmap = 0
- If pixmap Then
- pixmap = PixmapWindow(pixmap,0,0,Min(GetSystemMetrics(SM_CXMENUCHECK),PixmapWidth(pixmap)),Min(GetSystemMetrics(SM_CYMENUCHECK),PixmapHeight(pixmap)))
- If TWindowsGUIDriver.CheckCommonControlVersion() >= 2 Then
- _iconBitmap = TWindowsGraphic.PreMultipliedBitmapFromPixmap32( pixmap )
- Else
- Local tmpRGB = GetSysColor(COLOR_MENU)
- _iconBitmap = TWindowsGraphic.BitmapWithBackgroundFromPixmap32( pixmap, tmpRGB&$FF, (tmpRGB Shr 8) & $FF, (tmpRGB Shr 16) & $FF )
- EndIf
- EndIf
-
- EndMethod
-
- Method SetTooltip( pTooltip$ )
- 'Menus shouldn't have tool-tips.
- EndMethod
-
- Method Class()
- Return GADGET_MENUITEM
- EndMethod
-
-EndType
-
-Type TWindowsIconStrip Extends TIconStrip
-
- Field _blanks[]
- Field _imagelist
-
- Function DetectNotBlank(pixmap:TPixmap,xx,n)
- Local c = pixmap.ReadPixel(xx,0), y
- For Local x=0 Until n
- For y=0 Until n
- If pixmap.ReadPixel(xx+x,y)<>c Return True
- Next
- Next
- EndFunction
-
- Method IsBlankIcon(n)
- Return _blanks[n]
- EndMethod
-
- Function RemoveMask(pixmap:TPixmap)
- If pixmap.format<>( PF_RGBA8888 ) And pixmap.format<>( PF_BGRA8888 ) Return
- Local w = pixmap.width, h = pixmap.height, y, c
- For Local x=0 Until w
- For y=0 Until h
- c=pixmap.ReadPixel(x,y)
- If c>=0 pixmap.WritePixel x,y,-1
- Next
- Next
- EndFunction
-
- Function BuildImageList(pixmap:TPixmap)
- Local bitmap,imagelist,sz,mask
- sz=pixmap.height
- If TWindowsGUIDriver.CheckCommonControlVersion() And (Pixmap.format=PF_RGBA8888 Or pixmap.format=PF_BGRA8888)
- imagelist=ImageList_Create(sz,sz,ILC_COLOR32,0,1)
- If imagelist
- bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, True)
- ImageList_Add(imagelist,bitmap,0)
- EndIf
- EndIf
- If imagelist=0
- bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, False)
- mask=TWindowsGraphic.BitmapMaskFromPixmap(pixmap)
- imagelist=ImageList_Create(sz,sz,ILC_COLOR24|ILC_MASK,0,1)
- ImageList_Add(imagelist,bitmap,mask)
- DeleteObject(mask)
- EndIf
- DeleteObject(bitmap)
- Return imagelist
- EndFunction
-
- Function Create:TWindowsIconStrip(source:Object)
- Local icons:TWindowsIconStrip
- Local imagelist
- Local n,i,sz
- Local blanks[]
-
- 'Get a 24-bit pixmap from source
- Local pix:TPixmap = TPixmap(source)
- If Not pix pix = LoadPixmap(source)
- If Not pix Return
-
- 'Detect blank icons in the set
- sz=pix.height;If sz n=pix.width/sz
- If n=0 Return
- blanks=New Int[n]
- For i=0 Until n
- blanks[i]=Not DetectNotBlank(pix,i*sz,sz)
- Next
-
- 'Build a Win32 Image-List
- imagelist=BuildImageList(pix)
- icons = New TWindowsIconStrip
- icons.pixmap = pix
- icons.count=n
- icons._blanks=blanks
- icons._imagelist=imagelist
-
- Return icons
- EndFunction
-
- Function CreateBlank:TWindowsIconStrip()
- Return Create(CreatePixmap(1,1,PF_BGR888))
- EndFunction
-
- Method Delete()
- If _imagelist Then
- ImageList_Destroy(_imagelist)
- _imagelist = 0
- EndIf
- EndMethod
-
-EndType
-
-Type TWindowsFont Extends TGuiFont
-
- Method Load:TWindowsFont(_name$,_size:Double,_style)
-
- If handle Then DeleteObject handle;handle = 0
-
- Local cfweight = FW_NORMAL
- Local cfsize = -LogicalUnitsFromSize( _size )
-
- If _style & FONT_BOLD cfweight=FW_BOLD
- handle=CreateFontW( cfsize, 0,0,0,cfweight,..
- (_style & FONT_ITALIC) ,..
- (_style & FONT_UNDERLINE),..
- (_style & FONT_STRIKETHROUGH),..
- DEFAULT_CHARSET,..
- OUT_DEFAULT_PRECIS,..
- CLIP_DEFAULT_PRECIS,..
- ANTIALIASED_QUALITY,..
- DEFAULT_PITCH|FF_DONTCARE,..
- _name.toWString())
-
- 'Now lets test to see whether the right font was found
-
- name = NameFromHandle(handle)
-
- 'If the font returned has a different name to that requested, let's try the symbol character set
-
- If name.ToLower() <> _name.ToLower() Then
- Local tmpSymbolHandle = CreateFontW( cfsize, 0,0,0,cfweight,..
- (_style & FONT_ITALIC) ,..
- (_style & FONT_UNDERLINE),..
- (_style & FONT_STRIKETHROUGH),..
- SYMBOL_CHARSET,..
- OUT_DEFAULT_PRECIS,..
- CLIP_DEFAULT_PRECIS,..
- ANTIALIASED_QUALITY,..
- DEFAULT_PITCH|FF_DONTCARE,..
- _name.toWString())
-
- Local strSymbolName:String = NameFromHandle(tmpSymbolHandle)
-
- 'If we now have a match, delete the first font returned and use the new symbol one.
-
- If strSymbolName.ToLower() = _name.ToLower() Then
- DeleteObject handle
- handle = tmpSymbolHandle
- name = strSymbolName
- Else
- DeleteObject tmpSymbolHandle
- EndIf
-
- EndIf
-
- size=_size
- style=_style
-
- Return Self
-
- EndMethod
-
- Method LoadFromLogFont:TWindowsFont( pLogFont:LOGFONTW, pStyle% = 0, pSize:Double = 0:Double )
-
- If pLogFont.lfWeight>=FW_BOLD Then pStyle:| FONT_BOLD
- If pLogFont.lfItalic Then pStyle:| FONT_ITALIC
- If pLogFont.lfUnderline Then pStyle:| FONT_UNDERLINE
- If pLogFont.lfStrikeOut Then pStyle:| FONT_STRIKETHROUGH
-
- style = pStyle
-
- If Not pSize Then pSize = SizeFromLogFont( pLogFont )
-
- size = pSize
-
- SetLogFontProperties( pLogFont, pStyle, pSize )
-
- name = String.FromWString( Varptr pLogFont.lfFaceName00 )
-
- If handle Then DeleteObject handle
- handle = CreateFontIndirectW( pLogFont )
-
- Return Self
-
- EndMethod
-
- Method LoadFromHandle:TWindowsFont(hfont)
-
- Local tmpLogFont:LOGFONTW = New LOGFONTW
- GetObjectW( hfont, SizeOf(LOGFONTW), tmpLogFont )
- Return LoadFromLogFont( tmpLogFont )
-
- EndMethod
-
- Method CharWidth( charcode )
- Local hdc=GetDC(0)
- Local tfont=SelectObject( hdc,handle )
-
- Local width=8,widths[3]
-
- If GetCharABCWidthsW( hdc,charcode,charcode,widths )
- width=widths[0]+widths[1]+widths[2]
- Else If GetCharWidth32W( hdc,charcode,charcode,widths )
- width=widths[0]
- EndIf
-
- SelectObject hdc,tfont
- ReleaseDC 0,hdc
-
- Return width
- EndMethod
-
- Method GetMaxCharWidth()
- Local hdc=GetDC(0)
- Local tfont=SelectObject(hdc,handle)
- Local tm:TEXTMETRIC=New TEXTMETRIC
- GetTextMetricsW hdc,tm
- SelectObject(hdc,tfont)
- ReleaseDC(0,hdc)
- Return tm.tmAveCharWidth
- EndMethod
-
- Method Delete()
- If handle Then DeleteObject handle
- EndMethod
-
- Function Request:TWindowsFont(font:TGuiFont)
-
- Local lf:LOGFONTW = New LOGFONTW
- Local cf:CHOOSEFONT = New CHOOSEFONT
-
- cf.lStructSize=SizeOf(cf)
- cf.hwndOwner=TWindowsGUIDriver.GetActiveHwnd()
- cf.lpLogFont=lf
- cf.Flags=CF_BOTH
-
- If font
- Local p:Short Ptr = Short Ptr(Varptr lf.lfFaceName00)
- For Local i = 0 Until Min(font.name.length, 31)
- p[i]=font.name[i]
- Next
- SetLogFontProperties( lf, font.style, font.size )
- cf.Flags:|CF_INITTOLOGFONTSTRUCT
- EndIf
-
- Local hwnd = GetFocus()
- Local n = ChooseFontW(cf)
- SetFocus(hwnd)
- If Not n Return
-
- Local style
- If cf.nFontType&BOLD_FONTTYPE style:|FONT_BOLD
- If cf.nFontType&ITALIC_FONTTYPE style:|FONT_ITALIC
- Return New TWindowsFont.LoadFromLogFont( lf, style, cf.iPointSize/Double(10) )
-
- EndFunction
-
- Function DefaultFont:TWindowsFont( pFontSize:Double = 0, pFontStyle% = FONT_NORMAL )
-
- 'Attempts to get hold of the Windows themed font (typically Tahoma on XP, Segeo UI on Vista)
- Local tmpNonClientMetrics:NONCLIENTMETRICSW = New NONCLIENTMETRICSW
-
- If SystemParametersInfoW And SystemParametersInfoW( SPI_GETNONCLIENTMETRICS, 0, Int Byte Ptr tmpNonClientMetrics, 0 ) Then
- Local tmpLogFont:LOGFONTW = New LOGFONTW
- MemCopy tmpLogFont, Varptr tmpNonClientMetrics.lfMessageFont_lfHeight, SizeOf(tmpLogFont)
- Return New TWindowsFont.LoadFromLogFont( tmpLogFont, pFontStyle, pFontSize )
- EndIf
-
- 'If these functions, for whatever reason, fail, then the default GUI font is used (typically MS Sans Serif).
- 'Note: A font size of '8' has has been hard-coded in as no reliable substitute can be found, however this may cause
- 'text to appear too small in some languages/lacalizations.
- If pFontSize <= 0 Then pFontSize = 8
- Return New TWindowsFont.Load( "MS Shell Dlg", pFontSize, pFontStyle )
-
- EndFunction
-
- Function NameFromHandle:String( pFntHandle:Int )
-
- Local hdc = GetDC(0), buffer:Short[512]
- Local tfont = SelectObject(hdc,pFntHandle)
-
- If Not GetTextFaceW(hdc,buffer.length,buffer) buffer[0] = 0
-
- SelectObject(hdc, tfont)
- ReleaseDC(0,hdc)
-
- Return String.FromWString(buffer)
-
- EndFunction
-
- Function LogicalUnitsFromSize( pSize:Double )
-
- Local tmpDC:Int = GetDC(0)
- Local tmpSize:Int = (pSize * GetDeviceCaps(tmpDC,LOGPIXELSY))/72 + 0.5
- ReleaseDC( 0, tmpDC )
- Return tmpSize
-
- EndFunction
-
- Function SizeFromLogFont:Double( pLogFont:LOGFONTW )
-
- Local tmpDC:Int = GetDC(0)
- Local tmpSize:Double = (Abs(pLogFont.lfHeight) * Double(72.0) )/GetDeviceCaps(tmpDC,LOGPIXELSY)
- ReleaseDC( 0, tmpDC )
- Return tmpSize
-
- EndFunction
-
- Function SetLogFontProperties( pLogFont:LOGFONTW, pFlags%, pSize:Double = 0:Double )
-
- If pFlags&FONT_BOLD Then pLogFont.lfWeight=FW_BOLD Else pLogFont.lfWeight=FW_NORMAL
- If pFlags&FONT_ITALIC Then pLogFont.lfItalic=True Else pLogFont.lfItalic=False
- If pFlags&FONT_UNDERLINE Then pLogFont.lfUnderline=True Else pLogFont.lfUnderline=False
- If pFlags&FONT_STRIKETHROUGH Then pLogFont.lfStrikeOut=True Else pLogFont.lfStrikeOut=False
-
- If pSize > 0 Then pLogFont.lfHeight = -LogicalUnitsFromSize( pSize )
-
- EndFunction
-
-EndType
-
-'A collection of functions that convert between Blitz pixmaps and Windows icons/bitmaps.
-Type TWindowsGraphic Final
-
- Function BitmapMaskFromPixmap:Int(pix:TPixmap)
-
- Local x, pix2:TPixmap, usealpha
-
- If PixmapFormat(pix) = PF_RGBA8888 Or PixmapFormat(pix) = PF_BGRA8888 Then usealpha = True
-
- pix2=ConvertPixmap(pix,PF_BGR888);ClearPixels(pix2)
-
- For Local y:Int = 0 Until pix.height
- For x = 0 Until pix.width
- If usealpha
- If (ReadPixel(pix,x,y) Shr 24) < 128 Then WritePixel(pix2,x,y,$FFFFFF)
- Else
- If (ReadPixel(pix,x,y) & $FFFFFF) = $FFFFFF Then WritePixel(pix2,x,y,$FFFFFF)
- EndIf
- Next
- Next
-
- Return BitmapFromPixmap(pix2,False)
-
- EndFunction
-
- Function PreMultipliedBitmapFromPixmap32:Int( pix:TPixmap )
-
- Local argb, a
- Local pix2:TPixmap = CreatePixmap( pix.width, pix.height, pix.format), x
-
- For Local y:Int = 0 Until pix.height
- For x = 0 Until pix.width
- argb = ReadPixel(pix,x,y)
- a = ((argb Shr 24) & $FF)
- WritePixel(pix2,x,y,((((argb&$ff00ff)*a)Shr 8)&$ff00ff)|((((argb&$ff00)*a)Shr 8)&$ff00)|(a Shl 24))
- Next
- Next
-
- Return BitmapFromPixmap(pix2,True)
-
- EndFunction
-
- Function BitmapFromPixmap:Int(pix:TPixmap, alpha:Int = True)
-
- Local bitCount:Int = 32, format:Int = PF_BGRA8888, bm
-
- If Not alpha Then
- bitCount = 24
- format = PF_BGR888
- EndIf
-
- pix=ConvertPixmap(pix,format)
-
- Local hdc = GetDC(0)
-
- Local bi:BITMAPINFOHEADER = New BITMAPINFOHEADER
- bi.biSize=SizeOf(bi)
- bi.biWidth=pix.width
- bi.biHeight=-pix.height
- bi.biPlanes=1
- bi.biBitCount=bitCount
- bi.biCompression=BI_RGB
-
- Local bits:Byte Ptr
- Local src:Byte Ptr = pix.pixels
-
- If alpha
- bm = CreateDibSection(hdc,bi,DIB_RGB_COLORS,Varptr bits,0,0)
- Else
- bm = CreateCompatibleBitmap(hdc,pix.width,pix.height)
- EndIf
-
- Assert bm, "Cannot create bitmap. The computer may be running low on resources."
-
- For Local y:Int = 0 Until pix.height
- SetDIBits(hdc,bm,pix.height-y-1,1,src,bi,DIB_RGB_COLORS)
- src:+pix.pitch
- Next
-
- ReleaseDC(0,hdc)
-
- Return bm
-
- EndFunction
-
- Function BitmapWithBackgroundFromPixmap32:Int( pix:TPixmap, pRed, pGreen, pBlue )
-
- Local tmpPixel, tmpRed, tmpGreen, tmpBlue, tmpAlpha, tmpAlphaFloat#, tmpAlphaFloat2#
- Local pix2:TPixmap = CreatePixmap( pix.width, pix.height, pix.format), x
-
- For Local y:Int = 0 Until pix.height
- For x = 0 Until pix.width
-
- 'Read pixel and alpha info
- tmpPixel = ReadPixel(pix,x,y)
- tmpAlpha = ((tmpPixel Shr 24) & $FF)
- tmpAlphaFloat = tmpAlpha/255.0
- tmpAlphaFloat2 = 1-tmpAlphaFloat
-
- 'Get individual colours
- tmpBlue = tmpPixel & $FF;tmpGreen = (tmpPixel Shr 8) & $FF;tmpRed = (tmpPixel Shr 16)&$FF
-
- 'Courtesy of Mark T
- tmpRed = (tmpRed * tmpAlphaFloat) + (tmpAlphaFloat2 * pRed)
- tmpGreen = (tmpGreen * tmpAlphaFloat) + (tmpAlphaFloat2 * pGreen)
- tmpBlue = (tmpBlue * tmpAlphaFloat) + (tmpAlphaFloat2 * pBlue)
-
- 'Write the new pixels
- WritePixel(pix2,x,y,(tmpAlpha Shl 24)|(tmpRed Shl 16)|(tmpGreen Shl 8)|tmpBlue)
- Next
- Next
-
- Return BitmapFromPixmap(pix2,False)
-
- EndFunction
-
- Function IconFromPixmap32:Int(pix:TPixmap)
-
- ' Convert the pixmap to a HBITMAP
- Local bitmap = BitmapFromPixmap(pix,True)
-
- ' and then copy/resize it (to the default size for icons/cusors).
- Local hSrcBMP = CopyImage(bitmap, IMAGE_BITMAP , 0 , 0 , LR_DEFAULTSIZE)
-
- ' Now we need to create a mask bitmap for the image
- Local hMaskBMP = BitmapMaskFromPixmap( pix )
-
- ' So now we have our source and mask bitmaps, we can create an ICONINFO structure
- Local IconInf:ICONINFO = New IconInfo
- IconInf.fIcon = True
- IconInf.hbmMask = hMaskBMP
- IconInf.hbmColor = hSrcBMP
-
- ' Create the icon
- Local tmpIcon = CreateIconIndirect(IconInf)
-
- ' Free our temporary bitmaps
- DeleteObject(hMaskBMP)
- DeleteObject(hSrcBMP)
- DeleteObject(bitmap)
-
- Return tmpIcon
-
- EndFunction
-
-EndType
-
-Private
-
-Function KeyMods()
- Local mods
- If GetKeyState(VK_SHIFT)&$8000 mods:|MODIFIER_SHIFT
- If GetKeyState(VK_CONTROL)&$8000 mods:|MODIFIER_CONTROL
- If GetKeyState(VK_MENU)&$8000 mods:|MODIFIER_OPTION
- If GetKeyState(VK_LWIN)&$8000 Or GetKeyState(VK_RWIN)&$8000 mods:|MODIFIER_SYSTEM
- Return mods
-EndFunction
-
-Function FindGadgetWindowHwnd(g:TGadget)
- Local wg:TWindowsWindow
- While g
- wg=TWindowsWindow(g)
- If wg Return wg.Query(QUERY_HWND) 'handle
- g=g.parent
- Wend
-EndFunction
-
-Type TIntWrapper Final
- Field value:Int
- Function Create:TIntWrapper(value:Int)
- Local tmpWrapper:TIntWrapper = New TIntWrapper
- tmpWrapper.value = value
- Return tmpWrapper
- EndFunction
- Method Compare( o:Object )
- Local c:TIntWrapper = TIntWrapper(o)
- If c Then Return (value - c.value)
- Return Super.Compare(o)
- EndMethod
- Method ToString$()
- Return value
- EndMethod
-EndType
+Rem\r
+bbdoc: MaxGUI Drivers/Win32MaxGUIEx\r
+End Rem\r
+Module MaxGUI.Win32MaxGUIEx\r
+\r
+ModuleInfo "Version: 0.75"\r
+ModuleInfo "Author: Simon Armstrong, Seb Hollington"\r
+ModuleInfo "License: zlib/libpng"\r
+\r
+Strict\r
+\r
+?Win32\r
+Import MaxGUI.MaxGUI\r
+Import "winimports.bmx"\r
+\r
+maxgui_driver = New TWindowsGUIDriver\r
+\r
+Type TWindowsGUIDriver Extends TMaxGUIDriver\r
+ \r
+ Global GadgetMap:TMap\r
+ Global GDIDesktop:TWindowsDesktop\r
+ Global GDIFont:TWindowsFont\r
+ Global ClassAtom\r
+ Global ClassAtom2\r
+ Global KBMessageHook,MouseMessageHook\r
+\r
+ Global windowtheme:Short Ptr\r
+ Global _cursor, _commoncontrolversion[]\r
+ Global _explorerstyle = False\r
+ Global _activeWindow:TWindowsWindow = Null\r
+ \r
+ Global _customcolors[] = [$FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, ..\r
+ $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF, $FFFFFF ]\r
+ \r
+ Global _hwndTooltips%\r
+ \r
+ Global intDontReleaseCapture% = False 'See WM_CAPTURECHANGED\r
+ \r
+ Method New()\r
+ \r
+ 'Initialize libraries\r
+ OleInitialize(Null)\r
+ Local icc:TINITCOMMONCONTROLSEX = New TINITCOMMONCONTROLSEX\r
+ icc.dwSize = SizeOf(icc)\r
+ icc.dwICC = ICC_WIN95_CLASSES|ICC_USEREX_CLASSES'|ICC_COOL_CLASSES'|ICC_DATE_CLASSES\r
+ InitCommonControlsEx icc\r
+ \r
+ 'Initialize Global Variables\r
+ GDIFont=TWindowsFont.DefaultFont()\r
+ GadgetMap=New TMap\r
+ GDIDesktop=New TWindowsDesktop\r
+ \r
+ 'Set-up Message Hooks\r
+ KBMessageHook=SetWindowsHookExW(WH_KEYBOARD,KeyboardProc,GetModuleHandleW(Null),GetCurrentThreadId())\r
+ MouseMessageHook=SetWindowsHookExW(WH_MOUSE,MouseProc,GetModuleHandleW(Null),GetCurrentThreadId())\r
+ \r
+ 'Gadget Tooltips\r
+ _hwndTooltips = CreateWindowExW( 0,"tooltips_class32","",WS_POPUP|TTS_ALWAYSTIP,0,0,0,0,GDIDesktop._hwnd,0,GetModuleHandleW(Null),Null )\r
+ SendMessageW( _hwndTooltips, TTM_SETMAXTIPWIDTH, 0, 300 )\r
+ SetWindowPos( _hwndTooltips, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE | SWP_NOSIZE | SWP_NOACTIVATE )\r
+ \r
+ EndMethod\r
+ \r
+ Method Delete()\r
+ DestroyWindow( _hwndTooltips );_hwndTooltips = 0\r
+ UnhookWindowsHookEx MouseMessageHook\r
+ UnhookWindowsHookEx KBMessageHook\r
+ EndMethod\r
+ \r
+ Method UserName$()\r
+ Return getenv_("username")\r
+ End Method\r
+ \r
+ Method ComputerName$()\r
+ Return getenv_("userdomain")\r
+ End Method\r
+ \r
+ 'Low-level Win32 interface\r
+\r
+ Function RegisterHwnd(hwnd,gadget:TWindowsGadget)\r
+ GadgetMap.Insert TIntWrapper.Create(hwnd),gadget \r
+ EndFunction\r
+ \r
+ Function RemoveHwnd(hwnd)\r
+ GadgetMap.Remove TIntWrapper.Create(hwnd)\r
+ EndFunction\r
+ \r
+ Function GadgetFromHwnd:TWindowsGadget(hwnd) nodebug\r
+ Return TWindowsGadget(GadgetMap.ValueForKey(TIntWrapper.Create(hwnd)))\r
+ EndFunction\r
+ \r
+ Function ClassWndProc(hwnd,msg,wp,lp) "win32"\r
+ Local owner:TWindowsGadget\r
+ Local res\r
+ Local nmhdr:Int Ptr\r
+ \r
+ '?Debug And Win32\r
+ 'Print TWindowsDebug.ReverseLookupMsg(msg) + ", hwnd: " + hwnd + ", wp: " + wp + ", lp: " + lp\r
+ '?Win32\r
+ \r
+ Select msg\r
+ \r
+ Case WM_MENUCHAR\r
+ \r
+ If HotKeyEventFromWp(wp & $FF) Then\r
+ Return (MNC_CLOSE Shl 16)\r
+ Else\r
+ Return (MNC_IGNORE Shl 16)\r
+ EndIf\r
+ \r
+ Case WM_SIZE\r
+ \r
+ owner = GadgetFromHwnd(hwnd)\r
+ If owner And Not TWindowsWindow(owner) Then\r
+ If hwnd = owner.Query(QUERY_HWND) Then owner.RethinkClient()\r
+ If hwnd = owner.Query(QUERY_HWND_CLIENT) Then owner.LayoutKids()\r
+ EndIf\r
+ \r
+ Case WM_CTLCOLORSTATIC, WM_CTLCOLOREDIT, WM_CTLCOLORBTN\r
+ \r
+ owner=GadgetFromHwnd(lp)\r
+ \r
+ Select True\r
+ \r
+ Case TWindowsLabel(owner) <> Null\r
+ \r
+ SetBkMode(wp, TRANSPARENT)\r
+ If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())\r
+ Return owner.CreateControlBrush( owner._hwnd, wp )\r
+ \r
+ Case TWindowsPanel(owner) <> Null\r
+ \r
+ If TWindowsPanel(owner)._type = TWindowsPanel.PANELGROUP Then\r
+ \r
+ SetBkMode(wp, TRANSPARENT)\r
+ If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())\r
+ Return owner.CreateControlBrush( lp, wp )\r
+ \r
+ EndIf\r
+ \r
+ Case TWindowsTextField(owner) <> Null, TWindowsComboBox(owner) <> Null\r
+ \r
+ If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())\r
+ If owner.BgBrush() Then SetBkColor(wp, owner.BgColor());Return owner.BgBrush()\r
+ \r
+ Case TWindowsButton(owner) <> Null, TWindowsSlider(owner) <> Null\r
+ \r
+ SetBkMode(wp, TRANSPARENT)\r
+ If owner.FgColor() > -1 Then SetTextColor_(wp, owner.FgColor())\r
+ Return owner.CreateControlBrush( owner._hwnd, wp )\r
+ \r
+ EndSelect\r
+ \r
+ owner = Null\r
+ \r
+ Case WM_COMMAND,WM_HSCROLL,WM_VSCROLL\r
+ If lp Then\r
+ owner=GadgetFromHwnd(lp)\r
+ 'Fix for tab control's up/down arrow.\r
+ If Not owner Then owner = GadgetFromHwnd(GetParent_(lp))\r
+ Else\r
+ owner=GadgetFromHwnd(hwnd) 'Fixed for menu events\r
+ EndIf\r
+\r
+ If Not owner Then owner = GadgetFromHwnd(hwnd)\r
+\r
+ If owner Then\r
+ res=owner.OnCommand(msg,wp)\r
+ If Not res And owner._proc And owner._hwnd = hwnd Return CallWindowProcW(owner._proc,hwnd,msg,wp,lp)\r
+ Return res\r
+ Else\r
+ Return DefWindowProcW( hwnd,msg,wp,lp )\r
+ EndIf\r
+ \r
+ Case WM_NOTIFY\r
+ \r
+ 'Gadget tooltips\r
+ nmhdr=Int Ptr(lp)\r
+ owner=GadgetFromHwnd(nmhdr[0]) \r
+ If owner Then\r
+ Select nmhdr[2]\r
+ Case TTN_GETDISPINFOW\r
+ If owner._wstrTooltip Then nmhdr[3] = Int(owner._wstrTooltip)\r
+ EndSelect\r
+ Return owner.OnNotify(wp,lp)\r
+ EndIf\r
+ \r
+ Case WM_SETCURSOR\r
+ \r
+ If _cursor Then\r
+ SetCursor(_cursor)\r
+ Return 1\r
+ EndIf\r
+ \r
+ Case WM_ACTIVATEAPP, WM_ACTIVATE\r
+ \r
+ SystemEmitOSEvent(hwnd,msg,wp,lp,Null)\r
+ \r
+ Case WM_DPICHANGED\r
+ Local g_dpi = wp Shr 16\r
+' UpdateDpiDependentFontsAndResources(); \r
+ DebugLog "DPICHANGED to "+g_dpi\r
+ \r
+ Case WM_DRAWITEM\r
+ \r
+ Local tmpDrawItemStruct:DRAWITEMSTRUCT = New DRAWITEMSTRUCT\r
+ MemCopy tmpDrawItemStruct, Byte Ptr lp, SizeOf(tmpDrawItemStruct)\r
+ \r
+ owner = GadgetFromHwnd(tmpDrawItemStruct.hwndItem)\r
+ If owner And owner.OnDrawItem( tmpDrawItemStruct ) Then Return True\r
+ \r
+ owner = Null\r
+ \r
+ 'Allow BRL.System to handle mouse/key events on sensitive gadgets.\r
+ \r
+ Case WM_CAPTURECHANGED\r
+ \r
+ 'For preventing problem where controls which called SetCapture() internally\r
+ 'had their capture prematurely released by the ReleaseCapture() call in BRL.System.\r
+ intDontReleaseCapture = False\r
+ 'If SetCapture() is called again after BRL.System's call (when the new\r
+ 'capture hwnd [lp] = old hwnd [hwnd]) then we dont want to call ReleaseCapture() in BRL.System\r
+ 'when WM_MOUSEBUTTONUP is received by the system hook TWindowsGUIDriver.MouseProc().\r
+ If (lp = hwnd) And (Not intEmitOSEvent) Then intDontReleaseCapture = True\r
+ \r
+ Default\r
+ \r
+ 'Added preliminary check to avoid searching for a gadget in GadgetMap un-necessarily.\r
+ If (msg = WM_MOUSEWHEEL) Or (msg = WM_MOUSELEAVE) Or (msg>=WM_KEYFIRST And msg<=WM_KEYLAST) Then\r
+ owner=GadgetFromHwnd(hwnd)\r
+ If owner Then\r
+ Select msg\r
+ Case WM_MOUSELEAVE, WM_MOUSEWHEEL\r
+ If (owner.sensitivity&SENSITIZE_MOUSE) Then SystemEmitOSEvent hwnd,msg,wp,lp,owner\r
+ Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP, WM_CHAR, WM_SYSCHAR\r
+ If (owner.sensitivity&SENSITIZE_KEYS) And Not GadgetDisabled(owner) Then\r
+ SystemEmitOSEvent hwnd,msg,wp,lp,owner\r
+ EndIf\r
+ If (msg<>WM_CHAR And msg<>WM_SYSCHAR) And HotKeyEventFromWp(wp) Then Return 1\r
+ EndSelect\r
+ EndIf\r
+ EndIf\r
+ \r
+ EndSelect\r
+ \r
+ If Not owner Then owner=GadgetFromHwnd(hwnd)\r
+ If owner Return owner.WndProc(hwnd,msg,wp,lp)\r
+ \r
+ Return DefWindowProcW( hwnd,msg,wp,lp )\r
+\r
+ EndFunction\r
+ \r
+ Function KeyboardProc( code,wparam,lparam ) "win32" nodebug\r
+ Local ev:TEvent, hwnd%, tmpClassName:Short[16], mods:Int, key:Int = wparam\r
+ If code>=0 Then\r
+ 'Removed: http://www.blitzbasic.com/Community/posts.php?topic=72737\r
+' Rem\r
+ If wparam = $D Then '$D: VK_RETURN\r
+ hwnd = GetFocus()\r
+ If hwnd And GetClassNameW(hwnd,tmpClassName,tmpClassName.length) And String.FromWString(tmpClassName).ToUpper() = "EDIT" Then\r
+ SetFocus(GetParent_(hwnd))\r
+ EndIf\r
+ EndIf\r
+' EndRem\r
+\r
+ ev = HotkeyEventFromWp(wparam)\r
+ If ev\r
+ 'Hot-key events shouldn't be emitted if the source gadget is disabled\r
+ If Not(TGadget(ev.source) And GadgetDisabled(TGadget(ev.source))) Then\r
+ If Not (lparam & $80000000) Then\r
+ EmitEvent ev\r
+ If ev.mods Then Return 1 'Key press events never reach active panels etc. if we return 1\r
+ EndIf\r
+ EndIf\r
+ EndIf \r
+ EndIf\r
+ Return CallNextHookEx( KBMessageHook,code,wparam,lparam );\r
+ EndFunction\r
+ \r
+ Function HotkeyEventFromWp:TEvent(wparam)\r
+ Local key = wparam, mods = KeyMods()\r
+ Select wparam\r
+ Case VK_SHIFT, $A0, $A1\r
+ If (wparam=VK_SHIFT) Then key = KEY_LSHIFT\r
+ mods:&~MODIFIER_SHIFT\r
+ Case VK_CONTROL, $A2, $A3\r
+ If (wparam=VK_CONTROL) Then key = KEY_LCONTROL\r
+ mods:&~MODIFIER_CONTROL\r
+ Case VK_MENU, $A4, $A5\r
+ If (wparam=VK_MENU) Then key = KEY_LALT\r
+ mods:&~MODIFIER_ALT\r
+ Case VK_LWIN, VK_RWIN\r
+ mods:&~MODIFIER_SYSTEM\r
+ EndSelect\r
+ Return HotKeyEvent( key,mods,GetForegroundWindow() )\r
+ EndFunction\r
+ \r
+ Global intButtonStates%[3]\r
+ \r
+ Function MouseProc( code,wparam,lparam ) "win32" nodebug\r
+ \r
+ If code>=0 And wparam >= WM_MOUSEFIRST And wparam <= WM_MOUSELAST Then 'Not needed as MouseProc only receives mouse messages!!!\r
+ \r
+ Local MOUSEHOOKSTRUCT:Int Ptr = Int Ptr(lparam), wp, lp, data\r
+ Local hwnd% = MOUSEHOOKSTRUCT[2], msg% = wparam, owner:TWindowsGadget\r
+ Local point:Int[] = [MOUSEHOOKSTRUCT[0],MOUSEHOOKSTRUCT[1]]\r
+ \r
+ Select msg\r
+ Case WM_LBUTTONDOWN, WM_LBUTTONDBLCLK\r
+ data = MOUSE_LEFT\r
+ msg = WM_LBUTTONDOWN\r
+ intButtonStates[MOUSE_LEFT] = True\r
+ Case WM_LBUTTONUP\r
+ data = MOUSE_LEFT\r
+ intButtonStates[MOUSE_LEFT] = False\r
+ Case WM_RBUTTONDOWN, WM_RBUTTONDBLCLK\r
+ data = MOUSE_RIGHT\r
+ msg = WM_RBUTTONDOWN\r
+ intButtonStates[MOUSE_RIGHT] = True\r
+ Case WM_RBUTTONUP\r
+ data = MOUSE_RIGHT\r
+ intButtonStates[MOUSE_RIGHT] = False\r
+ Case WM_MBUTTONDOWN, WM_MBUTTONDBLCLK\r
+ data = MOUSE_MIDDLE\r
+ msg = WM_MBUTTONDOWN\r
+ intButtonStates[MOUSE_MIDDLE] = True\r
+ Case WM_MBUTTONUP\r
+ data = MOUSE_MIDDLE\r
+ intButtonStates[MOUSE_MIDDLE] = False\r
+ EndSelect\r
+ \r
+ owner = GadgetFromHwnd(hwnd)\r
+ If owner And ScreenToClient( hwnd, point ) Then\r
+ \r
+ If data And (Not intButtonStates[data]) And TGadget.dragGadget[data-1] Then\r
+ PostGuiEvent EVENT_GADGETDROP, owner, data, KeyMods(), point[0], point[1], TGadget.dragGadget[data-1]\r
+ TGadget.dragGadget[data-1] = Null\r
+ EndIf\r
+ \r
+ If (owner.sensitivity&SENSITIZE_MOUSE) Then\r
+ \r
+ 'Fake wp parameter to pass onto bbSystemEmitOSEvent\r
+ If intButtonStates[MOUSE_LEFT] Then wp:|MK_LBUTTON\r
+ If intButtonStates[MOUSE_MIDDLE] Then wp:|MK_MBUTTON\r
+ If intButtonStates[MOUSE_RIGHT] Then wp:|MK_RBUTTON\r
+ If GetKeyState(VK_SHIFT)&$8000 Then wp:|MK_SHIFT\r
+ If GetKeyState(VK_CONTROL)&$8000 Then wp:|MK_CONTROL\r
+ \r
+ lp = (Short(point[1]) Shl 16) | Short(point[0])\r
+ 'Sort and determine whether to emit the event\r
+ Select msg\r
+ Case WM_MOUSEMOVE\r
+ If (owner._oldcursorlp<>lp) Then\r
+ owner._oldcursorlp=lp\r
+ SystemEmitOSEvent hwnd,msg,wp,lp,owner\r
+ EndIf\r
+ Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP\r
+ If intDontReleaseCapture Then\r
+ PostGuiEvent EVENT_MOUSEUP, owner, data\r
+ Else\r
+ SystemEmitOSEvent hwnd,msg,wp,lp,owner\r
+ EndIf\r
+ Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN\r
+ SystemEmitOSEvent hwnd,msg,wp,lp,owner\r
+ EndSelect\r
+ \r
+ EndIf\r
+ EndIf\r
+ EndIf\r
+ Return CallNextHookEx( MouseMessageHook,code,wparam,lparam )\r
+ EndFunction\r
+ \r
+ Global intEmitOSEvent\r
+ \r
+ Function SystemEmitOSEvent( hwnd, msg, wp, lp, owner:TGadget )\r
+ intEmitOSEvent:+1\r
+ If owner Then\r
+ While owner.source\r
+ owner = owner.source\r
+ Wend\r
+ EndIf\r
+ Local tmpResult% = bbSystemEmitOSEvent( hwnd, msg, wp, lp, owner )\r
+ intEmitOSEvent:-1\r
+ Return tmpResult\r
+ EndFunction\r
+ \r
+ Function ClassName$()\r
+ Global _name$\r
+ Global _wc:WNDCLASSW\r
+ Global _icon\r
+ \r
+ If Not _name\r
+ _name="BLITZMAX_WINDOW_CLASS"\r
+ _icon=LoadIconW(GetModuleHandleW(Null),Short Ptr(101))\r
+ _wc=New WNDCLASSW\r
+ _wc.style=CS_OWNDC|CS_HREDRAW|CS_VREDRAW\r
+ _wc.lpfnWndProc=ClassWndProc\r
+ _wc.hInstance=GetModuleHandleW(Null)\r
+ _wc.hIcon=_icon\r
+ _wc.hCursor=LoadCursorW( 0,Short Ptr( IDC_ARROW ) )\r
+ _wc.hbrBackground=COLOR_BTNSHADOW\r
+ _wc.lpszMenuName=Null\r
+ _wc.lpszClassName=_name.ToWString()\r
+ _wc.cbWndExtra=DLGWINDOWEXTRA\r
+ ClassAtom=RegisterClassW(_wc)\r
+ EndIf\r
+ Return _name\r
+ EndFunction\r
+ \r
+ Function DialogClassName$()\r
+ Global _dname$\r
+ Global _dc:WNDCLASSW\r
+ \r
+ If Not _dname\r
+ _dname="BLITZMAX_DIALOG_CLASS"\r
+ _dc=New WNDCLASSW\r
+ _dc.style=CS_OWNDC|CS_HREDRAW|CS_VREDRAW\r
+ _dc.lpfnWndProc=ClassWndProc\r
+ _dc.hInstance=GetModuleHandleW(Null)\r
+ _dc.hCursor=LoadCursorW( 0,Short Ptr( IDC_ARROW ) )\r
+ _dc.hbrBackground=COLOR_BTNSHADOW\r
+ _dc.lpszMenuName=Null\r
+ _dc.lpszClassName=_dname.ToWString()\r
+ _dc.cbWndExtra=DLGWINDOWEXTRA\r
+ ClassAtom2=RegisterClassW(_dc)\r
+ EndIf\r
+ Return _dname\r
+ EndFunction\r
+ \r
+ 'TMaxGuiDriver interface \r
+ \r
+ Method CreateGadget:TGadget(class,Text$,x,y,w,h,group:TGadget,style)\r
+ \r
+ Select class\r
+ Case GADGET_WINDOW\r
+ If Not group group=GDIDesktop\r
+ End Select\r
+ \r
+ Local gadget:TGadget = GadgetInstanceFromClass(class,group,style,Text)\r
+ \r
+ Select class\r
+ Case GADGET_DESKTOP, GADGET_MENUITEM, GADGET_NODE\r
+ Return gadget\r
+ End Select\r
+ \r
+ If LocalizationMode() & LOCALIZATION_OVERRIDE Then\r
+ LocalizeGadget(gadget,Text,"")\r
+ Else\r
+ gadget.SetText(Text)\r
+ EndIf\r
+ \r
+ If group Then gadget._SetParent group\r
+ If class <> GADGET_TOOLBAR Then gadget.SetShape(x,y,w,h)\r
+ \r
+ 'v0.51: Gadgets are now only shown when they have been sized, and the text set.\r
+ If TWindowsGadget(gadget) Then\r
+ If Not TWindowsWindow(gadget)\r
+ gadget.SetFont(GDIFont)\r
+ If TWindowsGadget(group) Then\r
+ TWindowsGadget(gadget)._forceDisable = Not( TWindowsGadget(group)._enabled And Not TWindowsGadget(group)._forceDisable )\r
+ gadget.SetEnabled(Not (gadget.State()&STATE_DISABLED))\r
+ EndIf\r
+ gadget.SetShow(True)\r
+ ElseIf Not (style & WINDOW_HIDDEN) Then\r
+ gadget.SetShow(True)\r
+ EndIf\r
+ EndIf\r
+ \r
+ If TWindowsGadget(gadget) Then TWindowsGadget(gadget).Sensitize()\r
+ \r
+ Return gadget\r
+ EndMethod\r
+ \r
+ Method GadgetInstanceFromClass:TGadget(class, group:TGadget, style = 0, Text$ = "")\r
+ \r
+ Local gadget:TGadget\r
+ \r
+ Select class\r
+ Case GADGET_DESKTOP\r
+ gadget=GDIDesktop\r
+ Case GADGET_MENUITEM\r
+ gadget=New TWindowsMenu.Create(group,style,Text)\r
+ Case GADGET_WINDOW\r
+ gadget=New TWindowsWindow.Create(group,style)\r
+ Case GADGET_BUTTON\r
+ gadget=New TWindowsButton.Create(group,style)\r
+ Case GADGET_TEXTFIELD\r
+ gadget=New TWindowsTextField.Create(group,style,Text)\r
+ Case GADGET_TEXTAREA\r
+ gadget=New TWindowsTextArea.Create(group,style)\r
+ Case GADGET_COMBOBOX\r
+ gadget=New TWindowsComboBox.Create(group,style,Text)\r
+ Case GADGET_LISTBOX\r
+ gadget=New TWindowsListBox.Create(group,style)\r
+ Case GADGET_TOOLBAR\r
+ gadget=New TWindowsToolBar.Create(group,style,Text)\r
+ Case GADGET_TABBER\r
+ gadget=New TWindowsTabber.Create(group,style)\r
+ Case GADGET_NODE \r
+ gadget=New TWindowsTreeNode.Create(group,style,Text)\r
+ Case GADGET_TREEVIEW\r
+ gadget=New TWindowsTreeView.Create(group,style)\r
+ Case GADGET_LABEL\r
+ gadget=New TWindowsLabel.Create(group,style)\r
+ Case GADGET_SLIDER\r
+ gadget=New TWindowsSlider.Create(group,style)\r
+ Case GADGET_PROGBAR\r
+ gadget=New TWindowsProgressBar.Create(group,style)\r
+ Case GADGET_PANEL\r
+ gadget=New TWindowsPanel.Create(group,style)\r
+ Case GADGET_CANVAS\r
+ gadget=New TWindowsPanel.Create(group,style|PANEL_CANVAS|PANEL_ACTIVE)\r
+ Case GADGET_HTMLVIEW\r
+ gadget=New TWindowsHTMLView.Create(group,style)\r
+ End Select\r
+ \r
+ Return gadget\r
+ \r
+ EndMethod\r
+ \r
+ Method ActiveGadget:TGadget()\r
+ Local tmpHwnd:Int = GetFocus(), tmpGadget:TGadget\r
+ While tmpHwnd\r
+ tmpGadget = GadgetFromHwnd( tmpHwnd )\r
+ If tmpGadget Then Exit\r
+ tmpHwnd = GetParent_(tmpHwnd)\r
+ Wend\r
+ Return tmpGadget\r
+ EndMethod\r
+ \r
+ Method RequestColor(red,green,blue)\r
+ Local cc:CHOOSECOLOR = New CHOOSECOLOR\r
+ cc.lStructSize=SizeOf(cc)\r
+ cc.hwndOwner=GetActiveHwnd()\r
+ cc.rgbResult=(red)|(green Shl 8)|(blue Shl 16)\r
+ cc.lpCustColors=_customcolors\r
+ cc.Flags=CC_RGBINIT|CC_FULLOPEN|CC_ANYCOLOR\r
+ Local hwnd = GetFocus()\r
+ Local n = ChooseColorW(cc)\r
+ SetFocus(hwnd) \r
+ If Not n Return 0 \r
+ n = ((cc.rgbResult Shr 16)&$ff) | (cc.rgbResult&$ff00) | ((cc.rgbResult Shl 16)&$ff0000)\r
+ Return n|$ff000000\r
+ EndMethod\r
+\r
+ Method LookupColor( colorindex:Int, red:Byte Var, green:Byte Var, blue:Byte Var )\r
+ \r
+ Select colorindex\r
+ Case GUICOLOR_WINDOWBG\r
+ colorindex = COLOR_BTNFACE\r
+ Case GUICOLOR_GADGETBG\r
+ colorindex = COLOR_WINDOW\r
+ Case GUICOLOR_GADGETFG\r
+ colorindex = COLOR_WINDOWTEXT\r
+ Case GUICOLOR_LINKFG\r
+ colorindex = COLOR_HOTLIGHT\r
+ Case GUICOLOR_SELECTIONBG\r
+ colorindex = COLOR_HIGHLIGHT\r
+ Default\r
+ Return Super.LookupColor( colorindex, red, green, blue )\r
+ EndSelect\r
+ \r
+ Local tmpColor:Int = GetSysColor( colorindex )\r
+ red = tmpColor & $FF\r
+ green = (tmpColor Shr 8) & $FF\r
+ blue = (tmpColor Shr 16) & $FF\r
+ \r
+ Return True\r
+ \r
+ EndMethod\r
+\r
+ Method LoadFont:TGuiFont(name$,size,flags)\r
+ Return New TWindowsFont.Load(name,Double(size),flags)\r
+ EndMethod\r
+ \r
+ Method LoadFontWithDouble:TGuiFont(name$,size:Double,flags)\r
+ Return New TWindowsFont.Load(name,size,flags)\r
+ EndMethod\r
+ \r
+ Method LibraryFont:TGuiFont( pFontType% = GUIFONT_SYSTEM, pFontSize:Double = 0, pFontStyle% = FONT_NORMAL )\r
+ If pFontType = GUIFONT_SYSTEM Then Return TWindowsFont.DefaultFont( pFontSize, pFontStyle ) Else Return Super.LibraryFont( pFontType, pFontSize, pFontStyle )\r
+ EndMethod\r
+ \r
+ Method RequestFont:TGuiFont(font:TGuiFont)\r
+ Return TWindowsFont.Request(font)\r
+ EndMethod\r
+ \r
+ Method SetPointer(shape)\r
+ Global winptrs[]=[0,32512,32513,32514,32515,32516,32642,32643,32644,32645,32646,32648,32649,32650,32651]\r
+ If shape<1 Or shape>14 Then _cursor = LoadCursorW( 0,Short Ptr( IDC_ARROW ) ) Else _cursor=LoadCursorW(0,Short Ptr(winptrs[shape]))\r
+ SetCursor(_cursor)\r
+ If TWindowsTextArea._oldCursor Then TWindowsTextArea._oldCursor = _cursor\r
+ If shape = 0 Then _cursor = 0\r
+ EndMethod\r
+\r
+ Method LoadIconStrip:TIconStrip(source:Object) \r
+ Return TWindowsIconStrip.Create(source)\r
+ EndMethod\r
+\r
+ Function CheckCommonControlVersion() 'Returns True if supports alpha/themes etc. or False if not.\r
+ If Not _commoncontrolversion Then\r
+ Local libComCtl = LoadLibraryW("comctl32.dll")\r
+ Local GetCommonControlVersion( pDllVersionInfo:Byte Ptr ) "win32" = GetProcAddress(libComCtl, "DllGetVersion")\r
+ If GetCommonControlVersion Then\r
+ Local tmpDllVersion:DLLVERSIONINFO2 = New DLLVERSIONINFO2\r
+ GetCommonControlVersion( tmpDllVersion )\r
+ _commoncontrolversion = [tmpDllVersion.dwMajorVersion,tmpDllVersion.dwMinorVersion,tmpDLLVersion.dwBuildNo]\r
+ EndIf\r
+ GetCommonControlVersion = Null\r
+ FreeLibrary( libComCtl )\r
+ EndIf\r
+ If _commoncontrolversion And _commoncontrolversion[0] >= 6 Then\r
+ If (_commoncontrolversion[0] > 6) Or (_commoncontrolversion[1] > 0) Then Return 2 Else Return 1\r
+ EndIf\r
+ EndFunction\r
+ \r
+ Function GetThemeHandle(hwnd, pClass$ = "WINDOW")\r
+ If OpenThemeData And CheckCommonControlVersion() Then Return OpenThemeData(hwnd, pClass)\r
+ EndFunction\r
+\r
+ Function CloseThemeHandle(hTheme)\r
+ If CloseThemeData Then Return CloseThemeData(hTheme)\r
+ EndFunction\r
+ \r
+ Function CreateExplorerStyleGadgets( pDisable = False )\r
+ _explorerstyle = (pDisable <> True)\r
+ EndFunction\r
+ \r
+ Function GetActiveHwnd()\r
+ If _activeWindow Then Return _activeWindow._hwnd Else Return GetActiveWindow()\r
+ EndFunction\r
+ \r
+EndType\r
+\r
+Type TWindowsGadget Extends TGadget\r
+ \r
+ 'Flag that determines whether gadgets should redraw when they are resized (see Rethink()).\r
+ Global _resizeRedraw = True\r
+ \r
+ 'Generic Unicode Strings to prevent memory-leak\r
+ Global _wstrEmpty:Short Ptr = "".ToWString()\r
+ Global _wstrSpace:Short Ptr = " ".ToWString()\r
+ Global _wstrExplorer:Short Ptr = "Explorer".ToWString()\r
+ \r
+ 'Important gadget fields that store OS control handles etc..\r
+ \r
+ Field _class, _hwnd, _hwndclient, _tooltips\r
+ Field _proc(hwnd,msg,wp,lp) "win32"\r
+ Field _hotkey:THotKey\r
+ Field _oldcursorlp 'Should track events\r
+ \r
+ Field _sensitive% = False 'Determines whether gadgets should generate events.\r
+ 'Not to be confused with the sensitivity field of TGadget\r
+ 'which specifies which type of events are fired.\r
+ \r
+ 'Aesthetics\r
+ Field _bgbrush, _fgcolor = -1, _bgcolor = -1 'Background colour\r
+ Field _hbrush, _hbitmap 'Background colour\r
+ Field _bitmap 'Background bitmap\r
+ Field _iconBitmap 'Icon bitmap\r
+ Field _hTheme 'Open handle to XP Theme API (for use in button's WM_DRAWITEM etc.)\r
+ Field _font:TWindowsFont 'Font (needs to be stored, otherwise it may be collected by GC)\r
+ Field _wstrTooltip:Short Ptr, _toolAdded = False\r
+ Field _clientX:Int, _clientY:Int, _enabled:Int = True, _forcedisable:Int = False\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget, style, Text$="") Abstract\r
+ \r
+ Method SetColor(red,green,blue)\r
+ If _bgbrush Then DeleteObject _bgbrush\r
+ _bgcolor = (blue Shl 16) | (green Shl 8) | red\r
+ _bgbrush=CreateSolidBrush(_bgcolor)\r
+ RedrawGadget(Self)\r
+ EndMethod\r
+\r
+ Method RemoveColor()\r
+ If _bgbrush Then DeleteObject _bgbrush\r
+ _bgbrush=0\r
+ RedrawGadget(Self)\r
+ EndMethod\r
+ \r
+ Method FgColor()\r
+ Return _fgcolor\r
+ EndMethod\r
+ \r
+ Method BgColor()\r
+ Return _bgcolor\r
+ EndMethod\r
+ \r
+ Method BgBrush()\r
+ Return _bgbrush\r
+ EndMethod\r
+\r
+ Method SetTextColor(r,g,b)\r
+ _fgcolor = (b Shl 16) | (g Shl 8) | r\r
+ RedrawGadget(Self)\r
+ EndMethod\r
+\r
+ Method Query(queryid)\r
+ Select queryid\r
+ Case QUERY_HWND\r
+ Return _hwnd\r
+ Case QUERY_HWND_CLIENT\r
+ If _hwndclient Return _hwndclient\r
+ Return _hwnd\r
+ End Select \r
+ EndMethod\r
+\r
+ Method Register(class,hwnd,hwndclient=0,tips=False)\r
+ _class=class\r
+ _hwnd=hwnd\r
+ _hwndclient=hwndclient\r
+ TWindowsGUIDriver.RegisterHwnd(_hwnd,Self) \r
+ If _hwndclient TWindowsGUIDriver.RegisterHwnd(_hwndclient,Self) \r
+ Local atom=GetClassLongW(hwnd,GCW_ATOM)\r
+ If atom<>TWindowsGUIDriver.ClassAtom And atom<>TWindowsGUIDriver.ClassAtom2 And Not _proc\r
+ _proc=Byte Ptr(SetWindowLongW(hwnd,GWL_WNDPROC,Int Byte Ptr TWindowsGUIDriver.ClassWndProc))\r
+ EndIf\r
+ If tips Then SetupToolTips() \r
+ EndMethod \r
+ \r
+ Method SetupToolTips()\r
+ If _tooltips Then DestroyWindow _tooltips;TWindowsGUIDriver.RemoveHwnd(_tooltips);_tooltips = 0\r
+ _tooltips = CreateWindowExW( 0,"tooltips_class32","",TTS_ALWAYSTIP,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,_hwnd,0,GetModuleHandleW(Null),Null )\r
+ SendMessageW _tooltips,TTM_SETMAXTIPWIDTH,0,300\r
+ TWindowsGUIDriver.RegisterHwnd( _tooltips, Self )\r
+ EndMethod\r
+ \r
+ Method isTabbable()\r
+ Local style:Int = GetWindowLongW(_hwnd,GWL_STYLE)&(WS_TABSTOP|WS_CHILD)\r
+ Return (style=(WS_TABSTOP|WS_CHILD))\r
+ EndMethod\r
+ \r
+ Method isControl()\r
+ Return (GetWindowLongW(_hwnd,GWL_STYLE)&(WS_CHILD)=WS_CHILD)\r
+ EndMethod\r
+\r
+ Method Activate(cmd)\r
+ Select cmd\r
+ Case ACTIVATE_FOCUS\r
+ If isTabbable()\r
+ DefDlgProcW GetParent_(_hwnd),WM_NEXTDLGCTL,_hwnd,1\r
+ Return 1\r
+ EndIf\r
+ Return SetFocus(_hwnd)\r
+ Case ACTIVATE_BACK\r
+ Return SendMessageW(_hwnd,WM_NEXTDLGCTL,1,0)\r
+ Case ACTIVATE_FORWARD\r
+ Return SendMessageW(_hwnd,WM_NEXTDLGCTL,0,0)\r
+ Case ACTIVATE_REDRAW\r
+ RefreshLook()\r
+ Return RedrawWindow( _hwnd, Null, Null, RDW_INVALIDATE | RDW_ERASE | RDW_FRAME | RDW_ALLCHILDREN )\r
+ End Select\r
+ EndMethod\r
+ \r
+ Method Rethink()\r
+ QueueResize(_hwnd,xpos,ypos,width,height)\r
+ EndMethod \r
+ \r
+ Method RethinkClient(forceRedraw:Int = False)\r
+ EndMethod\r
+ \r
+ Method SetArea(x,y,w,h)\r
+ SetRect(x,y,w,h)\r
+ Rethink()\r
+ EndMethod\r
+ \r
+ Method LayoutKids()\r
+ \r
+ StartResize()\r
+ \r
+ 'Implemented hack to speed-up drawing considerably...\r
+ Local tmpOldState = TWindowsGadget._resizeredraw\r
+ TWindowsGadget._resizeredraw = False\r
+ \r
+ 'Child windows are laid-out like normal...\r
+ Super.LayoutKids()\r
+ \r
+ 'Reposition all child gadgets together.\r
+ EndResize()\r
+ \r
+ 'If this control is the first parent who started the resizing, then redraw parent and all controls now.\r
+ If tmpOldState Then\r
+ If (Not kids.IsEmpty()) Then Activate(ACTIVATE_REDRAW)\r
+ TWindowsGadget._resizeredraw = True\r
+ EndIf\r
+ \r
+ EndMethod\r
+ \r
+ Method ClientWidth()\r
+ Local Rect[] = [xpos,ypos,xpos+width,ypos+height]\r
+ SendMessageW Query(QUERY_HWND), WM_NCCALCSIZE, False, Int Byte Ptr Rect\r
+ Return Rect[2]-Rect[0]-_clientX\r
+ EndMethod\r
+\r
+ Method ClientHeight()\r
+ Local Rect[] = [xpos,ypos,xpos+width,ypos+height]\r
+ SendMessageW Query(QUERY_HWND), WM_NCCALCSIZE, False, Int Byte Ptr Rect\r
+ Return Rect[3]-Rect[1]-_clientY\r
+ EndMethod\r
+ \r
+ Method SetText(Text$)\r
+ Desensitize()\r
+ SetWindowTextW _hwnd, Text\r
+ Sensitize()\r
+ EndMethod \r
+ \r
+ Method GetText$()\r
+ Local strText:Short[GetWindowTextLengthW(_hwnd)+1] 'Must include NULL terminator.\r
+ GetWindowTextW _hwnd, strText, strText.length\r
+ Return String.FromWString( strText )\r
+ EndMethod\r
+ \r
+ Method SetFont(font:TGuiFont)\r
+ If TWindowsFont(font) Then _font = TWindowsFont(font) Else _font = TWindowsGUIDriver.GDIFont\r
+ SendMessageW _hwnd,WM_SETFONT,font.handle,1\r
+ EndMethod\r
+ \r
+ Method SetShow(show)\r
+ If show\r
+ ShowWindow _hwnd,SW_SHOW\r
+ Else\r
+ 'Requester fix - ShowWindow activates the last activated window when an active window is hidden, so if\r
+ 'a file requester/child gadget was the last window to be activated, then the program will lose focus as it is\r
+ 'trying to activate a non-existent window.\r
+ If parent And HasDescendant(ActiveGadget()) Then ActivateGadget(parent)\r
+ ShowWindow _hwnd,SW_HIDE\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method SetEnabled(enable)\r
+ _enabled = enable\r
+ enable = enable And Not _forceDisable\r
+ If Not((EnableWindow(_hwnd,enable)<>0) ~ enable) Then\r
+ For Local tmpGadget:TWindowsGadget = EachIn kids\r
+ tmpGadget._forceDisable = Not enable\r
+ If tmpGadget.isControl() Then tmpGadget.SetEnabled(tmpGadget._enabled)\r
+ Next\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ \r
+ If _wstrTooltip Then MemFree _wstrTooltip;_wstrTooltip = Null\r
+ \r
+ Local tmpToolInfo:TOOLINFOW = New TOOLINFOW\r
+ tmpToolInfo.cbSize = SizeOf(tmpToolInfo)\r
+ tmpToolInfo.hwnd = GetParent_(_hwnd)\r
+ tmpToolInfo.hinst = GetModuleHandleW(Null)\r
+ tmpToolInfo.uID = _hwnd\r
+ \r
+ If pTooltip Then\r
+ _wstrTooltip = pTooltip.Replace("~r","").Replace("~n","~r~n").ToWString()\r
+ \r
+ tmpToolInfo.uFlags = TTF_IDISHWND|TTF_TRANSPARENT|TTF_SUBCLASS\r
+ tmpToolInfo.lpszText = _wstrTooltip\r
+ \r
+ If Not _toolAdded Then\r
+ _toolAdded = SendMessageW(TWindowsGUIDriver._hwndTooltips, TTM_ADDTOOLW, 0, Int Byte Ptr tmpToolInfo)\r
+ Else\r
+ SendMessageW(TWindowsGUIDriver._hwndTooltips, TTM_UPDATETIPTEXTW, 0, Int Byte Ptr tmpToolInfo)\r
+ EndIf\r
+ ElseIf _tooladded Then\r
+ SendMessageW(TWindowsGUIDriver._hwndTooltips, TTM_DELTOOLW, 0, Int Byte Ptr tmpToolInfo )\r
+ _toolAdded = 0\r
+ EndIf\r
+ \r
+ EndMethod\r
+ \r
+ Method GetTooltip$()\r
+ If _wstrTooltip Then Return String.FromWString(_wstrTooltip)\r
+ EndMethod\r
+ \r
+ Method State()\r
+ Local t, style = GetWindowLongW(_hwnd, GWL_STYLE)\r
+ If Not (style&WS_VISIBLE) Then t:|STATE_HIDDEN\r
+ If Not _enabled Then t:|STATE_DISABLED\r
+ Return t\r
+ EndMethod\r
+\r
+ Method Free()\r
+ If _tooltips Then DestroyWindow _tooltips;_tooltips=0\r
+ SetTooltip("") 'Free any tooltip memory allocations\r
+ If _hwnd Then DestroyWindow _hwnd;TWindowsGUIDriver.RemoveHwnd(_hwnd);_hwnd=0\r
+ If _hwndclient Then TWindowsGUIDriver.RemoveHwnd(_hwndclient);_hwndclient=0\r
+ FlushBrushes(False)\r
+ If _hotKey Then RemoveHotKey(_hotKey);_hotKey = Null\r
+ If _iconBitmap Then DeleteObject(_iconBitmap);_iconBitmap = 0\r
+ If _bitmap Then DeleteObject(_bitmap);_bitmap = 0\r
+ If _bgbrush Then DeleteObject(_bgbrush);_bgbrush = 0\r
+ If _htheme Then TWindowsGUIDriver.CloseThemeHandle(_hTheme);_hTheme = 0\r
+ _font = Null\r
+ _SetParent Null\r
+ EndMethod \r
+ \r
+ Method OnNotify(wp,lp)\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ Case WM_WINDOWPOSCHANGING\r
+ FlushBrushes()\r
+ EndSelect\r
+ If _proc And _hwnd = hwnd Then\r
+ Return CallWindowProcW(_proc,hwnd,msg,wp,lp) 'fixed auto scrollbars\r
+ EndIf\r
+ Return DefWindowProcW( hwnd,msg,wp,lp )\r
+ EndMethod\r
+ \r
+ Method OnCommand(msg,wp)\r
+ EndMethod\r
+ \r
+ Method OnDrawItem( pDrawItemStruct:DRAWITEMSTRUCT )\r
+ EndMethod\r
+ \r
+ Method SetHotKey(key,modifier)\r
+ Local ev:TEvent = CreateEvent( EVENT_GADGETACTION,Self )\r
+ If _hotKey Then RemoveHotKey(_hotKey);_hotKey = Null\r
+ If key Then _hotkey=SetHotKeyEvent(key,modifier,ev,FindGadgetWindowHwnd(Self))\r
+ EndMethod\r
+ \r
+ 'Slow back-up code for mimicking transparency for PANEL_GROUPs and when\r
+ 'DrawThemeParentBackground() is not available (i.e. on Windows 9x/2000).\r
+ Method CreateControlBrush( hWndControl, hdc = 0 )\r
+ \r
+ Local xOffset, yOffset\r
+ Local hwndWindow = GetParent_(hwndControl)\r
+ Local rectWindow[4], rectControl[4], rectClient[4]\r
+ \r
+ If _hbrush Then Return _hbrush\r
+ \r
+ If BgBrush() Then\r
+ If hdc Then SetBkColor(hdc, BgColor())\r
+ Return BgBrush()\r
+ EndIf\r
+ \r
+ Local tmpDC = GetDC( hwndWindow )\r
+ \r
+ 'Fix required to offset background when controls are drawn with WS_EX_CLIENTEDGE (e.g. panel with PANEL_SUNKEN/PANEL_RAISED set)\r
+ If GetWindowLongW(hwndWindow,GWL_EXSTYLE)&(WS_EX_CLIENTEDGE|WS_EX_WINDOWEDGE) Then\r
+ xOffset = -GetSystemMetrics(SM_CXEDGE)\r
+ yOffset = -GetSystemMetrics(SM_CYEDGE)\r
+ EndIf\r
+ \r
+ GetClientRect( hwndControl, rectClient )\r
+ GetWindowRect( hwndWindow, rectWindow )\r
+ GetWindowRect( hwndControl, rectControl )\r
+ \r
+ Local x = rectControl[0]-rectWindow[0]\r
+ Local y = rectControl[1]-rectWindow[1]\r
+ Local w = rectControl[2]-rectControl[0]\r
+ Local h = rectControl[3]-rectControl[1]\r
+ \r
+ Local dcBitmap = CreateCompatibleDC( tmpDC )\r
+ Local bkgndBitmap = CreateCompatibleBitmap( tmpDC, rectWindow[2]-rectWindow[0], rectWindow[3]-rectWindow[1] )\r
+ SelectObject( dcBitmap, bkgndBitmap )\r
+ \r
+ 'InvalidateRect( hwndWindow, Null, False )\r
+ SendMessageW hwndWindow, WM_ERASEBKGND, dcBitmap, 0\r
+ \r
+ Local bkgndClientBitmap = CreateCompatibleBitmap( tmpDC, w, h )\r
+ Local dcClientBitmap = CreateCompatibleDC( tmpDC )\r
+ SelectObject( dcClientBitmap, bkgndClientBitmap )\r
+ \r
+ BitBlt( dcClientBitmap, 0,0 , w, h, dcBitmap, x+xOffset, y+yOffset, ROP_SRCCOPY )\r
+ \r
+ DeleteObject( bkgndBitmap )\r
+ DeleteDC( dcBitmap )\r
+ DeleteDC( dcClientBitmap )\r
+ \r
+ _hbrush = CreatePatternBrush( bkgndClientBitmap )\r
+ _hbitmap = bkgndClientBitmap\r
+ \r
+ ReleaseDC( hwndWindow, tmpDC )\r
+ \r
+ Return _hbrush\r
+ \r
+ EndMethod\r
+ \r
+ 'Clears the parent background brushes.\r
+ Method FlushBrushes(pRecurse:Int = True)\r
+ Local tmpChanges:Int = 0\r
+ If _hbrush Then\r
+ DeleteObject( _hbrush )\r
+ _hbrush = 0\r
+ tmpChanges:|True\r
+ EndIf\r
+ If _hBitmap Then\r
+ DeleteObject( _hBitmap )\r
+ _hBitmap = 0\r
+ tmpChanges:|True\r
+ EndIf\r
+ Return tmpChanges\r
+ EndMethod\r
+ \r
+ 'Method that returns a brush for drawing backgrounds.\r
+ Method DrawBackground( hdc, hwnd )\r
+ \r
+ If BgBrush() Then SetBkColor(hdc, BgColor());Return BgBrush()\r
+ \r
+ Return DrawParentBackground( hdc, hwnd )\r
+\r
+ EndMethod\r
+ \r
+ 'Another method which mimics transparency on Windows Controls.\r
+ Function DrawParentBackground( hdc, hwndControl, pForceHack = False )\r
+ \r
+ Local rectWindow[4], rectControl[4], rectClient[4]\r
+ Local hwndWindow = GetParent_(hwndControl)\r
+\r
+ GetClientRect( hwndControl, rectClient )\r
+ GetClientRect( hwndWindow, rectWindow )\r
+ GetWindowRect( hwndControl, rectControl )\r
+ \r
+ 'Ensures that the the drawing context is returned in exactly the same state that it was passed.\r
+ Local tmpSaveState = SaveDC( hdc )\r
+ \r
+ If DrawThemeParentBackground And Not pForceHack Then\r
+ \r
+ DrawThemeParentBackground(hwndControl,hdc,rectClient)\r
+ \r
+ Else 'Again, slow back-up code in case DrawThemeParentBackground() is not available.\r
+ \r
+ Local tmpDC, xOffset, yOffset\r
+ \r
+ 'Fix required to offset background when controls are drawn with WS_EX_CLIENTEDGE (e.g. panel with PANEL_BORDER set)\r
+ If GetWindowLongW(hwndWindow,GWL_EXSTYLE)&WS_EX_CLIENTEDGE Then\r
+ xOffset = -GetSystemMetrics(SM_CXEDGE)\r
+ yOffset = -GetSystemMetrics(SM_CYEDGE)\r
+ EndIf\r
+ \r
+ tmpDC = GetDC( hwndWindow )\r
+ \r
+ ScreenToClient( hwndWindow, rectControl )\r
+ ScreenToClient( hwndWindow, Int Ptr (rectControl)+2 )\r
+ \r
+ Local x = rectControl[0]+rectClient[0]\r
+ Local y = rectControl[1]+rectClient[1]\r
+ Local w = rectClient[2]-rectClient[0]\r
+ Local h = rectClient[3]-rectClient[1]\r
+ \r
+ Local bkgndBitmap = CreateCompatibleBitmap( tmpDC, rectWindow[2]-rectWindow[0], rectWindow[3]-rectWindow[1] )\r
+ Local dcBitmap = CreateCompatibleDC( tmpDC )\r
+ SelectObject( dcBitmap, bkgndBitmap )\r
+ \r
+ InvalidateRect( hwndWindow, Null, False )\r
+ SendMessageW hwndWindow, WM_ERASEBKGND, dcBitmap, 0\r
+ \r
+ BitBlt( hdc, 0,0 , w, h, dcBitmap, x+xOffset, y+yOffset, ROP_SRCCOPY )\r
+ \r
+ DeleteObject( bkgndBitmap )\r
+ DeleteDC( dcBitmap )\r
+ ReleaseDC( hwndWindow, tmpDC )\r
+ \r
+ EndIf\r
+ \r
+ 'Ensures that the the drawing context is returned in exactly the same state that it was passed.\r
+ RestoreDC( hdc, tmpSaveState )\r
+ \r
+ Return GetStockObject( NULL_BRUSH )\r
+ \r
+ EndFunction\r
+ \r
+ Method Sensitize()\r
+ _sensitive = True\r
+ EndMethod\r
+ \r
+ Method DeSensitize()\r
+ _sensitive = False\r
+ EndMethod\r
+ \r
+ Method PostGuiEvent( pID%, pData%=0, pMods%=0, pX%=0, pY%=0, pExtra:Object = Null)\r
+ \r
+ Select True\r
+ Case TWindowsListBox(Self) <> Null, TWindowsTabber(Self) <> Null, TWindowsToolbar(Self) <> Null, TWindowsCombobox(Self) <> Null\r
+ If pData>-1 Then\r
+ If (ItemFlags(pData) & GADGETITEM_TOGGLE) Then SelectItem(pData,2)\r
+ EndIf\r
+ End Select\r
+ \r
+ If _sensitive Then MaxGUI.MaxGUI.PostGuiEvent( pID, Self, pData, pMods, pX, pY, pExtra )\r
+ \r
+ EndMethod\r
+ \r
+ 'Resize Methods\r
+ \r
+ Field hdwpStruct\r
+ \r
+ Method StartResize()\r
+ If Not hdwpStruct Then\r
+ Local tmpCount = kids.Count()\r
+ If tmpCount Then hdwpStruct = BeginDeferWindowPos( tmpCount )\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method QueueResize( hwnd, xpos, ypos, width, height )\r
+ If parent And GetParent_(hwnd) = parent.Query(QUERY_HWND_CLIENT) And TWindowsGadget(parent).hdwpStruct Then\r
+ Local tmpFlags = SWP_NOOWNERZORDER | SWP_NOZORDER | SWP_NOACTIVATE' | SWP_NOCOPYBITS\r
+ If Not _resizeRedraw Then tmpFlags:| SWP_NOREDRAW\r
+ TWindowsGadget(parent).hdwpStruct = DeferWindowPos( TWindowsGadget(parent).hdwpStruct, hwnd, Null, xpos, ypos, width, height, tmpFlags )\r
+ Else\r
+ MoveWindow( hwnd, xpos, ypos, width, height, _resizeRedraw )\r
+ HasResized()\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method EndResize()\r
+ If hdwpStruct Then\r
+ EndDeferWindowPos( hdwpStruct );hdwpStruct = 0\r
+ For Local tmpGadget:TWindowsGadget = EachIn kids\r
+ Sensitize()\r
+ tmpGadget.HasResized()\r
+ Next\r
+ EndIf\r
+ EndMethod\r
+ \r
+ 'Required for resizing columns in listboxes (has to be done outside WM_SIZE)\r
+ Method HasResized()\r
+ EndMethod\r
+ \r
+ 'Required to ensure problematic controls are updated when parent aesthetics are changed:\r
+ Method RefreshLook()\r
+ FlushBrushes(False)\r
+ For Local tmpGadget:TWindowsGadget = EachIn kids\r
+ tmpGadget.RefreshLook()\r
+ Next\r
+ EndMethod\r
+ \r
+Rem \r
+ Method StartDoubleBuffer()\r
+ For Local tmpGadget:TWindowsGadget = EachIn kids\r
+ tmpGadget.StartDoubleBuffer()\r
+ Next\r
+ EndMethod\r
+\r
+ Method EndDoubleBuffer()\r
+ For Local tmpGadget:TWindowsGadget = EachIn kids\r
+ tmpGadget.EndDoubleBuffer()\r
+ Next\r
+ EndMethod\r
+EndRem \r
+EndType\r
+\r
+\r
+Type TWindowsDesktop Extends TWindowsGadget\r
+\r
+ Method New()\r
+ Local Rect[4]\r
+ Local hwnd = GetDesktopWindow()\r
+ Register(GADGET_DESKTOP,hwnd,0,False)\r
+ GetClientRect hwnd,Rect\r
+ SetShape 0,0,Rect[2]-Rect[0],Rect[3]-Rect[1]\r
+ EndMethod\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="")\r
+ Return Self\r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ 'Shouldn't have tool-tips.\r
+ EndMethod\r
+ \r
+ Method Free()\r
+ 'Can't be free'd.\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_DESKTOP\r
+ EndMethod\r
+ \r
+ Method ClientHeight()\r
+ Local Rect[4]\r
+ If Super.ClientHeight() = height And SystemParametersInfoW( SPI_GETWORKAREA, 0, Int Byte Ptr Rect, 0 ) \r
+ Return Rect[3]-Rect[1]\r
+ Else\r
+ Return Super.ClientHeight()\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method ClientWidth()\r
+ Local Rect[4]\r
+ If Super.ClientWidth() = width And SystemParametersInfoW( SPI_GETWORKAREA, 0, Int Byte Ptr Rect, 0 ) \r
+ Return Rect[2]-Rect[0]\r
+ Else\r
+ Return Super.ClientWidth()\r
+ EndIf\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsWindow Extends TWindowsGadget\r
+ \r
+ Field _wstyle, _xstyle\r
+ Field _minwidth,_minheight,_maxwidth = -1,_maxheight = -1\r
+ Field _menu:TWindowsMenu\r
+ Field _hmenu\r
+ Field _status\r
+\r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="")\r
+ Local hwnd, parent, client\r
+ Local classname$ = TWindowsGUIDriver.ClassName()\r
+ \r
+ Self.style = style\r
+ _wstyle=WS_CLIPSIBLINGS|WS_CLIPCHILDREN\r
+ If group Then parent = group.Query(QUERY_HWND)\r
+ \r
+ If (style&WINDOW_TITLEBAR)\r
+ _wstyle:|WS_OVERLAPPED|WS_SYSMENU\r
+ If style&WINDOW_RESIZABLE _wstyle:|WS_MINIMIZEBOX|WS_MAXIMIZEBOX\r
+ If group <> TWindowsGUIDriver.GDIDesktop And Not (style&WINDOW_TOOL) Then\r
+ classname$ = TWindowsGUIDriver.DialogClassName()\r
+ _xstyle:|WS_EX_DLGMODALFRAME\r
+ EndIf\r
+ Else\r
+ _wstyle:|WS_POPUP \r
+ EndIf\r
+ \r
+ If style&WINDOW_RESIZABLE Then _wstyle:|WS_SIZEBOX \r
+ If style&WINDOW_MENU Then _hmenu=CreateMenu_();AppendMenuW( _hmenu,MF_STRING,Null,_wstrEmpty )\r
+ If style&WINDOW_TOOL Then _xstyle:|WS_EX_TOOLWINDOW\r
+ \r
+ ' Note: No WINDOW_HIDDEN case as gadgets are always created hidden to hide initial resize flicker.\r
+ ' TWindowsGUIDriver.CreateGadget() will later show window if WINDOW_HIDDEN is not specified.\r
+ \r
+ hwnd=CreateWindowExW(_xstyle,classname,"",_wstyle,0,0,0,0,parent,_hmenu,GetModuleHandleW(Null),Null)\r
+ \r
+ If style&WINDOW_STATUS\r
+ _status=CreateWindowExW(0,"msctls_statusbar32","",WS_CHILD|WS_VISIBLE,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null)\r
+ SetWindowPos( _status, HWND_TOPMOST,0,0,0,0,SWP_NOACTIVATE|SWP_NOMOVE|SWP_NOOWNERZORDER|SWP_NOSIZE)\r
+ EndIf\r
+ \r
+ client=CreateWindowExW(0,TWindowsGUIDriver.ClassName(),"",WS_CHILD|WS_VISIBLE|WS_CLIPCHILDREN|WS_CLIPSIBLINGS,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null)\r
+ \r
+ Register GADGET_WINDOW,hwnd,client,False\r
+\r
+ If style&WINDOW_ACCEPTFILES Then DragAcceptFiles _hwnd,True\r
+ _wstyle = GetWindowLongW( hwnd, GWL_STYLE )\r
+ \r
+ Return Self\r
+ EndMethod\r
+ \r
+ Method SetAlpha( alpha# )\r
+ If SetLayeredWindowAttributes Then\r
+ Local tmpStyle% = GetWindowLongW(_hwnd, GWL_EXSTYLE)\r
+ If alpha = 1.0 Then\r
+ SetLayeredWindowAttributes( _hwnd, 0, Byte(alpha*255), LWA_ALPHA)\r
+ If (tmpStyle & WS_EX_LAYERED) Then SetWindowLongW(_hwnd, GWL_EXSTYLE, tmpStyle&~WS_EX_LAYERED)\r
+ Else\r
+ If Not (tmpStyle & WS_EX_LAYERED) Then SetWindowLongW(_hwnd, GWL_EXSTYLE, tmpStyle|WS_EX_LAYERED)\r
+ SetLayeredWindowAttributes( _hwnd, 0, Byte(alpha*255), LWA_ALPHA)\r
+ EndIf\r
+ RedrawGadget(Self)\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method Rethink()\r
+ Local dimensions[] = [xpos,ypos,width,height]\r
+ ConvertToContainerDimensions( dimensions[0], dimensions[1], dimensions[2], dimensions[3] )\r
+ MoveWindow _hwnd, dimensions[0], dimensions[1], dimensions[2], dimensions[3], True\r
+ RethinkClient(True)\r
+ EndMethod \r
+ \r
+ Method RethinkClient(forceRedraw:Int = False)\r
+ If _hwndClient Then\r
+ MoveWindow _hwndClient, _clientx,_clienty,ClientWidth(),ClientHeight(),forceRedraw\r
+ EndIf\r
+ LayoutKids()\r
+ EndMethod\r
+ \r
+ \r
+ Method ClientWidth()\r
+ If (style & WINDOW_CLIENTCOORDS) Then Return width\r
+ Local Rect:Int[4]\r
+ GetClientRect _hwnd, Rect\r
+ Return Max(Rect[2]-Rect[0]-_clientX,0)\r
+ EndMethod\r
+ \r
+ Method ClientHeight()\r
+ If (style & WINDOW_CLIENTCOORDS) Then Return height\r
+ Local h:Int = height, Rect:Int[] = [0,0,width,height]\r
+ AdjustWindowRectEx(Rect,GetWindowLongW(_hwnd, GWL_STYLE),_hmenu,GetWindowLongW(_hwnd, GWL_EXSTYLE))\r
+ h:-(Rect[3]-Rect[1]+_clientY-height)\r
+ If _status Then GetWindowRect _status,Rect;h:-(Rect[3]-Rect[1])\r
+ Return Max(h,0)\r
+ End Method\r
+ \r
+ Method Class()\r
+ Return GADGET_WINDOW\r
+ EndMethod\r
+ \r
+ Method State()\r
+ Local t = Super.State()\r
+ If IsIconic(_hwnd) t:|STATE_MINIMIZED\r
+ If IsZoomed(_hwnd) t:|STATE_MAXIMIZED\r
+ Return t\r
+ EndMethod\r
+\r
+ Method SetEnabled(enable)\r
+ _enabled = enable\r
+ EnableWindow(_hwnd,enable)\r
+ EndMethod\r
+\r
+ Method SetMinimumSize(w,h)\r
+ 'Set minimum size for current window style\r
+ _minwidth=w;_minheight=h\r
+ 'Get window style\r
+ Local tmpWStyle% = GetWindowLongW( _hwnd, GWL_STYLE )\r
+ 'Update size border\r
+ If (_maxwidth = _minwidth And _maxheight = _minheight) Then tmpWStyle:&~WS_SIZEBOX ElseIf (style&WINDOW_RESIZABLE) Then tmpWStyle:|WS_SIZEBOX\r
+ 'Set new window style if necessary\r
+ If tmpWStyle <> GetWindowLongW( _hwnd, GWL_STYLE ) Then\r
+ SetWindowLongW( _hwnd, GWL_STYLE, tmpWStyle )\r
+ Rethink()\r
+ SetWindowPos( _hwnd, Null, 0, 0, 0, 0, SWP_DRAWFRAME|SWP_FRAMECHANGED|SWP_NOACTIVATE|SWP_NOMOVE|SWP_NOOWNERZORDER|SWP_NOZORDER|SWP_NOSIZE )\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method SetMaximumSize(w,h)\r
+ 'Set maximum size for current window style\r
+ _maxwidth=w;_maxheight=h\r
+ 'Get window style\r
+ Local tmpWStyle% = GetWindowLongW( _hwnd, GWL_STYLE )&~WS_MAXIMIZEBOX\r
+ 'Update size border\r
+ If (_maxwidth = _minwidth And _maxheight = _minheight) Then tmpWStyle:&~WS_SIZEBOX ElseIf (style&WINDOW_RESIZABLE) Then tmpWStyle:|WS_SIZEBOX\r
+ 'Set new window style if necessary\r
+ If tmpWStyle <> GetWindowLongW( _hwnd, GWL_STYLE ) Then\r
+ SetWindowLongW( _hwnd, GWL_STYLE, tmpWStyle )\r
+ Rethink()\r
+ SetWindowPos( _hwnd, Null, 0, 0, 0, 0, SWP_DRAWFRAME|SWP_FRAMECHANGED|SWP_NOACTIVATE|SWP_NOMOVE|SWP_NOOWNERZORDER|SWP_NOZORDER|SWP_NOSIZE )\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method GetMenu:TGadget()\r
+ If Not _menu Then\r
+ _menu = New TWindowsMenu.Create(Null,0,"")\r
+ _menu._setParent Self\r
+ EndIf\r
+ Return _menu\r
+ EndMethod\r
+\r
+ Method UpdateMenu()\r
+ \r
+ Local hmenu, oldMenu\r
+ If _menu\r
+ _menu.FreeKids\r
+ _menu.Open\r
+ hmenu=_menu._hmenu\r
+ EndIf\r
+ \r
+ oldMenu = GetMenu_( _hwnd )\r
+ SetMenu _hwnd,hmenu\r
+ DrawMenuBar _hwnd\r
+ DestroyMenu oldMenu\r
+ \r
+ EndMethod\r
+ \r
+ Field _statustext$\r
+ \r
+ Method GetStatusText$()\r
+ If _status\r
+ Return _statustext\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method SetStatusText(Text$)\r
+ If _status\r
+ _statustext = Text\r
+ If (style&WINDOW_RESIZABLE) Then Text:+" " 'Cludge for size handle obfuscation\r
+ Local tmpWString:Short Ptr = Text.ToWString()\r
+ SendMessageW _status,WM_SETTEXT,0,Int(tmpWString)\r
+ MemFree tmpWString\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Field popupextra:Object\r
+ \r
+ Method PopupMenu(menu:TGadget,extra:Object)\r
+ Local pt[2], wmenu:TWindowsMenu = TWindowsMenu(menu), tmpLink:TLink\r
+ If wmenu\r
+ \r
+ GetCursorPos_ pt\r
+ popupextra = extra\r
+ wmenu.Open(True)\r
+ \r
+ Local hmenu:Int = TrackPopupMenu( wmenu._hmenu,TPM_LEFTALIGN|TPM_TOPALIGN|TPM_RETURNCMD|TPM_NONOTIFY,pt[0],pt[1],0,_hwnd,0 )\r
+ If hmenu Then HandleMenuEvent( WM_COMMAND, hmenu )\r
+ \r
+ wmenu.Close()\r
+ popupextra = Null\r
+ \r
+ EndIf\r
+ EndMethod\r
+\r
+ Function EnumChildProc(hwnd,lp) "win32"\r
+ Local winfo:WINDOWINFO = New WINDOWINFO\r
+ winfo.cbSize=SizeOf winfo\r
+ GetWindowInfo hwnd,winfo\r
+ If winfo.dwStyle&WS_TABSTOP\r
+ _firsttab=hwnd\r
+ Else\r
+ EnumChildWindows hwnd,EnumChildProc,0\r
+ EndIf \r
+ If _firsttab Return 0\r
+ Return 1\r
+ EndFunction\r
+\r
+ Global _firsttab\r
+\r
+ Method Activate(cmd)\r
+ Select cmd\r
+ Case ACTIVATE_FOCUS\r
+ _firsttab=0\r
+ EnumChildWindows _hwnd,EnumChildProc,0\r
+ If Not _firsttab _firsttab=_hwnd\r
+ SetFocus _firsttab\r
+ Case ACTIVATE_MINIMIZE\r
+ ShowWindow _hwnd,SW_MINIMIZE\r
+ Case ACTIVATE_MAXIMIZE\r
+ ShowWindow _hwnd,SW_MAXIMIZE\r
+ Case ACTIVATE_RESTORE\r
+ ShowWindow _hwnd,SW_RESTORE\r
+ Case ACTIVATE_REDRAW\r
+ RefreshLook()\r
+ Return RedrawWindow( _hwnd, Null, Null, RDW_INVALIDATE | RDW_UPDATENOW | RDW_ERASE | RDW_FRAME | RDW_ALLCHILDREN )\r
+ End Select\r
+ EndMethod\r
+ \r
+ Method OnCommand(msg,wp)\r
+ If wp>100 Then HandleMenuEvent(msg,wp)\r
+ EndMethod\r
+ \r
+ Method HandleMenuEvent( msg, wp )\r
+ \r
+ Local tmpMenuSource:TWindowsMenu = TWindowsMenu.GetMenuFromKey(wp), tmpMenuID\r
+ If tmpMenuSource Then tmpMenuID = tmpMenuSource._tag\r
+ \r
+ Local tmpPopupExtra:Object = popupextra\r
+ popupextra = Null\r
+ \r
+ MaxGUI.MaxGUI.PostGuiEvent EVENT_MENUACTION,tmpMenuSource,tmpMenuID,0,0,0,tmpPopupExtra\r
+ \r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Local x,y,w,h\r
+ Local move,size\r
+ Local Rect[4]\r
+ Local winrect[4]\r
+ \r
+ Select msg\r
+ \r
+ Case WM_ERASEBKGND\r
+ If BgBrush() Then\r
+ Local Rect[4]\r
+ If Not GetUpdateRect( hwnd, Rect, False ) Then GetClipBox( wp, Rect )\r
+ FillRect( wp, Rect, BgBrush() )\r
+ Return 1\r
+ EndIf\r
+ \r
+ Case WM_SIZE\r
+ \r
+ If (hwnd = _hwnd) And (wp <> SIZE_MINIMIZED) Then\r
+ \r
+ If _status Then SendMessageW _status,WM_SIZE,0,0\r
+ \r
+ If (style & WINDOW_CLIENTCOORDS) Then\r
+ GetClientRect _hwnd,Rect\r
+ w=Rect[2]\r
+ h=Rect[3]\r
+ AdjustWindowRectEx(Rect,GetWindowLongW(_hwnd, GWL_STYLE),_hmenu,GetWindowLongW(_hwnd, GWL_EXSTYLE))\r
+ x=-Rect[0]\r
+ y=-Rect[1]\r
+ GetWindowRect _hwnd,Rect\r
+ x:+Rect[0]\r
+ y:+Rect[1]\r
+ If _status Then\r
+ GetWindowRect _status,Rect\r
+ h:-(Rect[3]-Rect[1])\r
+ EndIf\r
+ x:+_clientX;y:+_clientY\r
+ w:-_clientX;h:-_clientY\r
+ Else\r
+ GetWindowRect(_hwnd,Rect)\r
+ x=Rect[0];y=Rect[1]\r
+ w=Rect[2]-Rect[0]\r
+ h=Rect[3]-Rect[1] \r
+ EndIf \r
+ \r
+ If x<>xpos Or y<>ypos Then move = True\r
+ If w<>width Or h<>height Then size = True\r
+ \r
+ SetRect x,y,w,h\r
+ \r
+ If size Then RethinkClient()\r
+ \r
+ If move PostGuiEvent EVENT_WINDOWMOVE,0,0,x,y\r
+ If size PostGuiEvent EVENT_WINDOWSIZE,0,0,w,h\r
+ \r
+ EndIf\r
+ \r
+ Case WM_MOVE\r
+ If (hwnd = _hwnd) And Not (IsZoomed(hwnd) Or IsIconic(hwnd)) Then\r
+ \r
+ If (style & WINDOW_CLIENTCOORDS) Then\r
+ GetClientRect _hwnd,Rect\r
+ w=Rect[2]\r
+ h=Rect[3]\r
+ AdjustWindowRectEx(Rect,GetWindowLongW(_hwnd, GWL_STYLE),_hmenu,GetWindowLongW(_hwnd, GWL_EXSTYLE))\r
+ x=-Rect[0]\r
+ y=-Rect[1]\r
+ GetWindowRect _hwnd,Rect\r
+ x:+Rect[0]+_clientX\r
+ y:+Rect[1]+_clientY\r
+ Else\r
+ GetWindowRect(_hwnd,Rect)\r
+ x=Rect[0];y=Rect[1]\r
+ w=Rect[2]-Rect[0]\r
+ h=Rect[3]-Rect[1] \r
+ EndIf \r
+ \r
+ If x<>xpos Or y<>ypos Then\r
+ SetRect x,y,width,height\r
+ PostGuiEvent EVENT_WINDOWMOVE,0,0,x,y\r
+ EndIf\r
+ \r
+ EndIf\r
+ \r
+ Case WM_GETMINMAXINFO\r
+ If hwnd = _hwnd And lp Then\r
+ Local minmax:Int Ptr = Int Ptr(lp), tmpZero% = 0\r
+ \r
+ minmax[6]=_minwidth\r
+ minmax[7]=_minheight\r
+ ConvertToContainerDimensions(tmpZero,tmpZero,minmax[6],minmax[7])\r
+ \r
+ If (_maxwidth >= _minwidth) And (_maxheight >= _minheight) Then\r
+ minmax[8]=_maxwidth\r
+ minmax[9]=_maxheight\r
+ ConvertToContainerDimensions(tmpZero,tmpZero,minmax[8],minmax[9])\r
+ EndIf\r
+ \r
+ EndIf\r
+ \r
+ Case WM_ACTIVATE\r
+ If (wp = WA_ACTIVE) Or (wp = WA_CLICKACTIVE) Then\r
+ TWindowsGUIDriver._ActiveWindow = Self\r
+ PostGuiEvent EVENT_WINDOWACTIVATE\r
+ EndIf\r
+ \r
+ Case WM_COMMAND\r
+ If wp>100 Then HandleMenuEvent(wp,msg)\r
+\r
+ Case WM_CLOSE\r
+ PostGuiEvent EVENT_WINDOWCLOSE\r
+ Return 1\r
+ \r
+ Case WM_DROPFILES\r
+ Local hdrop,pt[2],path$\r
+ Local pbuffer:Short[MAX_PATH]\r
+ Local i,n,l\r
+ DragQueryPoint wp,pt\r
+ n=DragQueryFileW(wp,$ffffffff,Null,0);\r
+ For i=0 Until n\r
+ l=DragQueryFileW(wp,i,pbuffer,MAX_PATH)\r
+ path=String.FromShorts(pbuffer,l)\r
+ PostGuiEvent EVENT_WINDOWACCEPT,0,0,pt[0],pt[1],path\r
+ Next\r
+ DragFinish wp\r
+ \r
+ End Select\r
+ \r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ \r
+ EndMethod\r
+ \r
+ Method DoLayout()\r
+ 'Don't do anything!\r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ 'Windows shouldn't have tool-tips!\r
+ EndMethod\r
+ \r
+ Method SetSensitivity(flags)\r
+ 'Problems with resizing/moving sensitive windows.\r
+ Super.SetSensitivity(flags&~SENSITIZE_MOUSE)\r
+ 'Easy to create an active panel in client area as a work around.\r
+ EndMethod\r
+ \r
+ Method SetPixmap(pPixmap:TPixmap, pFlags)\r
+ If Not (pFlags & GADGETPIXMAP_ICON) Then Return False\r
+ If _iconBitmap Then DestroyIcon(_iconBitmap);_iconBitmap = 0\r
+ If pPixmap Then _iconBitmap = TWindowsGraphic.IconFromPixmap32( pPixmap ) \r
+ SendMessageW (_hwnd, WM_SETICON, 0, _iconBitmap)\r
+ SendMessageW (_hwnd, WM_SETICON, 1, _iconBitmap)\r
+ Return True\r
+ EndMethod\r
+ \r
+ ' Needed otherwise SetEnabled() locks if modal child window is opened and parent is disabled.\r
+ Method isControl()\r
+ Return False\r
+ EndMethod\r
+ \r
+ Method ConvertToContainerDimensions%( pX Var, pY Var, pW Var , pH Var )\r
+ \r
+ If Not (style & WINDOW_CLIENTCOORDS) Then Return 0\r
+ \r
+ Local Rect[4], menu = GetMenu_(_hwnd)\r
+ \r
+ If menu Then menu = True\r
+ If _status Then GetWindowRect _status,Rect;pH:+(Rect[3]-Rect[1])\r
+ pW:+_clientX;pH:+_clientY;pX:-_clientX;pY:-_clientY\r
+ \r
+ Rect = [pX,pY,pX+pW,pY+pH]\r
+ AdjustWindowRectEx Rect,GetWindowLongW(_hwnd, GWL_STYLE),menu,GetWindowLongW(_hwnd, GWL_EXSTYLE)\r
+ \r
+ pX = Rect[0];pY = Rect[1];pW = Rect[2]-Rect[0];pH = Rect[3]-Rect[1]\r
+ \r
+ Return 1\r
+ \r
+ EndMethod\r
+ \r
+ Method FlushBrushes(pRecurse:Int = True)\r
+ Super.FlushBrushes()\r
+ If Not pRecurse Then Return\r
+ For Local tmpGadget:TWindowsGadget = EachIn kids\r
+ tmpGadget.FlushBrushes()\r
+ Next\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsButton Extends TWindowsGadget\r
+ \r
+ Field _buttonImageList[] = [-1,0,0,0,0,0], _strButtonText$, _mouseoverbutton\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="")\r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ Self.style = style\r
+ wstyle=WS_CHILD|WS_TABSTOP|WS_CLIPSIBLINGS|BS_MULTILINE \r
+ Select style&7\r
+ Case 0 wstyle:|BS_PUSHBUTTON;style = BUTTON_PUSH\r
+ Case BUTTON_CHECKBOX wstyle:|BS_3STATE;If (style&BUTTON_PUSH) Then wstyle:|BS_PUSHLIKE\r
+ Case BUTTON_RADIO wstyle:|BS_AUTORADIOBUTTON;If (style&BUTTON_PUSH) Then wstyle:|BS_PUSHLIKE\r
+ Case BUTTON_OK wstyle:|BS_DEFPUSHBUTTON;hotkey=IDOK\r
+ Case BUTTON_CANCEL wstyle:|BS_PUSHBUTTON;hotkey=IDCANCEL\r
+ End Select\r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"BUTTON","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null) \r
+ Register GADGET_BUTTON,hwnd\r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method SetTextColor(r,g,b)\r
+ If Not (style&7) Then\r
+ SetWindowLongW(_hwnd,GWL_STYLE,GetWindowLongW(_hwnd,GWL_STYLE)|BS_OWNERDRAW)\r
+ If Not _hTheme Then _hTheme = TWindowsGUIDriver.GetThemeHandle( _hwnd, "Button" )\r
+ ElseIf Not (style&BUTTON_PUSH) And ((style&7=BUTTON_CHECKBOX) Or (style&7=BUTTON_RADIO))\r
+ If SetWindowThemeW Then SetWindowThemeW(_hwnd,_wstrSpace,_wstrSpace)\r
+ EndIf\r
+ Super.SetTextColor(r,g,b)\r
+ EndMethod\r
+\r
+ Method SetColor(r,g,b)\r
+ If Not (style&7) Then\r
+ SetWindowLongW(_hwnd,GWL_STYLE,GetWindowLongW(_hwnd,GWL_STYLE)|BS_OWNERDRAW)\r
+ If Not _hTheme Then _hTheme = TWindowsGUIDriver.GetThemeHandle( _hwnd, "Button" )\r
+ EndIf\r
+ Super.SetColor(r,g,b)\r
+ EndMethod\r
+\r
+ Method RemoveColor()\r
+ If Not (style&7) Then\r
+ SetWindowLongW(_hwnd,GWL_STYLE,GetWindowLongW(_hwnd,GWL_STYLE)&~BS_OWNERDRAW)\r
+ _hTheme=0\r
+ EndIf\r
+ Super.RemoveColor()\r
+ EndMethod\r
+ \r
+ Method State()\r
+ Local t=Super.State()\r
+ Select SendMessageW( _hwnd,BM_GETCHECK,0,0 )\r
+ Case BST_CHECKED;t:|STATE_SELECTED\r
+ Case BST_INDETERMINATE;t:|STATE_INDETERMINATE\r
+ EndSelect\r
+ Return t\r
+ EndMethod\r
+\r
+ Method SetSelected(bool)\r
+ Local state = BST_UNCHECKED\r
+ If bool Then\r
+ If (style&7 = BUTTON_CHECKBOX) And (bool = CHECK_INDETERMINATE) Then\r
+ state = BST_INDETERMINATE\r
+ Else\r
+ state = BST_CHECKED\r
+ EndIf\r
+ EndIf\r
+ SendMessageW _hwnd,BM_SETCHECK,state,0\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ Case WM_THEMECHANGED\r
+ If _hTheme Then\r
+ TWindowsGUIDriver.CloseThemeHandle(_hTheme)\r
+ _hTheme = TWindowsGUIDriver.GetThemeHandle(_hwnd,"BUTTON")\r
+ EndIf\r
+ Case WM_LBUTTONDBLCLK\r
+ PostMessageW(_hwnd, WM_LBUTTONDOWN, wp, lp)\r
+ Case WM_MOUSEMOVE\r
+ If Not _mouseoverbutton Then\r
+ _mouseoverbutton = True\r
+ InvalidateRect(_hwnd,Null,False)\r
+ Local tmpTrackMouseEvent:Int[] = [ 16, $2, hwnd, 0 ] 'TME_LEAVE: $2\r
+ _TrackMouseEvent( tmpTrackMouseEvent )\r
+ EndIf\r
+ Case WM_MOUSELEAVE\r
+ If _mouseoverbutton Then\r
+ _mouseoverbutton = False\r
+ InvalidateRect(_hwnd,Null,False)\r
+ EndIf\r
+ Case WM_ERASEBKGND\r
+ Return 1\r
+ EndSelect\r
+ \r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ \r
+ EndMethod\r
+ \r
+ Method OnDrawItem(pDrawItemStruct:DRAWITEMSTRUCT)\r
+ \r
+ Local tmpDc = pDrawItemStruct.hDc, txtWidth%, txtHeight%\r
+ Local tmpDcState = SaveDC(tmpDC)\r
+ \r
+ ' button state\r
+ Local tmpIsPressed = (pDrawItemStruct.ItemState & ODS_SELECTED)\r
+ Local tmpIsFocused = (pDrawItemStruct.ItemState & ODS_FOCUS)\r
+ Local tmpIsDisabled = (pDrawItemStruct.ItemState & ODS_DISABLED)\r
+ Local tmpDrawFocusRect = Not (pDrawItemStruct.ItemState & ODS_NOFOCUSRECT)\r
+ \r
+ Local itemRect:Int Ptr = Int Ptr Varptr pDrawItemStruct.rcItem_left, txtRect:Int[4], clientRect:Int[4]\r
+ \r
+ Local tmpBgMode = SetBkMode(tmpDc, TRANSPARENT)\r
+ \r
+ ' Prepare draw... paint button background\r
+ \r
+ If _hTheme Then\r
+ \r
+ Local tmpState = PBS_NORMAL\r
+ If tmpIsDisabled Then\r
+ tmpState = PBS_DISABLED\r
+ ElseIf tmpIsPressed Then\r
+ tmpState = PBS_PRESSED\r
+ ElseIf _mouseoverbutton Then\r
+ tmpState = PBS_HOT\r
+ ElseIf tmpIsFocused Then\r
+ tmpState = PBS_DEFAULTED\r
+ EndIf\r
+ \r
+ If IsThemeBackgroundPartiallyTransparent(_hTheme, BP_PUSHBUTTON, tmpState) Then\r
+ DrawThemeParentBackground( _hwnd, tmpDc, itemRect )\r
+ EndIf\r
+ DrawThemeBackground(_hTheme, tmpDc, BP_PUSHBUTTON, tmpState, itemRect, Null)\r
+ GetThemeBackgroundContentRect(_hTheme, tmpDc, BP_PUSHBUTTON, tmpState, itemRect, clientRect)\r
+ \r
+ Else\r
+ \r
+ clientRect = [itemRect[0], itemRect[1], itemRect[2], itemRect[3]]\r
+ InflateRect(clientRect, -GetSystemMetrics(SM_CXEDGE), -GetSystemMetrics(SM_CYEDGE))\r
+ \r
+ If tmpIsFocused Then\r
+ \r
+ Local tmpBr = CreateSolidBrush($000000)\r
+ FrameRect(tmpDc, itemRect , tmpBr)\r
+ InflateRect(itemRect, -1, -1)\r
+ DeleteObject(tmpBr)\r
+ \r
+ EndIf\r
+ \r
+ Local crColor\r
+ If BgColor() < 0 Then crColor = GetSysColor(COLOR_BTNFACE) Else crColor = BgColor()\r
+ \r
+ Local brBackground = CreateSolidBrush(crColor)\r
+ \r
+ FillRect(tmpDc, itemRect, brBackground)\r
+ \r
+ DeleteObject(brBackground)\r
+ \r
+ ' Draw pressed button\r
+ If tmpIsPressed\r
+ \r
+ Local brBtnShadow = CreateSolidBrush(GetSysColor(COLOR_BTNSHADOW))\r
+ FrameRect(tmpDc, itemRect, brBtnShadow)\r
+ DeleteObject(brBtnShadow)\r
+ \r
+ OffsetRect( clientRect, 1, 1 )\r
+ \r
+ Else ' ...Else draw non pressed button\r
+ \r
+ Local tmpUState = DFCS_BUTTONPUSH\r
+ If _mouseoverbutton Then tmpUState :| DFCS_HOT\r
+ If tmpIsPressed Then tmpUState :| DFCS_PUSHED\r
+ \r
+ DrawFrameControl(tmpDc, itemRect, DFC_BUTTON, tmpUState)\r
+ \r
+ EndIf\r
+ \r
+ EndIf\r
+ \r
+ If BgColor() > -1 Then\r
+ Local brBackground = CreateSolidBrush(BgColor())\r
+ FillRect(tmpDc, clientRect, brBackground)\r
+ DeleteObject(brBackground)\r
+ EndIf\r
+ \r
+ txtRect = clientRect[..]\r
+ \r
+ clientRect[RECT_RIGHT]:-clientRect[RECT_LEFT]\r
+ clientRect[RECT_BOTTOM]:-clientRect[RECT_TOP]\r
+ \r
+ ' Read the button's title\r
+ Local tmpText$ = Super.GetText()\r
+ \r
+ ' Draw the icon\r
+ 'DrawTheIcon(GetDlgItem(hDlg, IDC_OWNERDRAW_BTN), &dc, bHasTitle, &lpDIS.rcItem, &captionRect, bIsPressed, bIsDisabled)\r
+ \r
+ ' Write the button title (if any)\r
+ If tmpText Then\r
+ \r
+ Local tmpFlags = DT_CENTER|DT_WORDBREAK\r
+ \r
+ DrawTextW( tmpDc, tmpText, -1, txtRect, DT_CALCRECT|tmpFlags )\r
+ \r
+ txtWidth = txtRect[RECT_RIGHT]-txtRect[RECT_LEFT]\r
+ txtHeight = txtRect[RECT_BOTTOM]-txtRect[RECT_TOP]\r
+ \r
+ txtRect[RECT_LEFT] = clientRect[RECT_LEFT] + (clientRect[RECT_RIGHT] - txtWidth)/2\r
+ txtRect[RECT_TOP] = clientRect[RECT_TOP] + (clientRect[RECT_BOTTOM] - txtHeight)/2\r
+ txtRect[RECT_RIGHT] = txtRect[RECT_LEFT] + txtWidth\r
+ txtRect[RECT_BOTTOM] = txtRect[RECT_TOP] + txtHeight\r
+ \r
+ Local tmpTextColor\r
+ If tmpIsDisabled Then\r
+ tmpTextColor = GetSysColor(COLOR_GRAYTEXT)\r
+ Else\r
+ If FgColor() < 0 Then tmpTextColor = GetSysColor(COLOR_BTNTEXT) Else tmpTextColor = FgColor()\r
+ EndIf\r
+ tmpTextColor = SetTextColor_(tmpDc,tmpTextColor)\r
+ \r
+ DrawTextW( tmpDc, tmpText, -1, txtRect, tmpFlags )\r
+ \r
+ SetTextColor_(tmpDc,tmpTextColor)\r
+ \r
+ EndIf\r
+ \r
+ RestoreDC(tmpDc,tmpDcState)\r
+ \r
+ ' Draw the focus rect\r
+ If tmpIsFocused And tmpDrawFocusRect Then\r
+ Local focusRect:Int[4]\r
+ CopyRect(focusRect, itemRect)\r
+ InflateRect(focusRect, -3, -3)\r
+ SetMapMode(tmpDc, MM_TEXT)\r
+ DrawFocusRect(tmpDc, focusRect)\r
+ EndIf\r
+ \r
+ Return True\r
+ EndMethod\r
+ \r
+ Method OnCommand(msg,wp)\r
+ Select wp Shr 16\r
+ Case BN_CLICKED\r
+ Select (style&7)\r
+ Case BUTTON_CHECKBOX\r
+ Select State()&STATE_INDETERMINATE\r
+ Case 0, STATE_INDETERMINATE\r
+ SetSelected(True)\r
+ Case STATE_SELECTED\r
+ SetSelected(False)\r
+ EndSelect\r
+ EndSelect\r
+ \r
+ PostGuiEvent EVENT_GADGETACTION,ButtonState(Self)\r
+ \r
+ 'Fix so that tooltips reappear on Windows XP\r
+ Local tmpTooltip$ = GetTooltip()\r
+ If tmpTooltip Then SetTooltip("");SetTooltip(tmpTooltip)\r
+ \r
+ EndSelect\r
+ EndMethod \r
+ \r
+ Method SetPixmap(pixmap:TPixmap,pFlags)\r
+ \r
+ Local tmpWindowStyle = GetWindowLongW(_hwnd,GWL_STYLE)\r
+ \r
+ If (pFlags & GADGETPIXMAP_ICON) And (((style&BUTTON_PUSH)=BUTTON_PUSH) Or (style = BUTTON_CANCEL)) Then\r
+ \r
+ 'To remove an image from a button, a handle-list of -1 should be passed.\r
+ If _buttonImageList[0] >= 0 Then ImageList_Destroy(_buttonImageList[0]);_buttonImageList[0] = -1\r
+ If pixmap Then _buttonImageList[0] = BuildImageList( pixmap )\r
+ \r
+ If (pFlags & GADGETPIXMAP_NOTEXT) Then\r
+ _buttonImageList[5] = BUTTON_IMAGELIST_ALIGN_CENTER\r
+ Else\r
+ _buttonImageList[5] = BUTTON_IMAGELIST_ALIGN_LEFT\r
+ EndIf\r
+ \r
+ 'If running Windows XP/Vista, let's use BCM_SETIMAGELIST\r
+\r
+ If Not SendMessageW (_hwnd, BCM_SETIMAGELIST, 0, Int Byte Ptr _buttonImageList) Then\r
+ 'Otherwise, if this fails we should use BM_SETIMAGE.\r
+ \r
+ If _buttonImageList[0] >= 0 Then ImageList_Destroy(_buttonImageList[0]);_buttonImageList[0] = -1\r
+ \r
+ If _iconBitmap Then DeleteObject(_iconBitmap);_iconBitmap = 0\r
+ If pixmap Then _iconBitmap = TWindowsGraphic.BitmapFromPixmap( pixmap, True )\r
+ \r
+ SendMessageW (_hwnd, BM_SETIMAGE, IMAGE_BITMAP, _iconBitmap)\r
+ \r
+ EndIf\r
+ \r
+ 'Show the text if there isn't a pixmap or if we haven't specified GADGETPIXMAP_NOTEXT.\r
+ If (Not pixmap) Or Not(pFlags & GADGETPIXMAP_NOTEXT) Then\r
+ tmpWindowStyle:&(~BS_BITMAP)\r
+ \r
+ 'Text isn't hidden on XP image buttons regardless of whether BS_BITMAP is set\r
+ 'so we have to hack this in - they must have fixed it on Vista though as it works fine there.\r
+ \r
+ Super.SetText( GetText() )\r
+ Else\r
+ tmpWindowStyle:|BS_BITMAP\r
+ \r
+ 'Text isn't hidden on XP image buttons regardless of whether BS_BITMAP is set\r
+ 'so we have to hack this in - they must have fixed it on Vista though as it works fine there.\r
+ \r
+ Super.SetText( "" )\r
+ EndIf\r
+ \r
+ SetWindowLongW _hwnd,GWL_STYLE,tmpWindowStyle\r
+ \r
+ InvalidateRect _hwnd, Null, False\r
+ \r
+ Return True\r
+ \r
+ EndIf\r
+ \r
+ EndMethod\r
+ \r
+ Method SetText(pText$)\r
+ Local oldText$ = _strButtonText\r
+ _strButtonText = pText\r
+ If (_buttonImageList[0] < 0 And Not _iconBitmap) Or (oldText = Super.GetText()) Then Super.SetText(pText)\r
+ EndMethod\r
+ \r
+ Method GetText$()\r
+ Return _strButtonText\r
+ EndMethod\r
+ \r
+ Method Free()\r
+ If _buttonImageList[0] >= 0 Then ImageList_Destroy(_buttonImageList[0])\r
+ If _iconBitmap Then DestroyIcon( _iconBitmap );_iconBitmap = 0\r
+ _buttonImageList = Null\r
+ Super.Free()\r
+ EndMethod\r
+ \r
+ Function BuildImageList(pixmap:TPixmap)\r
+ Local bitmap,imagelist,mask\r
+ If TWindowsGUIDriver.CheckCommonControlVersion() And (Pixmap.format=PF_RGBA8888 Or pixmap.format=PF_BGRA8888)\r
+ imagelist=ImageList_Create(pixmap.width,pixmap.height,ILC_COLOR32,0,1)\r
+ If imagelist\r
+ bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, True)\r
+ ImageList_Add(imagelist,bitmap,0)\r
+ EndIf\r
+ EndIf\r
+ If imagelist=0\r
+ bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, False)\r
+ mask=TWindowsGraphic.BitmapMaskFromPixmap(pixmap)\r
+ imagelist=ImageList_Create(pixmap.width,pixmap.height,ILC_COLOR24|ILC_MASK,0,1)\r
+ ImageList_Add(imagelist,bitmap,mask)\r
+ DeleteObject(mask)\r
+ EndIf\r
+ DeleteObject(bitmap)\r
+ Return imagelist\r
+ EndFunction\r
+ \r
+ Method Class()\r
+ Return GADGET_BUTTON\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsTextField Extends TWindowsGadget\r
+\r
+ Field _busy\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ Self.style = style\r
+ xstyle=WS_EX_CLIENTEDGE\r
+ wstyle=WS_CHILD|WS_TABSTOP|ES_AUTOHSCROLL|WS_CLIPSIBLINGS\r
+ If style&TEXTFIELD_PASSWORD Then wstyle:|ES_PASSWORD \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"EDIT","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ 'SendMessageW hwnd,WM_SETFONT,TWindowsGUIDriver.GDIFont.handle,1\r
+ Register GADGET_TEXTFIELD,hwnd\r
+ SetColor(255,255,255)\r
+ Return Self \r
+ EndMethod\r
+\r
+ Method SetText(Text$)\r
+ Local p0,p1\r
+ _busy:+1\r
+ SendMessageW _hwnd,EM_GETSEL,Int Byte Ptr Varptr p0,Int Byte Ptr Varptr p1\r
+ Super.SetText(Text)\r
+ SendMessageW _hwnd,EM_SETSEL,p0,p1\r
+ _busy:-1\r
+ EndMethod\r
+ \r
+ Method Activate(cmd)\r
+ Select cmd\r
+ Case ACTIVATE_CUT \r
+ SendMessageW _hwnd,WM_CUT,0,0\r
+ Case ACTIVATE_COPY \r
+ SendMessageW _hwnd,WM_COPY,0,0\r
+ Case ACTIVATE_PASTE\r
+ SendMessageW _hwnd,WM_PASTE,0,0\r
+ Case ACTIVATE_FOCUS\r
+ SendMessageW _hwnd,EM_SETSEL,0,-1\r
+ End Select\r
+ Return Super.Activate(cmd)\r
+ EndMethod\r
+ \r
+ Method OnCommand(msg,wp)\r
+ If Not _busy\r
+ Select (wp Shr 16)\r
+ Case EN_UPDATE\r
+ PostGuiEvent EVENT_GADGETACTION\r
+ Case EN_KILLFOCUS\r
+ SendMessageW _hwnd,EM_SETSEL,0,0\r
+ End Select\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Local event:TEvent\r
+ Select msg\r
+ Case WM_ERASEBKGND\r
+ Return 1\r
+ Case WM_KEYDOWN\r
+ If eventfilter<>Null\r
+ event=CreateEvent(EVENT_KEYDOWN,Self,wp,keymods())\r
+ If Not eventfilter(event,context) Return True\r
+ EndIf\r
+ Case WM_CHAR\r
+ If eventfilter<>Null\r
+ event=CreateEvent(EVENT_KEYCHAR,Self,wp,keymods())\r
+ If Not eventfilter(event,context) Return True\r
+ EndIf\r
+ Case WM_KILLFOCUS\r
+ PostGuiEvent EVENT_GADGETLOSTFOCUS\r
+ End Select\r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_TEXTFIELD\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsTextArea Extends TWindowsGadget\r
+ \r
+ Global _ClassName:String = Null 'See InitializeLibrary().\r
+ \r
+ Global _pagemargin# = 0.5 'Page margin for print-out in inches\r
+ \r
+ Field _locked\r
+\r
+ Field cr1:CHARRANGE=New CHARRANGE\r
+ Field cr2:CHARRANGE=New CHARRANGE\r
+ Field cf:CHARFORMATW=New CHARFORMATW\r
+\r
+ Field ole:IRichEditOLE\r
+ Field idoc:ITextDocument\r
+ Field busy,readonly\r
+ \r
+ Field IID_ITextDocument:GUID = New GUID\r
+ \r
+ Function _InitializeLibrary()\r
+ \r
+ If Not _ClassName Then\r
+ \r
+ 'Load RichEdit DLL\r
+ If Not LoadLibraryW("msftedit.dll") Then\r
+ If LoadLibraryW("riched20.dll") _ClassName = "RichEdit20W"\r
+ Else\r
+ _ClassName = "RICHEDIT50W"\r
+ EndIf\r
+ \r
+ EndIf\r
+ \r
+ EndFunction\r
+ \r
+ Method New()\r
+ _InitializeLibrary()\r
+ EndMethod\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ Local res\r
+ \r
+ xstyle=WS_EX_CLIENTEDGE\r
+ wstyle=WS_CHILD|WS_VSCROLL|WS_CLIPSIBLINGS\r
+ wstyle:|ES_MULTILINE|ES_NOOLEDRAGDROP|ES_NOHIDESEL|ES_LEFT\r
+ If Not (style&TEXTAREA_WORDWRAP) wstyle:|WS_HSCROLL|ES_AUTOHSCROLL\r
+' If (style&TEXTAREA_READONLY) wstyle:|ES_READONLY \r
+ If (style&TEXTAREA_READONLY) readonly=True\r
+ \r
+ Self.style = style\r
+ \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ \r
+ 'RichText control should be made have dimensions of 1x1 pixels to fix Windows XP vertical scrollbar drawing bug.\r
+ hwnd=CreateWindowExW(xstyle,_ClassName,"",wstyle,0,0,1,1,parent,hotkey,GetModuleHandleW(Null),Null)\r
+\r
+ SendMessageW hwnd,EM_SETLIMITTEXT,4*1024*1024,0\r
+ SendMessageW hwnd,EM_SETEVENTMASK,0,ENM_CHANGE|ENM_MOUSEEVENTS|ENM_SELCHANGE|ENM_KEYEVENTS \r
+ SendMessageW hwnd,EM_SETUNDOLIMIT,0,0\r
+ \r
+ SendMessageW hwnd,EM_GETOLEINTERFACE,0,Int Byte Ptr Varptr ole\r
+ res=IIDFromString(ITextDocument_UUID,IID_ITextDocument)\r
+ \r
+ res=ole.QueryInterface(IID_ITextDocument,Varptr idoc) \r
+\r
+ Register GADGET_TEXTAREA,hwnd \r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method Free()\r
+ If ole Then ole.Release_\r
+ If idoc Then idoc.Release_\r
+ Super.Free()\r
+ EndMethod\r
+ \r
+ Method Activate(cmd)\r
+ Select cmd\r
+ Case ACTIVATE_CUT \r
+ SendMessageW _hwnd,WM_CUT,0,0\r
+ Case ACTIVATE_COPY \r
+ SendMessageW _hwnd,WM_COPY,0,0\r
+ SetFocus _hwnd\r
+ Case ACTIVATE_PASTE\r
+ DoPaste \r
+ Case ACTIVATE_PRINT\r
+ DoPrint\r
+ Default\r
+ Return Super.Activate(cmd)\r
+ End Select\r
+ EndMethod\r
+ \r
+ Method DoPaste()\r
+ Local h,handle,n\r
+ Local w:Short Ptr,cp:Short Ptr\r
+ Local tp:Byte Ptr,bp:Byte Ptr\r
+ \r
+ If OpenClipboard(_hwnd)\r
+ If IsClipboardFormatAvailable(CF_UNICODETEXT)\r
+ handle=GetClipboardData(CF_UNICODETEXT)\r
+ n=GlobalSize(handle)\r
+ w=Short Ptr GlobalLock(handle)\r
+ h=GlobalAlloc(GMEM_MOVEABLE,n)\r
+ cp=Short Ptr GlobalLock(h)\r
+ memcpy_(cp,w,n)\r
+ If cp[n/2-2]=10 Then cp[n/2-2]=13\r
+ GlobalUnlock h \r
+ GlobalUnlock handle\r
+ If h\r
+ EmptyClipboard\r
+ SetClipboardData CF_UNICODETEXT,h\r
+ EndIf\r
+ ElseIf IsClipboardFormatAvailable(CF_OEMTEXT)\r
+ handle=GetClipboardData(CF_OEMTEXT)\r
+ n=GlobalSize(handle) \r
+ tp=Byte Ptr GlobalLock(handle) \r
+ h=GlobalAlloc(GMEM_MOVEABLE,n)\r
+ bp=Byte Ptr GlobalLock(h)\r
+ memcpy_(bp,tp,n)\r
+ If bp[n-2]=10 Then bp[n-2]=13\r
+ GlobalUnlock h\r
+ GlobalUnlock handle\r
+ If h\r
+ EmptyClipboard\r
+ SetClipboardData CF_OEMTEXT,h\r
+ EndIf\r
+ EndIf\r
+ CloseClipboard\r
+ SendMessageW _hwnd,WM_PASTE,0,0\r
+ SetFocus _hwnd\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method DoPrint()\r
+ \r
+ Local tmpTextSelLen = TextAreaSelLen(Self)\r
+ \r
+ Local tmpPrintDialog:PRINTDLGW = New PRINTDLGW\r
+ \r
+ tmpPrintDialog.flags = PD_RETURNDC | PD_HIDEPRINTTOFILE | PD_NOPAGENUMS\r
+ If Not tmpTextSelLen Then tmpPrintDialog.flags:|PD_NOSELECTION\r
+ \r
+ tmpPrintDialog.hwndOwner = _hwnd\r
+ \r
+ If Not PrintDlg( Byte Ptr tmpPrintDialog ) Then Return 0\r
+ \r
+ Local hdcPrinter = tmpPrintDialog.hdc \r
+ \r
+ Local tmpDoc:DOCINFOW = New DOCINFOW\r
+ Local tmpDocTitle:Short Ptr = AppTitle.ToWString()\r
+ tmpDoc.lpszDocName = tmpDocTitle\r
+ \r
+ Local tmpSuccess = (StartDocW( hdcPrinter, Byte Ptr tmpDoc ) > 0)\r
+ \r
+ If tmpSuccess Then\r
+ \r
+ Local _cursor = TWindowsGUIDriver._cursor\r
+ \r
+ SetPointer( POINTER_WAIT )\r
+ \r
+ SetMapMode( hdcPrinter, MM_TEXT )\r
+ \r
+ Local wPage = GetDeviceCaps( hdcPrinter, PHYSICALWIDTH )\r
+ Local hPage = GetDeviceCaps( hdcPrinter, PHYSICALHEIGHT )\r
+ Local xPPI = GetDeviceCaps( hdcPrinter, LOGPIXELSX )\r
+ Local yPPI = GetDeviceCaps( hdcPrinter, LOGPIXELSY )\r
+ \r
+ Local tmpTextLengthStruct[] = [GTL_DEFAULT,1200]\r
+ Local tmpTextLength = SendMessageW (_hwnd, EM_GETTEXTLENGTHEX, Int Byte Ptr tmpTextLengthStruct, 0)\r
+ \r
+ Local tmpTextPrinted, tmpFormatRange:FORMATRANGE = New FORMATRANGE\r
+ \r
+ tmpFormatRange.hdc = hdcPrinter\r
+ tmpFormatRange.hdcTarget = hdcPrinter\r
+ \r
+ tmpFormatRange.rcPageRight = (wPage*1440:Long)/xPPI\r
+ tmpFormatRange.rcPageBottom = (hPage*1440:Long)/yPPI\r
+ \r
+ tmpFormatRange.rcLeft = (1440*_pagemargin);tmpFormatRange.rcTop = (1440*_pagemargin)\r
+ tmpFormatRange.rcRight = tmpFormatRange.rcPageRight - (2880*_pagemargin)\r
+ tmpFormatRange.rcBottom = tmpFormatRange.rcPageBottom - (2880*_pagemargin)\r
+ \r
+ If tmpPrintDialog.flags & PD_SELECTION Then\r
+ tmpTextPrinted = TextAreaCursor(Self)\r
+ tmpFormatRange.CHARRANGE_cpMax = tmpTextPrinted+tmpTextSelLen\r
+ Else\r
+ tmpFormatRange.CHARRANGE_cpMax = tmpTextLength\r
+ EndIf\r
+ \r
+ SendMessageW (_hwnd, EM_FORMATRANGE, False, 0)\r
+ \r
+ While tmpSuccess And ( tmpTextPrinted < tmpFormatRange.CHARRANGE_cpMax )\r
+ \r
+ tmpFormatRange.CHARRANGE_cpMin = tmpTextPrinted\r
+ \r
+ tmpSuccess = (StartPage(hdcPrinter) > 0)\r
+ If Not tmpSuccess Then Exit\r
+ \r
+ tmpTextPrinted = SendMessageW( _hwnd, EM_FORMATRANGE, True, Int Byte Ptr tmpFormatRange )\r
+ \r
+ tmpSuccess = (EndPage(hdcPrinter) > 0)\r
+ \r
+ Wend\r
+ \r
+ If tmpSuccess Then EndDoc( hdcPrinter ) Else AbortDoc( hdcPrinter )\r
+ \r
+ SendMessageW (_hwnd, EM_FORMATRANGE, False, 0)\r
+ \r
+ TWindowsGUIDriver._cursor = _cursor\r
+ SetCursor _cursor\r
+ \r
+ EndIf\r
+ \r
+ GlobalFree( tmpPrintDialog.hDevMode )\r
+ GlobalFree( tmpPrintDialog.hDevNames )\r
+ DeleteDC( hdcPrinter )\r
+ \r
+ MemFree tmpDocTitle\r
+ \r
+ Return tmpSuccess\r
+ \r
+ EndMethod\r
+ \r
+ Global gt[] = [GTL_DEFAULT, CP_ACP]\r
+ \r
+ Method CharCount()\r
+ Return SendMessageW(_hwnd,EM_GETTEXTLENGTHEX,Int Byte Ptr gt,0)\r
+ EndMethod\r
+ \r
+ Method SetStyle(r,g,b,flags,pos,length,units)\r
+ Local iifont:ITextFont\r
+ Local iirange:ITextRange\r
+ Local res, tmpOutput\r
+ If units=TEXTAREA_LINES\r
+ Local n=pos\r
+ pos=CharAt(pos)\r
+ If length>=0 length=CharAt(n+length)-pos\r
+ EndIf \r
+ If length<0 length=charcount()-pos \r
+ busy:+1 \r
+ res=idoc.Range(pos,pos+length,iirange)\r
+ res=iirange.GetFont(iifont)\r
+ res=iifont.SetForeColor(((b Shl 16)|(g Shl 8)|r))\r
+ If (flags&TEXTFORMAT_BOLD) Then iifont.SetBold(TOMTRUE) Else iifont.SetBold(TOMFALSE)\r
+ If (flags&TEXTFORMAT_ITALIC) Then iifont.SetItalic(TOMTRUE) Else iifont.SetItalic(TOMFALSE)\r
+ If (flags&TEXTFORMAT_UNDERLINE) Then iifont.SetUnderline(TOMSINGLE) Else iifont.SetUnderline(TOMFALSE)\r
+ If (flags&TEXTFORMAT_STRIKETHROUGH) Then iifont.SetStrikeThrough(TOMTRUE) Else iifont.SetStrikeThrough(TOMNONE)\r
+ iifont.Release_\r
+ iirange.Release_\r
+ busy:-1\r
+ EndMethod \r
+ \r
+ Method InsertText(Text$,pos,count)\r
+ Local iirange:ITextRange\r
+ Local bstr:Short Ptr, tmpWString:Short Ptr = Text.toWString()\r
+ Local res, bool\r
+ busy:+1\r
+ res=idoc.Range(pos,pos+count,iirange) \r
+ bstr=SysAllocStringLen(tmpWString,Text.length);MemFree tmpWString\r
+ LockText()\r
+ res=iirange.SetText(bstr)\r
+ UnlockText()\r
+ SysFreeString bstr\r
+ iirange.Release_\r
+ busy:-1\r
+ EndMethod\r
+ \r
+ Method ReplaceText(pos,length,Text$,units)\r
+ If units=TEXTAREA_LINES\r
+ Local n=pos\r
+ pos=CharAt(pos)\r
+ If length>=0 length=CharAt(n+length)-pos\r
+ EndIf \r
+ If length<0 Then length=charcount()-pos \r
+ InsertText Text,pos,length\r
+ EndMethod\r
+\r
+ Method AreaText$(pos,length,units)\r
+ Local iirange:ITextRange\r
+ Local bstr:Short Ptr\r
+\r
+ If units=TEXTAREA_LINES\r
+ Local n=pos\r
+ pos=CharAt(pos)\r
+ If length>=0 length=CharAt(n+length)-pos\r
+ EndIf \r
+ If length<0 length=charcount()-pos \r
+ idoc.Range(pos,pos+length,iirange) \r
+ iirange.GetText(Varptr bstr)\r
+ Local Text$=String.FromWString(bstr)\r
+ SysFreeString bstr\r
+ iirange.Release_\r
+ Text=Text.Replace(Chr(13),Chr(10))\r
+ Return Text\r
+ EndMethod\r
+ \r
+ Method SetSelection(pos,length,units)\r
+ If units=TEXTAREA_LINES\r
+ Local n=pos\r
+ pos=CharAt(pos)\r
+ If length>0\r
+ length=CharAt(n+length)\r
+ length=length-pos\r
+ EndIf\r
+ EndIf \r
+ If length<0 length=charcount()-pos \r
+ Local cr:CHARRANGE = New CHARRANGE\r
+ cr.cpMin=pos\r
+ cr.cpMax=pos+length\r
+ Desensitize()\r
+ SendMessageW _hwnd,EM_EXSETSEL,0,Int Byte Ptr(cr)\r
+ Sensitize()\r
+ EndMethod\r
+\r
+ Method SetMargins(leftmargin)\r
+ SendMessageW _hwnd,EM_SETMARGINS,EC_LEFTMARGIN,leftmargin\r
+ EndMethod\r
+ \r
+ ' 72 points per inch\r
+ \r
+ Method SetTabs(tabs)\r
+ Local hdc=GetDC( 0 )\r
+ idoc.SetDefaultTabStop tabs * 72.0 / GetDeviceCaps( hdc,LOGPIXELSX )\r
+ ReleaseDC 0,hdc\r
+ EndMethod\r
+\r
+ Method SetTextColor(r,g,b)\r
+ cf.cbSize=SizeOf(CHARFORMATW) \r
+ cf.dwMask=CFM_COLOR|CFM_BOLD|CFM_ITALIC\r
+ cf.crTextColor=(b Shl 16)|(g Shl 8)|r \r
+ SendMessageW _hwnd,EM_SETCHARFORMAT,SCF_DEFAULT,Int Byte Ptr cf\r
+ SendMessageW _hwnd,EM_SETCHARFORMAT,SCF_ALL,Int Byte Ptr cf\r
+ EndMethod\r
+\r
+ Method SetColor(r,g,b)\r
+ SendMessageW _hwnd,EM_SETBKGNDCOLOR,0,((b Shl 16)|(g Shl 8)|r)\r
+ EndMethod\r
+\r
+ Method RemoveColor()\r
+ SendMessageW _hwnd,EM_SETBKGNDCOLOR,1,0\r
+ EndMethod\r
+ \r
+ Method GetCursorPos(units)\r
+ Local cr:CHARRANGE = New CHARRANGE\r
+ SendMessageW _hwnd,EM_EXGETSEL,0,Int Byte Ptr(cr)\r
+ Local pos=cr.cpMin\r
+ If units=TEXTAREA_LINES pos=LineAt(pos)\r
+ Return pos\r
+ EndMethod \r
+ \r
+ Method GetSelectionLength(units)\r
+ Local cr:CHARRANGE = New CHARRANGE\r
+ SendMessageW _hwnd,EM_EXGETSEL,0,Int Byte Ptr(cr)\r
+ If units=TEXTAREA_LINES\r
+ Return LineAt(cr.cpMax-1)-LineAt(cr.cpMin)+1\r
+ Else\r
+ Return cr.cpMax-cr.cpMin\r
+ EndIf\r
+ EndMethod\r
+\r
+ Method CharAt(Line)\r
+ If Line<0 Return\r
+ If Line>AreaLen(TEXTAREA_LINES) Return charcount()\r
+ Return SendMessageW(_hwnd,EM_LINEINDEX,Line,0)\r
+ EndMethod\r
+\r
+ Method LineAt(pos)\r
+ If pos<0 Return\r
+ If pos>charcount() Return AreaLen(TEXTAREA_LINES)\r
+ Return SendMessageW(_hwnd,EM_EXLINEFROMCHAR,0,pos)\r
+ EndMethod\r
+\r
+ Method AreaLen(units)\r
+ If units=TEXTAREA_LINES Return LineAt(charcount())\r
+ Return charcount()\r
+ EndMethod\r
+ \r
+ Method CharX( char )\r
+ Local tmpPoint[2]\r
+ SendMessageW(_hwnd, EM_POSFROMCHAR, Int Byte Ptr tmpPoint, char )\r
+ Return tmpPoint[0]\r
+ EndMethod\r
+ \r
+ Method CharY( char )\r
+ Local tmpPoint[2]\r
+ SendMessageW(_hwnd, EM_POSFROMCHAR, Int Byte Ptr tmpPoint, char )\r
+ Return tmpPoint[1]\r
+ EndMethod\r
+ \r
+ Method SetText(Text$)\r
+ InsertText Text,0,charcount()\r
+ EndMethod\r
+\r
+ Method AddText(Text$)\r
+ InsertText Text,charcount(),0\r
+ Local cr:CHARRANGE = New CHARRANGE\r
+ Local p = charcount()\r
+ cr.cpMin=p\r
+ cr.cpMax=p\r
+ SendMessageW _hwnd,EM_EXSETSEL,0,Int Byte Ptr(cr)\r
+ EndMethod\r
+ \r
+ Method GetText$()\r
+ Return AreaText(0,charcount(),TEXTAREA_CHARS)\r
+ EndMethod\r
+ \r
+ Global _oldCursor = 0\r
+ Field _oldSelPos%, _oldSelLen% = 0\r
+ \r
+ Method LockText()\r
+ \r
+ If Not idoc.Freeze(_locked)\r
+ _oldSelPos = GetCursorPos(TEXTAREA_CHARS)\r
+ _oldSelLen = GetSelectionLength(TEXTAREA_CHARS)\r
+ If Not _oldCursor Then _oldCursor = GetCursor()\r
+ EndIf\r
+ \r
+ EndMethod\r
+ \r
+ Method UnlockText()\r
+ \r
+ If idoc.Unfreeze(_locked) = S_OK Then\r
+ SetSelection( _oldSelPos, _oldSelLen, TEXTAREA_CHARS )\r
+ If _oldCursor And (_oldCursor <> GetCursor()) Then\r
+ SetCursor(_oldCursor)\r
+ EndIf\r
+ _oldCursor = 0\r
+ EndIf\r
+ \r
+ EndMethod\r
+\r
+ Method OnCommand(msg,wp)\r
+ If busy Then Return\r
+ Select wp Shr 16\r
+ Case EN_CHANGE\r
+ If Not _locked Then PostGuiEvent EVENT_GADGETACTION\r
+ End Select\r
+ EndMethod\r
+\r
+ Method OnNotify(wp,lp)\r
+ Local nmhdr:Int Ptr\r
+ Local event:TEvent\r
+ \r
+ Super.OnNotify(wp,lp) 'Tooltip\r
+ \r
+ nmhdr=Int Ptr(lp)\r
+ Select nmhdr[2]\r
+' Case EN_PROTECTED\r
+' DebugStop\r
+ Case EN_SELCHANGE\r
+ If Not (busy Or _locked)\r
+ PostGuiEvent EVENT_GADGETSELECT\r
+ EndIf\r
+ Case EN_MSGFILTER\r
+ Select nmhdr[3]\r
+ Case WM_RBUTTONDOWN\r
+ If GetSelectionLength(TEXTAREA_CHARS)=0 nmhdr[3]=WM_LBUTTONDOWN\r
+ Case WM_RBUTTONUP\r
+ Local mx=nmhdr[5] & $ffff\r
+ Local my=nmhdr[5] Shr 16\r
+ PostGuiEvent EVENT_GADGETMENU,0,0,mx,my\r
+ Case WM_KEYDOWN\r
+ \r
+ Local k=nmhdr[4]\r
+ \r
+ 'Filtering out special shortcut combinations\r
+ If (keymods()&MODIFIER_CONTROL) Then\r
+ Select k\r
+ Case 76,69,82 'ctrl+l, ctrl+e, ctrl+r\r
+ Return 1 'Alignment shortcuts\r
+ \r
+ Case 188,190 'ctrl+<, ctrl+>\r
+ 'Font size shortcuts\r
+ If (keymods()&MODIFIER_SHIFT) Then Return 1\r
+ EndSelect\r
+ EndIf\r
+ \r
+ 'Read-only\r
+ If readonly\r
+ If k>=33 And k<=40 Return 0 'selection keys\r
+ If (keymods()&MODIFIER_CONTROL) Then\r
+ Select k\r
+ Case 65, 67;Return 0 'ctrl-a, ctrl+c\r
+ EndSelect\r
+ EndIf\r
+ Return 1 \r
+ EndIf\r
+ \r
+ 'Event Filter\r
+ If eventfilter<>Null\r
+ event=CreateEvent(EVENT_KEYDOWN,Self,k,keymods())\r
+ Return Not eventfilter(event,context)\r
+ EndIf\r
+ \r
+ Case WM_CHAR\r
+ If readonly Return 1\r
+ If eventfilter<>Null\r
+ event=CreateEvent(EVENT_KEYCHAR,Self,nmhdr[4],keymods())\r
+ Return Not eventfilter(event,context)\r
+ EndIf\r
+ End Select\r
+ End Select\r
+ EndMethod\r
+\r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ \r
+ Case WM_MOUSEWHEEL\r
+ If (wp&MK_CONTROL) Then SendMessageW _hwnd, EM_SETZOOM, 0, 0\r
+ \r
+ Case WM_KILLFOCUS\r
+ PostGuiEvent EVENT_GADGETLOSTFOCUS\r
+ \r
+ End Select\r
+ \r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ \r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_TEXTAREA\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsListBox Extends TWindowsGadget\r
+\r
+ Field _icons:TWindowsIconStrip\r
+ Field _selected = -1\r
+\r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ \r
+ Self.style = style\r
+ \r
+ xstyle=WS_EX_CLIENTEDGE\r
+ wstyle=WS_CHILD|WS_TABSTOP|LVS_REPORT|LVS_NOCOLUMNHEADER|LVS_SHOWSELALWAYS|LVS_SHAREIMAGELISTS \r
+ wstyle:|WS_CLIPSIBLINGS\r
+ \r
+ If (style&LISTBOX_MULTISELECT<>LISTBOX_MULTISELECT) Then wstyle:|LVS_SINGLESEL\r
+ \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"SysListView32","",wstyle,0,0,20,20,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ \r
+ Local column:LVCOLUMNW\r
+ column=New LVCOLUMNW\r
+ SendMessageW hwnd,LVM_INSERTCOLUMNW,0,Int Byte Ptr(column)\r
+ \r
+ SendMessageW hwnd,LVM_SETEXTENDEDLISTVIEWSTYLE,LVS_EX_FULLROWSELECT|LVS_EX_INFOTIP,LVS_EX_FULLROWSELECT|LVS_EX_INFOTIP\r
+ \r
+ If TWindowsGUIDriver.CheckCommonControlVersion() Then SendMessageW hwnd,LVM_SETEXTENDEDLISTVIEWSTYLE,LVS_EX_DOUBLEBUFFER,LVS_EX_DOUBLEBUFFER\r
+ \r
+ Register GADGET_LISTBOX,hwnd,0,False 'Set to True for normal Tooltips\r
+ \r
+ If TWindowsGUIDriver._explorerstyle Then UseExplorerTheme()\r
+ \r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method SetColor(r,g,b)\r
+ SendMessageW _hwnd,LVM_SETBKCOLOR ,0,(b Shl 16)|(g Shl 8)|r\r
+ SendMessageW _hwnd,LVM_SETTEXTBKCOLOR ,0,(b Shl 16)|(g Shl 8)|r\r
+ EndMethod\r
+\r
+ Method RemoveColor()\r
+ SendMessageW _hwnd,LVM_SETBKCOLOR ,1,0\r
+ SendMessageW _hwnd,LVM_SETTEXTBKCOLOR ,1,0\r
+ EndMethod\r
+\r
+ Method SetTextColor(r,g,b)\r
+ SendMessageW _hwnd,LVM_SETTEXTCOLOR,0,(b Shl 16)|(g Shl 8)|r\r
+ EndMethod\r
+ \r
+ 'Hack: When image lists are removed from listviews, the items don't\r
+ 'reposition themselves automatically. Hack involves first setting a tiny\r
+ 'blank image-list to update item size, before attempting to remove it.\r
+ Method SetIconStrip(iconstrip:TIconStrip)\r
+ Local imagelist\r
+ If Not iconstrip Then\r
+ _icons = TWindowsIconStrip.CreateBlank()\r
+ Else\r
+ _icons = TWindowsIconStrip(iconstrip)\r
+ EndIf\r
+ If _icons Then imagelist = _icons._imagelist\r
+ SendMessageW _hwnd,LVM_SETIMAGELIST,LVSIL_SMALL,imagelist\r
+ If Not iconstrip Then\r
+ SendMessageW _hwnd,LVM_SETIMAGELIST,LVSIL_SMALL,0\r
+ _icons = Null\r
+ EndIf\r
+ EndMethod\r
+\r
+ Method ClearListItems()\r
+ _selected=-1\r
+ DeSensitize()\r
+ SendMessageW _hwnd,LVM_DELETEALLITEMS,0,0\r
+ If Not IsSingleSelect() Then SelectionChanged()\r
+ Sensitize()\r
+ EndMethod\r
+\r
+ Method InsertListItem(index,Text$,tip$,icon,tag:Object)\r
+ \r
+ Local it:LVITEMW\r
+ it=New LVITEMW\r
+ it.mask=LVIF_TEXT|LVIF_DI_SETITEM\r
+ it.iItem=index\r
+ it.pszText=Text.toWString()\r
+ \r
+ 'If icon>=0 Then\r
+ it.mask:|LVIF_IMAGE\r
+ it.iImage=icon\r
+ 'EndIf\r
+ \r
+ Desensitize()\r
+ SendMessageW _hwnd,LVM_INSERTITEMW,0,Int Byte Ptr(it)\r
+ SendMessageW _hwnd,LVM_SETCOLUMNWIDTH,0,-2\r
+ If Not IsSingleSelect() Then SelectionChanged()\r
+ Sensitize()\r
+ MemFree it.pszText\r
+ \r
+ EndMethod\r
+ \r
+ Method SetListItem(index,Text$,tip$,icon,tag:Object)\r
+ Local tmpReselect\r
+ If ListItemState(index) & STATE_SELECTED Then tmpReselect = True\r
+ RemoveListItem index\r
+ InsertListItem index,Text,tip,icon,tag\r
+ If tmpReselect Then SetItemState(index,STATE_SELECTED)\r
+ EndMethod\r
+ \r
+ Method RemoveListItem(index)\r
+ Desensitize()\r
+ If ListItemState(index) & STATE_SELECTED Then _selected = -1\r
+ SendMessageW _hwnd,LVM_DELETEITEM,index,0\r
+ SendMessageW _hwnd,LVM_SETCOLUMNWIDTH,0,-2\r
+ If Not IsSingleSelect() Then SelectionChanged()\r
+ Sensitize()\r
+ EndMethod\r
+ \r
+ Method SetListItemState(index,state)\r
+ Local it:LVITEMW = New LVITEMW\r
+ it.mask=LVIF_STATE\r
+ it.iItem=index\r
+ If state&STATE_SELECTED\r
+ it.state=LVIS_SELECTED\r
+ If IsSingleSelect() Then _selected=index\r
+ ElseIf _selected=index\r
+ _selected=-1\r
+ EndIf\r
+ it.stateMask=LVIS_SELECTED\r
+ Desensitize()\r
+ SendMessageW _hwnd,LVM_SETITEMSTATE,index,Int Byte Ptr(it)\r
+ If it.state Then SendMessageW _hwnd,LVM_ENSUREVISIBLE,index,False\r
+ If Not IsSingleSelect() Then SelectionChanged()\r
+ Sensitize()\r
+ EndMethod\r
+ \r
+ Method ListItemState(index)\r
+ Local state = SendMessageW(_hwnd,LVM_GETITEMSTATE,index,LVIS_SELECTED)\r
+ If state&LVIS_SELECTED Return STATE_SELECTED\r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ 'ToolTips should be set on an item-by-item basis instead.\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ Case WM_MAXGUILISTREFRESH\r
+ Local index\r
+ \r
+ If IsSingleSelect() Then\r
+ index=SendMessageW(_hwnd,LVM_GETNEXTITEM,-1,LVNI_SELECTED)\r
+ Else\r
+ index = SelectionChanged()\r
+ EndIf\r
+ If index <> _selected Then\r
+ If IsSingleSelect() Then _selected = index\r
+ Local item:TGadgetItem = New TGadgetItem\r
+ If index>=0 And index<items.length item=items[index]\r
+ PostGuiEvent EVENT_GADGETSELECT,index,0,0,0,item.extra\r
+ EndIf\r
+ \r
+ 'If we are using XP Common Controls or higher, then the listbox will be double-buffered\r
+ 'and so we don't need to clear the background (performance tweak).\r
+ Case WM_ERASEBKGND\r
+ If TWindowsGUIDriver.CheckCommonControlVersion() Then Return 1\r
+ EndSelect\r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ EndMethod\r
+ \r
+ Method OnNotify(wp,lp)\r
+ Local nmhdr:Int Ptr = Int Ptr(lp)\r
+ Local index, code = nmhdr[2]\r
+ Select code\r
+ \r
+ Case LVN_GETINFOTIPW\r
+ Local tmpItemIndex = nmhdr[6]\r
+ Local tmpMaxCharCount = nmhdr[5]-1\r
+ Local tmpTipOutput:Short Ptr = Short Ptr(nmhdr[4])\r
+ \r
+ If tmpItemIndex < items.length Then\r
+ \r
+ Local tmpTipString$ = items[tmpItemIndex].tip\r
+ If (items[tmpItemIndex].flags&GADGETITEM_LOCALIZED) Then tmpTipString = LocalizeString(tmpTipString)\r
+ \r
+ tmpTipString = tmpTipString[..Min(tmpTipString.length,tmpMaxCharCount)]\r
+ \r
+ Local tmpBufferMem:Short Ptr = tmpTipString.ToWString()\r
+ MemCopy tmpTipOutput, tmpBufferMem, (tmpTipString.length+1) * 2\r
+ MemFree tmpBufferMem\r
+ \r
+ EndIf\r
+\r
+ Case LVN_ITEMCHANGED\r
+ 'We need to postpone processing until after *all* item states have been updated by the OS.\r
+ If Not(nmhdr[7]&LVIF_STATE) Then Return\r
+ PostMessageW( _hwnd, WM_MAXGUILISTREFRESH, 0, 0 )\r
+ Case NM_DBLCLK\r
+ index=nmhdr[3]\r
+ Local item:TGadgetItem\r
+ If index>=0 And index<items.length\r
+ item=items[index]\r
+ PostGuiEvent EVENT_GADGETACTION,index,0,0,0,item.extra\r
+ EndIf\r
+ Case NM_CLICK\r
+ index=nmhdr[3]\r
+ If index=-1 And _selected<>-1\r
+ _selected=-1\r
+ PostGuiEvent EVENT_GADGETSELECT,-1\r
+ EndIf\r
+ Case NM_RCLICK\r
+ index=nmhdr[3]\r
+ Local item:TGadgetItem\r
+ If index>=0 And index<items.length\r
+ item=items[index]\r
+ PostGuiEvent EVENT_GADGETMENU,index,0,0,0,item.extra\r
+ EndIf\r
+ 'Return true to tell the OS not to send individual LVN_DELETEITEM notifications for each and every item when clearing list.\r
+ Case LVN_DELETEALLITEMS\r
+ Return True\r
+ End Select\r
+ EndMethod\r
+ \r
+ Method IsSingleSelect()\r
+ Return (style&LISTBOX_MULTISELECT<>LISTBOX_MULTISELECT)\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_LISTBOX\r
+ EndMethod\r
+ \r
+ Method HasResized()\r
+ SendMessageW _hwnd,LVM_SETCOLUMNWIDTH,0,-2\r
+ EndMethod\r
+ \r
+ Method UseExplorerTheme()\r
+ If TWindowsGUIDriver.CheckCommonControlVersion() And SetWindowThemeW Then SetWindowThemeW( _hwnd, _wstrExplorer, Null )\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsComboBox Extends TWindowsGadget\r
+\r
+ Field _icons:TWindowsIconStrip\r
+ Field _editHwnd, _comboHwnd\r
+ Field _selected = -1\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="")\r
+ Local xstyle,wstyle,hotkey,hwnd\r
+ Local parent,editstyle,combostyle\r
+ \r
+ Self.style = style\r
+ wstyle=WS_CHILD|WS_TABSTOP|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|CBS_AUTOHSCROLL\r
+ If (style & COMBOBOX_EDITABLE) Then wstyle:|CBS_DROPDOWN Else wstyle:|CBS_DROPDOWNLIST\r
+ \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"ComboBoxEx32","",wstyle,0,0,0,180,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ \r
+ If (style & COMBOBOX_EDITABLE) Then\r
+ _editHwnd=SendMessageW(hwnd,CBEM_GETEDITCONTROL,0,0)\r
+ If _editHwnd Then\r
+ editstyle=GetWindowLongW(_editHwnd,GWL_STYLE)\r
+ SetWindowLongW _editHwnd,GWL_STYLE,editstyle|WS_TABSTOP\r
+ EndIf\r
+ EndIf\r
+\r
+ _comboHwnd=SendMessageW(hwnd,CBEM_GETCOMBOCONTROL,0,0)\r
+ comboStyle=GetWindowLongW(_comboHwnd,GWL_STYLE)\r
+ SetWindowLongW _comboHwnd,GWL_STYLE,comboStyle|WS_TABSTOP\r
+ \r
+ Register GADGET_COMBOBOX,hwnd\r
+ \r
+ TWindowsGUIDriver.RegisterHwnd(_combohwnd,Self)\r
+ If _edithwnd Then TWindowsGUIDriver.RegisterHwnd(_edithwnd,Self)\r
+ \r
+ SetColor(255,255,255)\r
+ \r
+ Return Self \r
+ \r
+ EndMethod\r
+ \r
+ Method SetText(Text$)\r
+ If Not _editHwnd Then\r
+ Local tmpWString:Short Ptr = Text.ToWString()\r
+ Local tmpResult = SendMessageW(_comboHwnd, CB_SETCUEBANNER, 0, Int(tmpWString))\r
+ MemFree tmpWString;Return tmpResult\r
+ Else\r
+ Return Super.SetText(Text)\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method GetText$()\r
+ If Not _editHwnd Then\r
+ If _selected > -1 Then Return items[_selected].Text Else Return ""\r
+ Else\r
+ Return Super.GetText()\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method Activate(cmd)\r
+ If _editHwnd Then\r
+ Select cmd\r
+ Case ACTIVATE_CUT \r
+ SendMessageW _editHwnd,WM_CUT,0,0\r
+ Case ACTIVATE_COPY \r
+ SendMessageW _editHwnd,WM_COPY,0,0\r
+ SetFocus _hwnd\r
+ Case ACTIVATE_PASTE\r
+ SendMessageW _editHwnd,WM_PASTE,0,0\r
+ Case ACTIVATE_FOCUS\r
+ SendMessageW _editHwnd,EM_SETSEL,0,-1\r
+ End Select\r
+ EndIf\r
+ Return Super.Activate(cmd)\r
+ EndMethod\r
+ \r
+ Method SetIconStrip(iconstrip:TIconStrip)\r
+ Local imagelist\r
+ _icons=TWindowsIconStrip(iconstrip)\r
+ If _icons Then imagelist = _icons._imagelist\r
+ SendMessageW _hwnd,CBEM_SETIMAGELIST,LVSIL_SMALL,imagelist\r
+ EndMethod\r
+\r
+ Method ClearListItems()\r
+ _selected=-1\r
+ Desensitize()\r
+ SendMessageW _hwnd,CB_RESETCONTENT,0,0\r
+ Sensitize()\r
+ EndMethod\r
+\r
+ Method InsertListItem(index,Text$,tip$,icon,tag:Object)\r
+ Local it:COMBOBOXEXITEMW = New COMBOBOXEXITEMW\r
+ it.mask=CBEIF_TEXT\r
+ it.iItem=index\r
+ it.pszText=Text.toWString()\r
+ If icon>=0\r
+ it.mask:|CBEIF_IMAGE|CBEIF_SELECTEDIMAGE\r
+ it.iImage=icon\r
+ it.iSelectedImage=icon\r
+ EndIf\r
+ Desensitize()\r
+ SendMessageW(_hwnd,CBEM_INSERTITEMW,0,Int Byte Ptr(it))\r
+ Sensitize()\r
+ MemFree it.pszText\r
+ EndMethod\r
+ \r
+ Method SetListItem(index,Text$,tip$,icon,tag:Object)\r
+ Local it:COMBOBOXEXITEMW = New COMBOBOXEXITEMW\r
+ it.mask=CBEIF_TEXT\r
+ it.iItem=index\r
+ it.pszText=Text.toWString()\r
+ If _icons And icon>-1\r
+ it.mask:|CBEIF_IMAGE|CBEIF_SELECTEDIMAGE\r
+ it.iImage=icon\r
+ it.iSelectedImage=icon\r
+ EndIf\r
+ Desensitize()\r
+ SendMessageW(_hwnd,CBEM_SETITEMW,0,Int Byte Ptr(it))\r
+ Sensitize()\r
+ MemFree it.pszText\r
+ EndMethod\r
+ \r
+ Method RemoveListItem(index)\r
+ Desensitize()\r
+ SendMessageW _hwnd,CBEM_DELETEITEM,index,0\r
+ Sensitize()\r
+ EndMethod\r
+ \r
+ Method SetListItemState(index,state)\r
+ If state&STATE_SELECTED\r
+ _selected=index\r
+ Else\r
+ If _selected=index _selected=-1\r
+ index=-1\r
+ EndIf\r
+ Desensitize()\r
+ SendMessageW _hwnd,CB_SETCURSEL,index,0\r
+ Sensitize()\r
+ EndMethod\r
+ \r
+ Method ListItemState(index)\r
+ Local Current,state\r
+ Current=SendMessageW(_hwnd,CB_GETCURSEL,0,0)\r
+ If Current=CB_ERR Current=-1\r
+ If Current=index state=STATE_SELECTED\r
+ Return state\r
+ EndMethod\r
+ \r
+ Method OnCommand(msg,wp)\r
+ Local index\r
+ Select wp Shr 16\r
+ Case CBN_SELCHANGE\r
+ index=SendMessageW(_hwnd,CB_GETCURSEL,0,0)\r
+ If index=CB_ERR\r
+ index=-1\r
+ Else\r
+ If _selected<>index 'user generated event\r
+ _selected=index\r
+ Local extra:Object\r
+ If index>=0 And index<items.length extra=items[index].extra\r
+ PostGuiEvent EVENT_GADGETACTION,index,0,0,0,extra\r
+ EndIf\r
+ EndIf\r
+ Case CBN_EDITCHANGE\r
+ _selected=-1\r
+ PostGuiEvent EVENT_GADGETACTION,-1\r
+ End Select\r
+ EndMethod\r
+\r
+ Method Class()\r
+ Return GADGET_COMBOBOX\r
+ EndMethod\r
+\r
+EndType\r
+\r
+Type TWindowsToolbar Extends TWindowsGadget\r
+ Field _icons:TWindowsIconStrip\r
+\r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ Self.style = style\r
+ xstyle=TBSTYLE_EX_DOUBLEBUFFER|TBSTYLE_EX_HIDECLIPPEDBUTTONS\r
+ wstyle=TBSTYLE_FLAT|WS_CHILD|WS_CLIPSIBLINGS|TBSTYLE_TRANSPARENT\r
+ Self.parent = group\r
+ parent=Self.parent.query(QUERY_HWND)\r
+ hwnd=CreateWindowExW(xstyle,"ToolbarWindow32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ DragAcceptFiles(hwnd,False) 'For some reason, toolbars may accept files by default!\r
+ Register GADGET_TOOLBAR,hwnd,0,True\r
+ SendMessageW _hwnd,TB_SETTOOLTIPS,_tooltips,0\r
+ Rethink()\r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method SetIconStrip(iconstrip:TIconStrip) \r
+ _icons=TWindowsIconStrip(iconstrip)\r
+ SendMessageW _hwnd,TB_SETIMAGELIST,0,_icons._imagelist \r
+ SendMessageW _hwnd,TB_AUTOSIZE,0,0\r
+ Rethink\r
+ EndMethod\r
+ \r
+ Method SetShow(truefalse)\r
+ Super.SetShow(truefalse)\r
+ UpdateWindowClient()\r
+ EndMethod\r
+ \r
+ Method Free()\r
+ SetShow(False)\r
+ Super.Free()\r
+ EndMethod\r
+ \r
+ Method Rethink()\r
+ \r
+ Local tmpRect[4]\r
+ GetWindowRect _hwnd,tmpRect\r
+ SetRect(0,0,parent.ClientWidth(),(tmpRect[3]-tmpRect[1]))\r
+ QueueResize _hwnd,xpos,ypos,width,height\r
+ UpdateWindowClient()\r
+ \r
+ EndMethod\r
+ \r
+ Method UpdateWindowClient()\r
+ Local tmpHeight:Int = height\r
+ If (State()&STATE_HIDDEN) Then tmpHeight = 0\r
+ If TWindowsGadget(parent)._clientY <> tmpHeight Then\r
+ TWindowsGadget(parent)._clientY = tmpHeight\r
+ parent.Rethink()\r
+ TWindowsGadget(parent).RethinkClient()\r
+ parent.LayoutKids()\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method DoLayout()\r
+ Rethink()\r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ 'ToolTips should be set on an item-by-item basis instead.\r
+ EndMethod\r
+ \r
+ Method ClearListItems()\r
+ While SendMessageW(_hwnd,TB_BUTTONCOUNT,0,0)\r
+ RemoveListItem(0)\r
+ Wend\r
+ EndMethod\r
+\r
+ Method InsertListItem(index,Text$,tip$,icon,tag:Object)\r
+ Local but:TBBUTTON\r
+ but=New TBBUTTON\r
+ but.fsState=TBSTATE_ENABLED\r
+ If icon = -2 Or (icon>-1 And _icons.IsBlankIcon(icon))\r
+ but.idCommand=0\r
+ but.fsStyle=TBSTYLE_SEP\r
+ Else\r
+ but.iBitmap=icon\r
+ but.idCommand=index+1\r
+ but.fsStyle=TBSTYLE_BUTTON\r
+ EndIf\r
+ Desensitize()\r
+ SendMessageW _hwnd,TB_INSERTBUTTON,index,Int Byte Ptr(but)\r
+ Sensitize()\r
+ If tip\r
+ Local ti:TOOLINFOW=New TOOLINFOW\r
+ ti.cbSize=SizeOf(ti)\r
+ ti.uFlags=TTF_SUBCLASS\r
+ ti.hwnd=_hwnd\r
+ ti.lpszText=tip.towstring()\r
+ ti.uId=index+1\r
+ SendMessageW _hwnd,TB_GETITEMRECT,index,Int(Varptr ti.rect_left)\r
+ SendMessageW _tooltips,TTM_ADDTOOLW,0,Int Byte Ptr(ti)\r
+ MemFree ti.lpszText\r
+ EndIf\r
+ EndMethod\r
+\r
+ Method SetListItem(index,Text$,tip$,icon,tag:Object)\r
+ Local tmpState:Int = ListItemState(index)\r
+ RemoveListItem index\r
+ InsertListItem index,Text,tip,icon,tag\r
+ SetListItemState(index,tmpState)\r
+ EndMethod\r
+ \r
+ Method RemoveListItem(index)\r
+ Local ti:TOOLINFOW=New TOOLINFOW\r
+ ti.cbSize=SizeOf(ti)\r
+ ti.hwnd=_hwnd\r
+ ti.uId=index+1\r
+ Desensitize()\r
+ SendMessageW _tooltips,TTM_DELTOOLW,0,Int(Varptr ti)\r
+ SendMessageW _hwnd,TB_DELETEBUTTON,index,0\r
+ Sensitize()\r
+ EndMethod\r
+ \r
+ Method SetListItemState(index,state)\r
+ Local enable,pressed\r
+ If state&STATE_DISABLED=0 enable=$1\r
+ If state&STATE_SELECTED pressed=$1\r
+ SendMessageW _hwnd,TB_ENABLEBUTTON,index+1,enable\r
+ SendMessageW _hwnd,TB_CHECKBUTTON,index+1,pressed\r
+ EndMethod\r
+ \r
+ Method ListItemState(index)\r
+ Local state,flags\r
+ state=SendMessageW(_hwnd,TB_GETSTATE,index+1,0)\r
+ If state=-1 Return 0\r
+ If Not (state&TBSTATE_ENABLED) flags:|STATE_DISABLED\r
+ If state&TBSTATE_CHECKED flags:|STATE_SELECTED\r
+ Return flags \r
+ EndMethod\r
+\r
+ Method OnCommand(msg,wp)\r
+ Local index=wp-1\r
+ Local extra:Object\r
+ If index>=0 And index<items.length extra=items[index].extra\r
+ PostGuiEvent EVENT_GADGETACTION,index,0,0,0,extra\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_TOOLBAR\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsTabber Extends TWindowsGadget\r
+\r
+ Field _icons:TWindowsIconStrip\r
+ Field _tabcount\r
+ Field _blank:Short Ptr\r
+ Field _selected = -1\r
+ Field _tipbuffer:Short Ptr\r
+\r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent,client\r
+ Self.style = style\r
+ xstyle=WS_EX_CONTROLPARENT\r
+ wstyle=WS_CHILD|TCS_HOTTRACK|WS_TABSTOP|TCS_FOCUSNEVER|WS_CLIPCHILDREN|WS_CLIPSIBLINGS \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"SysTabControl32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ client=CreateWindowExW(xstyle,TWindowsGUIDriver.ClassName(),"",WS_CHILD|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null )\r
+ SendMessageW hwnd,TCM_INSERTITEMW,0,Int(_wstrSpace)\r
+ Register GADGET_TABBER,hwnd,client,True\r
+ SendMessageW _hwnd,TCM_SETTOOLTIPS,_tooltips,0\r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method SetIconStrip(iconstrip:TIconStrip)\r
+ Local imagelist\r
+ _icons=TWindowsIconStrip(iconstrip)\r
+ If _icons Then imagelist = _icons._imagelist\r
+ SendMessageW _hwnd,TCM_SETIMAGELIST,0,imagelist\r
+ RethinkClient()\r
+ EndMethod\r
+ \r
+ Method ClientWidth()\r
+ Local Rect[] = [0,0,width,height]\r
+ SendMessageW _hwnd,TCM_ADJUSTRECT,False,Int Byte Ptr(Rect) \r
+ If Rect[2]>Rect[0] Then Return Rect[2]-Rect[0]\r
+ EndMethod\r
+\r
+ Method ClientHeight()\r
+ Local Rect[] = [0,0,width,height]\r
+ SendMessageW _hwnd,TCM_ADJUSTRECT,False,Int Byte Ptr(Rect) \r
+ If Rect[3]>Rect[1] Then Return Rect[3]-Rect[1]\r
+ EndMethod\r
+\r
+ Method ClearListItems()\r
+ _tabcount=0\r
+ _selected=-1\r
+ Desensitize()\r
+ SendMessageW _hwnd,TCM_DELETEALLITEMS, 0, 0\r
+ Sensitize()\r
+ RethinkClient()\r
+ EndMethod\r
+\r
+ Method InsertListItem(index,Text$,tip$,icon,tag:Object)\r
+ If _tabcount=0 SendMessageW _hwnd,TCM_DELETEALLITEMS,0,0\r
+ Local t:TCITEMW=New TCITEMW \r
+ t.mask=TCIF_TEXT|TCIF_IMAGE\r
+ t.pszText=Text.toWString()\r
+ t.iImage=icon\r
+ Desensitize()\r
+ SendMessageW _hwnd,TCM_INSERTITEMW,index,Int Byte Ptr(t)\r
+ Sensitize()\r
+ MemFree t.pszText \r
+ _tabcount:+1\r
+ RethinkClient()\r
+ EndMethod\r
+ \r
+ Method SetListItem(index,Text$,tip$,icon,tag:Object)\r
+ Local t:TCITEMW=New TCITEMW \r
+ t.mask=TCIF_TEXT|TCIF_IMAGE\r
+ t.pszText=Text.toWString()\r
+ t.iImage=icon\r
+ Desensitize()\r
+ SendMessageW _hwnd,TCM_SETITEMW,index,Int Byte Ptr(t)\r
+ Sensitize()\r
+ MemFree t.pszText\r
+ RethinkClient()\r
+ EndMethod\r
+ \r
+ Method RemoveListItem(index)\r
+ Desensitize()\r
+ SendMessageW _hwnd,TCM_DELETEITEM,index,0\r
+ _tabcount:-1\r
+ _selected=SendMessageW(_hwnd,TCM_GETCURSEL,0,0)\r
+ If _tabcount=0 SendMessageW _hwnd,TCM_INSERTITEMW,0,Int(_blank)\r
+ Sensitize()\r
+ RethinkClient()\r
+ EndMethod\r
+\r
+ Method SetListItemState(index,state)\r
+ Desensitize()\r
+ If state&STATE_SELECTED\r
+ _selected=index\r
+ SendMessageW _hwnd,TCM_SETCURSEL,index,0\r
+ ElseIf _selected=index\r
+ _selected=-1\r
+ EndIf\r
+ Sensitize()\r
+ EndMethod\r
+ \r
+ Method ListItemState(index)\r
+ Local state,Current\r
+ Current=-1\r
+ If _tabcount Current=SendMessageW(_hwnd,TCM_GETCURSEL,0,0)\r
+ If Current=index state:|STATE_SELECTED\r
+ Return state\r
+ EndMethod\r
+\r
+ Method OnNotify(wp,lp)\r
+ Local nmhdr:Int Ptr 'hwnd,id,code\r
+ Local index\r
+ nmhdr=Int Ptr(lp)\r
+ Select nmhdr[2]\r
+ \r
+ Case TTN_GETDISPINFOW\r
+ \r
+ Local TCHITTESTINFO[3], Rect[4]\r
+ \r
+ GetCursorPos_( TCHITTESTINFO );GetWindowRect( _hwnd, Rect )\r
+ TCHITTESTINFO = [TCHITTESTINFO[0]-Rect[0],TCHITTESTINFO[1]-Rect[1],0]\r
+ \r
+ Local tmpItem = SendMessageW( _hwnd, TCM_HITTEST, 0, Int Byte Ptr TCHITTESTINFO )\r
+ \r
+ If (tmpItem > -1) And (tmpItem < items.length) Then\r
+ Local tmpTooltip$ = items[tmpItem].tip\r
+ If (items[tmpItem].flags&GADGETITEM_LOCALIZED) Then tmpTooltip = LocalizeString(tmpTooltip)\r
+ SetTipBuffer( tmpTooltip )\r
+ If tmpTooltip Then nmhdr[3] = Int(_tipbuffer)\r
+ EndIf\r
+ \r
+ Case TCN_SELCHANGE\r
+ If _tabcount\r
+ index=SendMessageW(_hwnd,TCM_GETCURSEL,0,0)\r
+ If index<>_selected\r
+ Local extra:Object\r
+ If index>=0 And index<items.length\r
+ extra=items[index].extra\r
+ Else\r
+ index=-1\r
+ EndIf\r
+ _selected=index\r
+ \r
+ PostGuiEvent EVENT_GADGETACTION,index,0,0,0,extra\r
+ EndIf\r
+ EndIf\r
+ \r
+ Case NM_RCLICK\r
+ \r
+ Local TCHITTESTINFO[3], Rect[4], extra:Object\r
+ \r
+ GetCursorPos_( TCHITTESTINFO );GetWindowRect( _hwnd, Rect )\r
+ TCHITTESTINFO = [TCHITTESTINFO[0]-Rect[0],TCHITTESTINFO[1]-Rect[1],0]\r
+ \r
+ Local index = SendMessageW( _hwnd, TCM_HITTEST, 0, Int Byte Ptr TCHITTESTINFO )\r
+ If (index < 0) Or (index >= items.length) Then index = -1 Else extra = items[index].extra\r
+ \r
+ PostGuiEvent EVENT_GADGETMENU,index,0,TCHITTESTINFO[0],TCHITTESTINFO[1],extra\r
+ \r
+ EndSelect\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ Case WM_ERASEBKGND\r
+ Select hwnd\r
+ Case _hwndclient\r
+ If DrawThemeParentBackground Then\r
+ DrawParentBackground(wp,hwnd)\r
+ Return 1\r
+ EndIf\r
+ EndSelect\r
+ End Select\r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ EndMethod\r
+ \r
+ Method RethinkClient(forceRedraw:Int = False)\r
+ Local Rect[] = [0,0,width,height]\r
+ SendMessageW _hwnd,TCM_ADJUSTRECT,False, Int Byte Ptr(Rect)\r
+ MoveWindow _hwndclient,Rect[RECT_LEFT],Rect[RECT_TOP],Rect[RECT_RIGHT]-Rect[RECT_LEFT],Rect[RECT_BOTTOM]-Rect[RECT_TOP],forceRedraw\r
+ EndMethod\r
+ \r
+ Method SetTipBuffer( pTip$ )\r
+ If _tipbuffer Then MemFree _tipbuffer\r
+ If pTip Then _tipbuffer = pTip.ToWString()\r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ 'ToolTips should be set on an item-by-item basis instead.\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_TABBER\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsTreeNode Extends TGadget\r
+ Field _parent:TWindowsTreeNode\r
+ Field _tree 'HWND\r
+ Field _item 'HTREEITEM\r
+ Field _expanded\r
+ Field _icon\r
+ Field _handle\r
+ \r
+ Method Activate(cmd)\r
+ Local tmpTree:TWindowsTreeView = TWindowsTreeView(TWindowsGUIDriver.GadgetFromHwnd(_tree))\r
+ If tmpTree Then tmpTree.Desensitize()\r
+ Select cmd\r
+ Case ACTIVATE_SELECT\r
+ If _item <> TVI_ROOT Then\r
+ SendMessageW _tree,TVM_SELECTITEM,TVGN_CARET,_item\r
+ Else\r
+ SendMessageW _tree,TVM_SELECTITEM,TVGN_CARET,0\r
+ EndIf\r
+ Case ACTIVATE_EXPAND\r
+ SendMessageW _tree,TVM_EXPAND,TVE_EXPAND,_item\r
+ _expanded=True\r
+ Case ACTIVATE_COLLAPSE\r
+ SendMessageW _tree,TVM_EXPAND,TVE_COLLAPSE,_item\r
+ _expanded=False\r
+ Case ACTIVATE_REDRAW\r
+ RedrawNode()\r
+ End Select\r
+ If tmpTree Then tmpTree.Sensitize()\r
+ EndMethod\r
+ \r
+ Method CreateRoot:TWindowsTreeNode(owner:TWindowsTreeView)\r
+ _tree=owner._hwnd\r
+ _item=TVI_ROOT \r
+ Return Self\r
+ EndMethod\r
+\r
+ Method CountKids()\r
+ Return kids.count()\r
+ EndMethod\r
+\r
+ Method Create:TWindowsTreeNode(group:TGadget,style,Text$="",index=-1,icon = -1)\r
+ _parent=TWindowsTreeNode(group)\r
+ If Not _parent Throw "Parent isn't a treeview node. Use TreeViewRoot() when creating a root node."\r
+ Self.style = style\r
+ _tree=_parent._tree\r
+ _icon = icon\r
+ Spawn(Text,index)\r
+ _SetParent group,index\r
+ If (LocalizationMode()&LOCALIZATION_OVERRIDE) Then\r
+ LocalizeGadget(Self, Text, "")\r
+ EndIf\r
+ Return Self\r
+ EndMethod\r
+\r
+ Method GetText$()\r
+ Local item[10]\r
+ Local buffer:Short[260]\r
+ item[0]=TVIF_TEXT\r
+ item[1]=_item\r
+ item[4]=Int Byte Ptr buffer\r
+ item[5]=256\r
+ SendMessageW _tree,TVM_GETITEMW,0,Int Byte Ptr(item)\r
+ Return String.FromWString(buffer)\r
+ EndMethod\r
+ \r
+ Method SetText(Text$)\r
+ Local tv:TVITEMW=New TVITEMW\r
+ tv.mask=TVIF_HANDLE|TVIF_TEXT\r
+ tv.hItem = _item\r
+ If _icon > -1 Then\r
+ tv.mask:|TVIF_IMAGE|TVIF_SELECTEDIMAGE\r
+ tv.iImage=_icon\r
+ tv.iSelectedImage=tv.iImage\r
+ EndIf\r
+ tv.pszText=Text.ToWString()\r
+ SendMessageW(_tree,TVM_SETITEMW,0,Int Byte Ptr tv)\r
+ MemFree tv.pszText\r
+ EndMethod\r
+ \r
+ Method DoLayout()\r
+ 'Don't do anything!\r
+ EndMethod\r
+ \r
+ Method Free()\r
+ 'If we don't have a parent then the node must have previously been freed.\r
+ If Not _parent Then Return\r
+ 'Avoid firing events when freeing a treenode that is selected.\r
+ If SendMessageW(_tree,TVM_GETNEXTITEM,TVGN_CARET,0) Then DeSelect()\r
+ 'Free treenode\r
+ If _item Then SendMessageW(_tree,TVM_DELETEITEM,0,_item);_item=0\r
+ 'Redraw parent if we were its last child node\r
+ If Not SendMessageW(_tree, TVM_GETNEXTITEM, TVGN_CHILD, _parent._item) Then _parent.RedrawNode()\r
+ 'Cleanup variables that could be circular references\r
+ _parent = Null;_tree = 0;_SetParent Null\r
+ 'Release any handle we created using HandleFromObject() in Spawn()\r
+ If _handle Then Release _handle\r
+ EndMethod\r
+ \r
+ Method DeSelect()\r
+ SendMessageW _tree,TVM_SELECTITEM,TVGN_CARET,0\r
+ EndMethod\r
+ \r
+ Method InsertNode:TGadget(index,Text$,icon)\r
+ Return New TWindowsTreeNode.Create(Self,0,Text,index,icon)\r
+ EndMethod\r
+\r
+ Method ModifyNode(Text$,icon)\r
+ _icon = icon\r
+ SetText Text\r
+ EndMethod\r
+ \r
+ Method tviatindex(index)\r
+ If kids.IsEmpty() Then Return TVI_FIRST\r
+ If index<0 Or index>=kids.count() Return TVI_LAST \r
+ Local child:TWindowsTreeNode\r
+ child=TWindowsTreeNode(kids.valueatindex(index))\r
+ Return child._item\r
+ EndMethod\r
+ \r
+ Method Spawn(name$,index=-1)\r
+ \r
+ Local it:TVINSERTSTRUCTW\r
+ Local hitem \r
+ it=New TVINSERTSTRUCTW\r
+ it.hParent=_parent._item\r
+ If index = 0 Then\r
+ it.hInsertAfter = TVI_FIRST\r
+ Else\r
+ it.hInsertAfter=_parent.tviatindex(index-1)\r
+ EndIf\r
+ it.item_mask=TVIF_TEXT|TVIF_PARAM\r
+ \r
+ If _icon > -1 Then\r
+ it.item_mask:|TVIF_IMAGE|TVIF_SELECTEDIMAGE\r
+ it.item_iImage=_icon\r
+ it.item_iSelectedImage=it.item_iImage\r
+ EndIf\r
+ \r
+ Local tmpParentHadKids = SendMessageW(_tree, TVM_GETNEXTITEM, TVGN_CHILD, _parent._item)\r
+ \r
+ it.item_pszText=name.ToWString()\r
+ it.item_lparam=HandleFromObject(Self)\r
+ \r
+ 'Make sure that we store handle so we can release it later.\r
+ If _handle Then Release _handle\r
+ _handle = it.item_lparam\r
+ \r
+ _item=SendMessageW(_tree,TVM_INSERTITEMW,0,Int Byte Ptr it)\r
+ \r
+ MemFree it.item_pszText\r
+ \r
+ 'Fix for tree-view parent status update problem.\r
+ If Not tmpParentHadKids Then _parent.RedrawNode()\r
+ \r
+ Return _item\r
+ \r
+ EndMethod\r
+ \r
+ Method RedrawNode()\r
+\r
+ If _item = TVI_ROOT Then\r
+ InvalidateRect _tree, Null, True\r
+ Else\r
+ Local Rect[] = [_item,0,0,0]\r
+ If SendMessageW(_tree, TVM_GETITEMRECT, False, Int Byte Ptr Rect) Then\r
+ InvalidateRect _tree, Rect, True\r
+ EndIf\r
+ EndIf\r
+\r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ 'At the moment, nodes don't support tooltips.\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_NODE\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsTreeView Extends TWindowsGadget\r
+\r
+ Field _root:TWindowsTreeNode\r
+ Field _selected:TWindowsTreeNode\r
+ Field _icons:TWindowsIconStrip\r
+\r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="")\r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ \r
+ Self.style = style\r
+ xstyle=WS_EX_CLIENTEDGE\r
+ wstyle=WS_CHILD|TVS_HASLINES|TVS_HASBUTTONS|TVS_LINESATROOT|TVS_SHOWSELALWAYS|TVS_NOTOOLTIPS|WS_CLIPSIBLINGS\r
+ If Not(style&TREEVIEW_DRAGNDROP) wstyle:|TVS_DISABLEDRAGDROP\r
+ \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"SysTreeView32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ If TWindowsGUIDriver.CheckCommonControlVersion() Then SendMessageW hwnd, TVM_SETEXTENDEDSTYLE, TVS_EX_DOUBLEBUFFER, TVS_EX_DOUBLEBUFFER\r
+ Register GADGET_TREEVIEW,hwnd \r
+ _root=New TWindowsTreeNode.CreateRoot(Self) \r
+ \r
+ If TWindowsGUIDriver._explorerstyle Then UseExplorerTheme()\r
+ \r
+ Return Self\r
+ \r
+ EndMethod\r
+\r
+ Method SetIconStrip(iconstrip:TIconStrip) \r
+ _icons=TWindowsIconStrip(iconstrip)\r
+ SendMessageW _hwnd,TVM_SETIMAGELIST,TVSIL_NORMAL,_icons._imagelist\r
+ EndMethod\r
+\r
+ Method SetColor(r,g,b)\r
+ SendMessageW _hwnd,TVM_SETBKCOLOR,0,(b Shl 16)|(g Shl 8)|r\r
+ EndMethod\r
+\r
+ Method RemoveColor()\r
+ SendMessageW _hwnd,TVM_SETBKCOLOR,1,0\r
+ EndMethod\r
+\r
+ Method SetTextColor(r,g,b)\r
+ SendMessageW _hwnd,TVM_SETTEXTCOLOR,0,(b Shl 16)|(g Shl 8)|r\r
+ EndMethod\r
+\r
+ Method RootNode:TGadget()\r
+ Return _root\r
+ EndMethod\r
+\r
+ Method SelectedNode:TGadget()\r
+ Return _selected\r
+ EndMethod\r
+\r
+ Method CountKids()\r
+ Return _root.CountKids()\r
+ EndMethod\r
+ \r
+ Method OnNotify(wp,lp)\r
+ Local nmhdr:Int Ptr\r
+ Local itemnew:Int Ptr\r
+ Local node:TWindowsTreeNode\r
+ \r
+ Super.OnNotify(wp,lp) 'Tool-tips\r
+ \r
+ nmhdr=Int Ptr(lp)\r
+ Select nmhdr[2] 'code\r
+ \r
+ 'MSLU glitch requires handling of ANSI equivalent\r
+ Case TVN_SELCHANGEDW, TVN_SELCHANGEDA\r
+ itemnew=nmhdr+14 'Int Ptr(nmhdr[5]) 'itemNew\r
+ If itemnew[1]=TVI_ROOT 'hItem\r
+ _selected=_root\r
+ Else\r
+ _selected=TWindowsTreeNode(HandleToObject(itemnew[9])) 'lParaM\r
+ EndIf\r
+ PostGuiEvent EVENT_GADGETSELECT,0,0,0,0,_selected\r
+ \r
+ Case TVN_ITEMEXPANDEDW, TVN_ITEMEXPANDEDA\r
+ itemnew=nmhdr+14 'Int Ptr(nmhdr[5]) 'itemNew.TVITEM\r
+ If itemnew[1]=TVI_ROOT 'hItem\r
+ node=_root\r
+ Else\r
+ node=TWindowsTreeNode(HandleToObject(itemnew[9] )) 'lParaM\r
+ EndIf\r
+ Select nmhdr[3] 'action itemnew[2]&TVIS_EXPANDED 'state\r
+ Case 1\r
+ PostGuiEvent EVENT_GADGETCLOSE,0,0,0,0,node\r
+ node._expanded=False\r
+ Case 2\r
+ PostGuiEvent EVENT_GADGETOPEN,0,0,0,0,node\r
+ node._expanded=True\r
+ End Select\r
+ Return True\r
+ \r
+ Case TVN_BEGINDRAGW, TVN_BEGINRDRAGW, TVN_BEGINDRAGA, TVN_BEGINRDRAGA\r
+ \r
+ If (style&TREEVIEW_DRAGNDROP) Then\r
+ \r
+ Local data% = 1\r
+ If (nmhdr[2] = TVN_BEGINRDRAGW) Or (nmhdr[2] = TVN_BEGINRDRAGA) Then data = 2\r
+ \r
+ itemnew=nmhdr+14 'Int Ptr(nmhdr[5]) 'itemNew\r
+ \r
+ If itemnew[1]<>TVI_ROOT Then\r
+ TGadget.dragGadget[data-1]=TWindowsTreeNode(HandleToObject(itemnew[9]))\r
+ PostGuiEvent EVENT_GADGETDRAG, data, KeyMods(), itemnew[10], itemnew[11], TGadget.dragGadget[data-1]\r
+ Else\r
+ TGadget.dragGadget[data-1]=Null\r
+ EndIf\r
+ \r
+ EndIf\r
+ \r
+ Case NM_DBLCLK, NM_RETURN\r
+ PostGuiEvent EVENT_GADGETACTION,0,0,0,0,_selected\r
+ \r
+ Case NM_RCLICK\r
+ Local Rect[4]\r
+ Local pt[2]\r
+ Local hittest[4]\r
+ Local item[10]\r
+ GetWindowRect _hwnd,Rect\r
+ GetCursorPos_ pt\r
+ hittest[0]=pt[0]-Rect[0]\r
+ hittest[1]=pt[1]-Rect[1]\r
+ If SendMessageW(_hwnd,TVM_HITTEST,0,Int Byte Ptr(hittest))\r
+ If hittest[3]=TVI_ROOT\r
+ node=_root\r
+ Else\r
+ item[0]=TVIF_PARAM\r
+ item[1]=hittest[3]\r
+ SendMessageW _hwnd,TVM_GETITEMW,0,Int Byte Ptr(item)\r
+ node=TWindowsTreeNode(HandleToObject(item[9]))\r
+ EndIf\r
+ PostGuiEvent EVENT_GADGETMENU,0,hittest[0],hittest[1],0,node\r
+ EndIf\r
+ Return True\r
+ \r
+ EndSelect\r
+ EndMethod\r
+\r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ 'If we are using Vista's common controls, then the treeview will be double-buffered and so\r
+ 'we don't need to clear the background when redrawing (performance tweak).\r
+ Case WM_ERASEBKGND\r
+ If TWindowsGUIDriver.CheckCommonControlVersion() >= 2 Then Return 1\r
+ EndSelect\r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ EndMethod\r
+\r
+ Method UseExplorerTheme()\r
+ \r
+ If TWindowsGUIDriver.CheckCommonControlVersion() And SetWindowThemeW Then\r
+ SetWindowThemeW( _hwnd, _wstrExplorer, Null )\r
+ SendMessageW _hwnd, TVM_SETEXTENDEDSTYLE, TVS_EX_FADEINOUTEXPANDOS, TVS_EX_FADEINOUTEXPANDOS\r
+ EndIf\r
+ \r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_TREEVIEW\r
+ EndMethod\r
+\r
+EndType\r
+\r
+Type TWindowsLabel Extends TWindowsGadget\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ \r
+ Self.style = style\r
+ wstyle=WS_CHILD|SS_NOPREFIX|WS_CLIPSIBLINGS|SS_NOTIFY\r
+ \r
+ Select style&24\r
+ Case LABEL_LEFT wstyle:|SS_LEFT\r
+ Case LABEL_RIGHT wstyle:|SS_RIGHT\r
+ Case LABEL_CENTER wstyle:|SS_CENTER\r
+ End Select\r
+ Select style&7\r
+ Case LABEL_FRAME wstyle:|WS_BORDER\r
+ Case LABEL_SUNKENFRAME wstyle:|SS_SUNKEN\r
+ Case LABEL_SEPARATOR wstyle:|SS_SUNKEN|SS_GRAYRECT\r
+ End Select\r
+ \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"STATIC","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ Register GADGET_LABEL,hwnd\r
+ \r
+ Return Self\r
+ EndMethod\r
+ \r
+ Method SetArea(x,y,w,h)\r
+ If ((style & 7) = LABEL_SEPARATOR) Then\r
+ If (w > h) Then h = 2 Else w = 2\r
+ EndIf\r
+ Return Super.SetArea(x,y,w,h)\r
+ EndMethod\r
+ \r
+ Method SetText(Text$)\r
+ If ((style & 7) <> LABEL_SEPARATOR) Then Return Super.SetText(Text)\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ Case WM_ERASEBKGND\r
+ Return 1\r
+ EndSelect\r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_LABEL\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsSlider Extends TWindowsGadget\r
+ Field _slidertype,_ishorizontal,_visible = 5,_total = 10,_value\r
+\r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,class$\r
+ Local hwnd,parent,hotkey\r
+ \r
+ _slidertype=style&$fffc\r
+ _ishorizontal=style&SLIDER_HORIZONTAL\r
+ \r
+ Self.style = style\r
+ wstyle=WS_CHILD|WS_CLIPSIBLINGS|WS_CLIPCHILDREN\r
+ parent=group.query(QUERY_HWND_CLIENT) \r
+ Select _slidertype\r
+ Case SLIDER_SCROLLBAR\r
+ If _ishorizontal wstyle:|SBS_HORZ;Else wstyle:|SBS_VERT\r
+ class$="SCROLLBAR"\r
+ Case SLIDER_TRACKBAR\r
+ wstyle:|TBS_AUTOTICKS|WS_TABSTOP\r
+ xstyle:|WS_EX_COMPOSITED 'Reduces flicker when resizing (doesn't like scrollbars/up-down controls)\r
+ If _ishorizontal wstyle:|TBS_HORZ Else wstyle:|TBS_VERT\r
+ class$=TRACKBAR_CLASS\r
+ Case SLIDER_STEPPER\r
+ If _ishorizontal wstyle:|UDS_HORZ\r
+ class$="msctls_updown32"\r
+ Default\r
+ Return Null\r
+ End Select\r
+ \r
+ hwnd=CreateWindowExW(xstyle,class,"",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ Register GADGET_SLIDER,hwnd\r
+ RefreshLook()\r
+ \r
+ Return Self \r
+ EndMethod\r
+\r
+ Method SetRange(visible,total)\r
+ _visible = visible\r
+ _total = total\r
+ Local tmpEnabled:Int = Not( State() & STATE_DISABLED )\r
+ Desensitize()\r
+ Select _slidertype\r
+ Case SLIDER_SCROLLBAR\r
+ Local info:SCROLLINFO=New SCROLLINFO\r
+ info.cbSize=SizeOf(SCROLLINFO)\r
+ info.fMask=SIF_PAGE|SIF_RANGE\r
+ info.nMax=total-1\r
+ info.nPage=visible \r
+ SendMessageW _hwnd,SBM_SETSCROLLINFO,True,Int Byte Ptr info\r
+ Case SLIDER_TRACKBAR\r
+ \r
+ SendMessageW _hwnd,TBM_SETRANGEMIN,False,visible\r
+ SendMessageW _hwnd,TBM_SETRANGEMAX,True,total\r
+ \r
+ ' Aesthetic tweak that should stop black tick bands forming when\r
+ ' large ranges are used on small trackbars.\r
+ \r
+ Local tmpFirstTick% = SendMessageW( _hwnd, TBM_GETTICPOS, 0, 0 )\r
+ Local tmpNumTicks% = SendMessageW( _hwnd, TBM_GETNUMTICS, 0, 0)\r
+ Local tmpLastTick% = SendMessageW( _hwnd, TBM_GETTICPOS, tmpNumTicks-3, 0 )\r
+ If Not( tmpLastTick < 0 Or tmpFirstTick < 0 Or (total-visible-2) < 1) Then\r
+ If (tmpLastTick-tmpFirstTick)/(total-visible-2) < 4 Then\r
+ SendMessageW( _hwnd, TBM_CLEARTICS, True, 0 )\r
+ EndIf\r
+ EndIf\r
+ \r
+ Case SLIDER_STEPPER\r
+ SendMessageW _hwnd,UDM_SETRANGE32,visible,total\r
+ End Select\r
+ _value = GetProp()\r
+ SetEnabled(tmpEnabled)\r
+ Sensitize() \r
+ EndMethod\r
+ \r
+ Method SetProp(value)\r
+ Desensitize()\r
+ Select _slidertype\r
+ Case SLIDER_SCROLLBAR\r
+ Local info:SCROLLINFO=New SCROLLINFO\r
+ info.cbSize=SizeOf(SCROLLINFO)\r
+ info.fMask=SIF_POS\r
+ info.nPos=value\r
+ SendMessageW _hwnd,SBM_SETSCROLLINFO,True,Int Byte Ptr info\r
+ Case SLIDER_TRACKBAR\r
+ If _ishorizontal Then\r
+ SendMessageW _hwnd,TBM_SETPOS,True,value\r
+ Else\r
+ 'Flip the value so that the scale starts from the bottom\r
+ SendMessageW _hwnd,TBM_SETPOS,True,_visible + _total - value\r
+ EndIf\r
+ Case SLIDER_STEPPER\r
+ SendMessageW _hwnd,UDM_SETPOS,True,value\r
+ End Select\r
+ _value = value\r
+ Sensitize() \r
+ EndMethod\r
+ \r
+ Method GetProp()\r
+ Local value\r
+ Select _slidertype\r
+ Case SLIDER_SCROLLBAR\r
+ value=GetScrollPos(_hwnd,SB_CTL)\r
+ Case SLIDER_TRACKBAR\r
+ value=SendMessageW(_hwnd,TBM_GETPOS,0,0)\r
+ 'Flip the value so that the scale starts from the bottom\r
+ If Not _ishorizontal Then value = _visible + _total - value\r
+ Case SLIDER_STEPPER\r
+ value=SendMessageW(_hwnd,UDM_GETPOS32,0,Null)\r
+ End Select \r
+ Return value\r
+ EndMethod\r
+\r
+ Method OnCommand(msg,wp)\r
+ If _slidertype=SLIDER_SCROLLBAR\r
+ If msg=WM_COMMAND Return\r
+ Local info:SCROLLINFO=New SCROLLINFO\r
+ info.cbSize=SizeOf(SCROLLINFO)\r
+ Select wp&$ffff\r
+ Case SB_THUMBTRACK,SB_THUMBPOSITION\r
+ info.fMask=SIF_TRACKPOS\r
+ SendMessageW _hwnd,SBM_GETSCROLLINFO,0,Int Byte Ptr info\r
+ SetScrollPos _hwnd,SB_CTL,info.nTrackPos,True\r
+ Default\r
+ info.fMask=SIF_POS|SIF_PAGE|SIF_RANGE\r
+ SendMessageW _hwnd,SBM_GETSCROLLINFO,0,Int Byte Ptr info\r
+ Local pos=info.nPos\r
+ Local vis=info.nPage\r
+ Select wp&$ffff\r
+ Case SB_LINEUP pos:-1\r
+ Case SB_LINEDOWN pos:+1\r
+ Case SB_PAGEUP pos:-vis\r
+ Case SB_PAGEDOWN pos:+vis\r
+ Default Return 0\r
+ End Select\r
+ SetScrollPos _hwnd,SB_CTL,pos,True\r
+ End Select\r
+ EndIf\r
+ Local index=GetProp()\r
+ If (index <> _value) Then\r
+ PostGuiEvent EVENT_GADGETACTION,index\r
+ _value = index\r
+ EndIf\r
+ Return 1\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ Case WM_ERASEBKGND\r
+ Return 1\r
+ EndSelect\r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ EndMethod\r
+ \r
+ Method RefreshLook()\r
+ Super.RefreshLook()\r
+ SetRange(_visible,_total)\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_SLIDER\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsProgressBar Extends TWindowsGadget\r
+\r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,parent\r
+ Self.style = style\r
+ wstyle=WS_CHILD|PBS_SMOOTH|WS_CLIPSIBLINGS\r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ hwnd=CreateWindowExW(xstyle,"msctls_progress32","",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ Register GADGET_PROGBAR,hwnd\r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method SetValue(value#)\r
+ SendMessageW _hwnd,PBM_SETPOS,value*100,0\r
+ EndMethod\r
+ \r
+ Method SetColor(r,g,b)\r
+ 'Only works in Classic mode, but it's better than nothing.\r
+ SendMessageW _hwnd,PBM_SETBKCOLOR ,0,(b Shl 16)|(g Shl 8)|r\r
+ EndMethod\r
+\r
+ Method RemoveColor()\r
+ 'Only works in Classic mode, but it's better than nothing.\r
+ SendMessageW _hwnd,PBM_SETBKCOLOR ,1,0\r
+ EndMethod\r
+\r
+ Method SetTextColor(r,g,b)\r
+ 'Only works in Classic mode, but it's better than nothing.\r
+ SendMessageW _hwnd,PBM_SETBARCOLOR ,0,(b Shl 16)|(g Shl 8)|r\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_PROGBAR\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsPanel Extends TWindowsGadget\r
+\r
+ Const PANELPANEL=0\r
+ Const PANELGROUP=1\r
+ Const PANELCANVAS=2\r
+\r
+ Field _type\r
+ Field _alpha#=1.0\r
+ Field _bitmapwidth,_bitmapheight,_bitmapflags\r
+ Field _canvas:TGraphics\r
+ Field _hasalpha\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Local xstyle,wstyle,hotkey\r
+ Local hwnd,client,parent\r
+ Self.style = style\r
+ \r
+ parent=group.query(QUERY_HWND_CLIENT)\r
+ If (style&3=PANEL_GROUP) Then\r
+ _type=PANELGROUP\r
+ hwnd=CreateWindowExW(WS_EX_CONTROLPARENT,"BUTTON","",BS_GROUPBOX|WS_CHILD|WS_CLIPSIBLINGS|WS_CLIPCHILDREN,0,0,0,0,parent,0,GetModuleHandleW(Null),Null )\r
+ client=CreateWindowExW(WS_EX_CONTROLPARENT,TWindowsGUIDriver.ClassName(),"",WS_CHILD|WS_VISIBLE|WS_CLIPCHILDREN|WS_CLIPSIBLINGS,0,0,0,0,hwnd,0,GetModuleHandleW(Null),Null)\r
+ Else\r
+ _type=PANELPANEL\r
+ xstyle=WS_EX_CONTROLPARENT\r
+ wstyle=WS_CHILD|WS_CLIPCHILDREN|WS_CLIPSIBLINGS\r
+ Select (style&3)\r
+ Case PANEL_SUNKEN xstyle:|WS_EX_CLIENTEDGE\r
+ Case PANEL_RAISED xstyle:|WS_EX_WINDOWEDGE ; wstyle:|WS_DLGFRAME\r
+ EndSelect\r
+ If (style&PANEL_CANVAS) Then _type=PANELCANVAS \r
+ hwnd=CreateWindowExW(xstyle,TWindowsGUIDriver.ClassName(),"",wstyle,0,0,0,0,parent,hotkey,GetModuleHandleW(Null),Null)\r
+ EndIf\r
+ \r
+ Register GADGET_PANEL,hwnd,client\r
+ If (style & PANEL_ACTIVE) Then sensitivity = SENSITIZE_ALL\r
+ \r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method SetAlpha( alpha# )\r
+ _alpha=alpha\r
+ RedrawGadget(Self)\r
+ EndMethod\r
+ \r
+ Method Activate( cmd )\r
+ Select cmd\r
+ Case ACTIVATE_REDRAW\r
+ If (_type = PANELCANVAS) Then\r
+ InvalidateRect _hwnd, Null, False\r
+ Return True\r
+ EndIf\r
+ EndSelect\r
+ Return Super.Activate(cmd)\r
+ EndMethod\r
+ \r
+ Method SetPixmap(pixmap:TPixmap,flags)\r
+ If _bitmap Then DeleteObject _bitmap;_bitmap = 0\r
+ If pixmap Then\r
+ If pixmap.format=PF_RGBA8888 Or pixmap.format=PF_BGRA8888\r
+ _bitmap=TWindowsGraphic.PreMultipliedBitmapFromPixmap32( pixmap )\r
+ EndIf\r
+ If _bitmap\r
+ _hasalpha=True\r
+ Else\r
+ _bitmap=TWindowsGraphic.BitmapFromPixmap( pixmap, False )\r
+ _hasalpha=False\r
+ EndIf\r
+ _bitmapflags=flags\r
+ _bitmapwidth=pixmap.width\r
+ _bitmapheight=pixmap.height\r
+ EndIf\r
+ RedrawGadget(Self)\r
+ EndMethod\r
+ \r
+ Method AttachGraphics:TGraphics( flags )\r
+ _canvas=brl.Graphics.AttachGraphics( _hwnd,flags )\r
+ EndMethod\r
+ \r
+ Method CanvasGraphics:TGraphics()\r
+ Return _canvas\r
+ EndMethod\r
+ \r
+ Method Free()\r
+ If _canvas Then CloseGraphics(_canvas);_canvas = Null\r
+ Super.Free()\r
+ EndMethod\r
+ \r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ \r
+ Case WM_ERASEBKGND\r
+ \r
+ If _type = PANELCANVAS Then Return 1\r
+ \r
+ Local hdc=wp,hdcCanvas,hdcBitmap,srcw,srch,x,y,xoffset,yoffset\r
+ Local clientRect[4], updateRect[4], clipRect[4], windowRect[4]\r
+ \r
+ GetClipBox( hdc, clipRect )\r
+ GetWindowRect( hwnd, windowRect)\r
+ GetClientRect( hwnd, clientRect )\r
+ \r
+ If Not GetUpdateRect( hwnd, updateRect, False) Then updateRect = clipRect\r
+ If IsRectEmpty(updateRect) Then updateRect = [0,0,windowRect[2]-windowRect[0],windowRect[3]-windowRect[1]]\r
+ \r
+ 'If we are drawing a bitmap or using alpha then let's do some double-buffering stuff\r
+ \r
+ If (hwnd <> _hwndclient) And ((_bitmap And _bitmapwidth And _bitmapheight) Or _alpha<1.0) Then\r
+ \r
+ hdc = CreateCompatibleDC(wp)\r
+ hdcCanvas = CreateCompatibleBitmap(wp,windowRect[2]-windowRect[0],windowRect[3]-windowRect[1])\r
+ SelectObject( hdc, hdcCanvas )\r
+ \r
+ EndIf\r
+ \r
+ 'Fill the drawing context with the background colour, or the background of the parent\r
+ \r
+ If BgBrush() And (hwnd <> _hwndclient) Then FillRect(hdc,updateRect,BgBrush()) Else DrawParentBackground(hdc,hwnd)\r
+ \r
+ 'If we aren't drawing to a bitmap or using alpha, then we can return now.\r
+ \r
+ If Not ((hwnd <> _hwndclient) And ((_bitmap And _bitmapwidth And _bitmapheight) Or _alpha<1.0)) Then Return 1\r
+ \r
+ If _bitmap And _bitmapwidth And _bitmapheight\r
+ hdcBitmap=CreateCompatibleDC(hdc)\r
+ SelectObject(hdcBitmap,_bitmap)\r
+ srcw=_bitmapwidth\r
+ srch=_bitmapheight\r
+ Select (_bitmapflags & (GADGETPIXMAP_ICON-1))\r
+ Case PANELPIXMAP_TILE\r
+ While y<windowRect[RECT_BOTTOM]-windowRect[RECT_TOP]\r
+ x=0\r
+ While x<windowRect[RECT_RIGHT]-windowRect[RECT_LEFT]\r
+ If _hasalpha\r
+ AlphaBlend_ hdc,x,y,srcw,srch,hdcBitmap,0,0,srcw,srch,$01ff0000\r
+ Else\r
+ BitBlt hdc,x,y,srcw,srch,hdcBitmap,0,0,ROP_SRCCOPY\r
+ EndIf\r
+ x:+srcw\r
+ Wend\r
+ y:+srch\r
+ Wend\r
+ Case PANELPIXMAP_CENTER\r
+ x=(windowRect[RECT_RIGHT]-windowRect[RECT_LEFT]-srcw)/2\r
+ y=(windowRect[RECT_BOTTOM]-windowRect[RECT_TOP]-srch)/2\r
+ If _hasalpha\r
+ AlphaBlend_ hdc,x,y,srcw,srch,hdcBitmap,0,0,srcw,srch,$01ff0000\r
+ Else\r
+ BitBlt hdc,x,y,srcw,srch,hdcBitmap,0,0,ROP_SRCCOPY\r
+ EndIf\r
+ \r
+ Case PANELPIXMAP_FIT, PANELPIXMAP_FIT2\r
+ \r
+ Local mx# = Float(windowRect[RECT_RIGHT]-windowRect[RECT_LEFT])/srcw\r
+ Local my# = Float(windowRect[RECT_BOTTOM]-windowRect[RECT_TOP])/srch\r
+ \r
+ If mx>my Then\r
+ If (_bitmapflags&(GADGETPIXMAP_ICON-1)) = PANELPIXMAP_FIT Then mx=my Else my=mx\r
+ EndIf\r
+ Local w=mx*srcw\r
+ Local h=mx*srch\r
+ x=(windowRect[RECT_RIGHT]-windowRect[RECT_LEFT]-w)/2\r
+ y=(windowRect[RECT_BOTTOM]-windowRect[RECT_TOP]-h)/2\r
+ SetStretchBltMode hdc,COLORONCOLOR\r
+\r
+ If _hasalpha\r
+ AlphaBlend_ hdc,x,y,w,h,hdcBitmap,0,0,srcw,srch,$01ff0000\r
+ Else\r
+ StretchBlt hdc,x,y,w,h,hdcBitmap,0,0,srcw,srch,ROP_SRCCOPY\r
+ EndIf\r
+\r
+ Case PANELPIXMAP_STRETCH\r
+ SetStretchBltMode hdc,COLORONCOLOR\r
+\r
+ If _hasalpha\r
+ AlphaBlend_ hdc,0,0,windowRect[RECT_RIGHT]-windowRect[RECT_LEFT],windowRect[RECT_BOTTOM]-windowRect[RECT_TOP],hdcBitmap,0,0,srcw,srch,$01ff0000\r
+ Else\r
+ StretchBlt hdc,0,0,windowRect[RECT_RIGHT]-windowRect[RECT_LEFT],windowRect[RECT_BOTTOM]-windowRect[RECT_TOP],hdcBitmap,0,0,srcw,srch,ROP_SRCCOPY\r
+ EndIf\r
+ \r
+ EndSelect \r
+ \r
+ DeleteDC(hdcBitmap)\r
+ \r
+ EndIf\r
+ \r
+ If _alpha < 1.0 Then\r
+ \r
+ DrawParentBackground( wp, hwnd )\r
+ Local blendfunction = ((Int(_alpha*255)&$FF) Shl 16)\r
+ AlphaBlend_(wp,updateRect[0],updateRect[1],updateRect[2]-updateRect[0],updateRect[3]-updateRect[1],hdc,updateRect[0],updateRect[1],updateRect[2]-updateRect[0],updateRect[3]-updateRect[1],blendfunction)\r
+ \r
+ Else\r
+ \r
+ BitBlt(wp,0,0,windowRect[2]-windowRect[0],WindowRect[3]-windowRect[1],hdc,0,0,ROP_SRCCOPY)\r
+ \r
+ EndIf\r
+ \r
+ Assert hdc <> wp, "hdc == wp! Please post a MaxGUI bug report."\r
+ \r
+ DeleteObject( hdcCanvas )\r
+ DeleteDC( hdc )\r
+ \r
+ Return 1\r
+ \r
+ Case WM_PAINT\r
+ \r
+ Select _type\r
+ Case PANELCANVAS\r
+ PostGuiEvent EVENT_GADGETPAINT\r
+ ValidateRect _hwnd, Null\r
+ Return 1\r
+ EndSelect\r
+ \r
+ Case WM_LBUTTONDOWN\r
+ \r
+ SetFocus Query(QUERY_HWND_CLIENT)\r
+ \r
+ End Select\r
+ \r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ \r
+ EndMethod\r
+ \r
+ Method FlushBrushes(pRecurse:Int = True)\r
+ Super.FlushBrushes()\r
+ If Not pRecurse Then Return\r
+ For Local tmpGadget:TWindowsGadget = EachIn kids\r
+ tmpGadget.FlushBrushes()\r
+ Next\r
+ EndMethod\r
+ \r
+ Method ClientWidth()\r
+ If _hwndClient Then Return (Super.ClientWidth()-8) Else Return Super.ClientWidth()\r
+ EndMethod\r
+ \r
+ Method ClientHeight()\r
+ If _hwndClient Then Return (Super.ClientHeight()-20) Else Return Super.ClientHeight()\r
+ EndMethod\r
+ \r
+ Method RethinkClient(forceRedraw:Int = False)\r
+ If _hwndClient Then\r
+ MoveWindow( _hwndClient, 4+_clientX,16+_clientY,ClientWidth(),ClientHeight(),forceRedraw)\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ If _type = PANELCANVAS Then Return GADGET_CANVAS Else Return GADGET_PANEL\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+\r
+Type TWindowsHTMLView Extends TWindowsGadget\r
+\r
+ Field mshtml\r
+ Field browser:IWebBrowser2\r
+\r
+ Field IID_IHTMLDocument2:GUID=New GUID\r
+ \r
+ Method Create:TWindowsGadget(group:TGadget,style,Text$="") \r
+ Self.style = style\r
+ Local parent=group.query(QUERY_HWND_CLIENT)\r
+ mshtml=msHtmlCreate(Self,TWindowsGUIDriver.ClassName(),parent,style) \r
+ browser=msHTMLBrowser(mshtml)\r
+ Register GADGET_HTMLVIEW,msHtmlHwnd(mshtml)\r
+ \r
+ Local res = IIDFromString(IHTMLDocument2_UUID,IID_IHTMLDocument2) \r
+ \r
+ Return Self\r
+ EndMethod\r
+ \r
+ Method Rethink()\r
+ msHtmlSetShape mshtml,xpos,ypos,width,height\r
+ EndMethod \r
+\r
+ Method SetText(Text$) 'sets document url\r
+ If Text Then msHtmlGo mshtml,Text\r
+ EndMethod\r
+ \r
+ Method GetText$()\r
+ Local bstr:Short Ptr\r
+ browser.lfget_LocationURL(Varptr bstr)\r
+ Local result$ = String.FromWString(bstr)\r
+ SysFreeString(bstr)\r
+ Return result\r
+ EndMethod\r
+ \r
+ Method GetTitleText$() 'returns document title\r
+ \r
+ Local bstr:Short Ptr\r
+ Local res\r
+ \r
+ Local disp:IDispatch\r
+ Local doc:IHTMLDOCUMENT2\r
+ \r
+ res=browser.lfget_Document(Varptr disp)\r
+ If res RuntimeError "no document" \r
+ \r
+ res=disp.QueryInterface(IID_IHTMLDocument2,Varptr doc)\r
+ If res RuntimeError "no document2 interface"\r
+ \r
+ If doc\r
+ doc.get_Title(Varptr bstr)\r
+ Else \r
+ browser.lfget_LocationName(Varptr bstr)\r
+ EndIf\r
+ \r
+ Local result$ = String.FromWString(bstr)\r
+ SysFreeString(bstr)\r
+ Return result\r
+ \r
+ End Method\r
+Rem\r
+ Method Run$(script$)\r
+ Local res\r
+ Local disp:IDispatch\r
+ Local doc:IHTMLDOCUMENT2\r
+ Local win:IHTMLWindow2\r
+ Local result:VARIANT \r
+\r
+ res=browser.lfget_Document(Varptr disp)\r
+ If res RuntimeError "no document" \r
+ res=disp.QueryInterface(IID_IHTMLDocument2,Varptr doc)\r
+ If res RuntimeError "no document2 interface"\r
+ res=doc.get_parentWindow(Varptr win)\r
+ If res RuntimeError "no parent window"\r
+ result=New VARIANT\r
+ result.vt=VT_EMPTY\r
+ Local bstr:Short Ptr\r
+ bstr=SysAllocStringLen(script.toWString(),script.length)\r
+ res=win.execScript(bstr,Null,result)\r
+ SysFreeString bstr\r
+ Return res\r
+ End Method\r
+\r
+EndRem\r
+ Method Activate(cmd)\r
+ Return msHtmlActivate(mshtml,cmd)\r
+ EndMethod\r
+ \r
+ Method State()\r
+ Return msHtmlStatus(mshtml)\r
+ EndMethod\r
+ \r
+ Method Run$(script$)\r
+ msHtmlRun(mshtml,script)\r
+ EndMethod\r
+\r
+ Method WndProc(hwnd,msg,wp,lp)\r
+ Select msg\r
+ 'Reduces flicker on HTMLViews\r
+ Case WM_ERASEBKGND\r
+ Return 1\r
+ EndSelect\r
+ Return Super.WndProc(hwnd,msg,wp,lp)\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_HTMLVIEW\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsMenu Extends TGadget\r
+ Field _hmenu\r
+ Field _pmenu\r
+ Field _item\r
+ Field _state\r
+ Field _tag\r
+ Field _hotkeycode\r
+ Field _modifier\r
+ Field _shortcut$\r
+ Field _hotkey:THotKey\r
+ Field _key = SetNewKey()\r
+ Field _iconBitmap\r
+ \r
+ Global iteminfo:MENUITEMINFOW\r
+ \r
+ Global keymap:TMap=New TMap 'key,gadget\r
+ Global keycount=100\r
+ \r
+ Method SetNewKey%()\r
+ keycount:+1\r
+ keymap.Insert( TIntWrapper.Create(keycount), Self )\r
+ Return keycount\r
+ EndMethod\r
+ \r
+ Function GetMenuFromKey:TWindowsMenu(pKey%)\r
+ Return TWindowsMenu(keymap.ValueForKey(TIntWrapper.Create(pKey)))\r
+ EndFunction\r
+ \r
+ Method SetText(pText$)\r
+ name = pText\r
+ EndMethod\r
+ \r
+ Method GetText$()\r
+ Return name\r
+ EndMethod\r
+ \r
+ Method Free()\r
+ Close\r
+ _setparent Null\r
+ keymap.Remove(TIntWrapper.Create(_key))\r
+ If _iconBitmap Then DeleteObject(_iconBitmap)\r
+ EndMethod\r
+ \r
+ Method DoLayout()\r
+ 'Don't do anything!\r
+ EndMethod\r
+ \r
+ Method State()\r
+ Return _state\r
+ EndMethod\r
+ \r
+ Method SetEnabled(enable)\r
+ If enable\r
+ If _pmenu EnableMenuItem(_pmenu,_item,MF_BYPOSITION|MF_ENABLED)\r
+ _state:&~STATE_DISABLED\r
+ Else\r
+ If _pmenu EnableMenuItem(_pmenu,_item,MF_BYPOSITION|MF_GRAYED)\r
+ _state:|STATE_DISABLED\r
+ EndIf\r
+ EndMethod\r
+\r
+ Method SetSelected(bool)\r
+ If bool\r
+ If _pmenu CheckMenuItem(_pmenu,_item,MF_BYPOSITION|MF_CHECKED)\r
+ _state:|STATE_SELECTED\r
+ Else\r
+ If _pmenu CheckMenuItem(_pmenu,_item,MF_BYPOSITION|MF_UNCHECKED)\r
+ _state:&~STATE_SELECTED\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method SetHotKey(keycode,modifier)\r
+ _hotkeycode=keycode\r
+ _modifier=modifier\r
+ \r
+ Local pre$, suf$, m$\r
+ \r
+ If LocalizationMode()&LOCALIZATION_ON Then\r
+ pre="{{"\r
+ suf="}}"\r
+ EndIf\r
+ \r
+ If keycode>=KEY_0 And keycode<=KEY_9\r
+ m$=Chr(keycode)\r
+ ElseIf keycode>=KEY_A And keycode<=KEY_Z\r
+ m$=Chr(keycode)\r
+ ElseIf keycode>=KEY_F1 And keycode<=KEY_F12\r
+ m$="F"+(keycode+1-KEY_F1)\r
+ ElseIf keycode>=KEY_NUM0 And keycode<=KEY_NUM9\r
+ m$="Num "+(keycode+1-KEY_NUM0)\r
+ Else\r
+ Select keycode\r
+ Case KEY_BACKSPACE;m = pre+"Backspace"+suf\r
+ Case KEY_TAB;m = pre+"Tab"+suf\r
+ Case KEY_ESCAPE;m = pre+"Esc"+suf\r
+ Case KEY_SPACE;m = pre+"Space"+suf\r
+ Case KEY_ENTER;m = pre+"Enter"+suf\r
+ Case KEY_PAGEUP;m = pre+"PageUp"+suf\r
+ Case KEY_PAGEDOWN;m = pre+"PageDown"+suf\r
+ Case KEY_END;m = pre+"End"+suf\r
+ Case KEY_HOME;m = pre+"Home"+suf\r
+ Case KEY_LEFT;m = pre+"Left"+suf\r
+ Case KEY_RIGHT;m = pre+"Right"+suf\r
+ Case KEY_UP;m = pre+"Up"+suf\r
+ Case KEY_DOWN;m = pre+"Down"+suf\r
+ Case KEY_INSERT;m = pre+"Insert"+suf\r
+ Case KEY_DELETE;m = pre+"Delete"+suf\r
+ Case KEY_TILDE;m = "~~"\r
+ Case KEY_MINUS;m = "-"\r
+ Case KEY_EQUALS;m = "="\r
+ Case KEY_OPENBRACKET;m = "["\r
+ Case KEY_CLOSEBRACKET;m = "]"\r
+ Case KEY_BACKSLASH;m = "\"\r
+ Case KEY_SEMICOLON;m = ";"\r
+ Case KEY_QUOTES;m = "'"\r
+ Case KEY_COMMA;m = ","\r
+ Case KEY_PERIOD;m = "."\r
+ Case KEY_SLASH;m = "/"\r
+ Case KEY_NUMMULTIPLY;m = "Num *"\r
+ Case KEY_NUMADD;m = "Num +"\r
+ Case KEY_NUMSUBTRACT;m = "Num -"\r
+ Case KEY_NUMDECIMAL;m = "Num ."\r
+ Case KEY_NUMDIVIDE;m = "Num /"\r
+ EndSelect\r
+ EndIf\r
+ \r
+ If m\r
+ If modifier&MODIFIER_SHIFT m$=pre+"Shift"+suf+"+"+m$\r
+ If modifier&MODIFIER_CONTROL m$=pre+"Ctrl"+suf+"+"+m$\r
+ If modifier&MODIFIER_ALT m$=pre+"Alt"+suf+"+"+m$\r
+ m="~t"+m\r
+ EndIf\r
+ _shortcut$=LocalizeString(m)\r
+ \r
+ If Not iteminfo\r
+ iteminfo=New MENUITEMINFOW\r
+ iteminfo.cbSize=SizeOf(iteminfo)\r
+ EndIf\r
+ iteminfo.fMask=MIIM_TYPE\r
+ iteminfo.dwTypeData=(name+_shortcut).toWString() \r
+ SetMenuItemInfoW _pmenu,_item,True,iteminfo\r
+ \r
+ MemFree iteminfo.dwTypeData\r
+ \r
+ Local ev:TEvent=CreateEvent( EVENT_MENUACTION, Self,_tag )\r
+ If _hotKey RemoveHotKey(_hotKey);_hotKey = Null\r
+ If keycode Then _hotkey=SetHotKeyEvent(keycode,modifier,ev,FindGadgetWindowHwnd(Self))\r
+ EndMethod\r
+ \r
+ Method Create:TWindowsMenu(group:TGadget,tag,Text$="")\r
+ If Not iteminfo Then\r
+ iteminfo=New MENUITEMINFOW\r
+ iteminfo.cbSize=SizeOf(iteminfo)\r
+ EndIf\r
+ name=Text\r
+ _tag=tag\r
+ Local window:TWindowsWindow = TWindowsWindow(group)\r
+ If window group=window.GetMenu()\r
+ _SetParent(group)\r
+ If (LocalizationMode()&LOCALIZATION_OVERRIDE) Then\r
+ LocalizeGadget(Self, name, "")\r
+ EndIf\r
+ Return Self \r
+ EndMethod\r
+ \r
+ Method Open(popup=False)\r
+ \r
+ Local dad:TWindowsMenu = TWindowsMenu(parent) \r
+ \r
+ If dad\r
+ _pmenu=dad._hmenu\r
+ If Not _pmenu Throw "Parent doesn't have a handle - the desktop heap may have run out of memory!"\r
+ _item=GetMenuItemCount(_pmenu)\r
+ If name\r
+ Local tmpWString:Short Ptr = (LocalizeString(name)+_shortcut).ToWString()\r
+ AppendMenuW _pmenu,MF_STRING,_key,tmpWString\r
+ MemFree tmpWString\r
+ Else\r
+ AppendMenuW _pmenu,MF_SEPARATOR,_key,Null\r
+ EndIf\r
+ If kids.count()\r
+ _hmenu=CreateMenu_()\r
+ Local tmpMenuInfo:MENUINFO = New MENUINFO\r
+ \r
+ tmpMenuInfo.fMask = MIM_APPLYTOSUBMENUS|MIM_STYLE\r
+ tmpMenuInfo.dwStyle = MNS_CHECKORBMP|MNS_MODELESS\r
+ SetMenuInfo(_hmenu, tmpMenuInfo)\r
+ \r
+ iteminfo.fMask=MIIM_SUBMENU\r
+ iteminfo.hSubMenu=_hmenu \r
+ SetMenuItemInfoW _pmenu,_item,True,iteminfo\r
+ EndIf\r
+ \r
+ If _state&STATE_DISABLED SetEnabled(False)\r
+ If _state&STATE_SELECTED SetSelected(True)\r
+ \r
+ If _iconBitmap Then SetMenuItemBitmaps(_pMenu,_key,MF_BYCOMMAND,_iconBitmap,Null)\r
+ Else\r
+ If popup\r
+ _hmenu=CreatePopupMenu()\r
+ Else\r
+ If kids _hmenu=CreateMenu_()\r
+ EndIf\r
+ EndIf\r
+ \r
+ For Local kid:TWindowsMenu = EachIn kids\r
+ kid.Open\r
+ Next\r
+ \r
+ EndMethod\r
+\r
+ Method FreeKids()\r
+ For Local kid:TWindowsMenu = EachIn kids\r
+ kid.Close\r
+ Next\r
+ EndMethod\r
+ \r
+ Method Close()\r
+ FreeKids()\r
+ If _hmenu\r
+ DestroyMenu _hmenu\r
+ _hmenu=0\r
+ EndIf\r
+ EndMethod\r
+ \r
+ Method SetPixmap(pixmap:TPixmap,pFlags)\r
+ If Not (pFlags & GADGETPIXMAP_ICON) Then Return\r
+ If _iconBitmap Then DeleteObject(_iconBitmap);_iconBitmap = 0\r
+ If pixmap Then\r
+ pixmap = PixmapWindow(pixmap,0,0,Min(GetSystemMetrics(SM_CXMENUCHECK),PixmapWidth(pixmap)),Min(GetSystemMetrics(SM_CYMENUCHECK),PixmapHeight(pixmap)))\r
+ If TWindowsGUIDriver.CheckCommonControlVersion() >= 2 Then\r
+ _iconBitmap = TWindowsGraphic.PreMultipliedBitmapFromPixmap32( pixmap )\r
+ Else\r
+ Local tmpRGB = GetSysColor(COLOR_MENU)\r
+ _iconBitmap = TWindowsGraphic.BitmapWithBackgroundFromPixmap32( pixmap, tmpRGB&$FF, (tmpRGB Shr 8) & $FF, (tmpRGB Shr 16) & $FF )\r
+ EndIf\r
+ EndIf\r
+ \r
+ EndMethod\r
+ \r
+ Method SetTooltip( pTooltip$ )\r
+ 'Menus shouldn't have tool-tips.\r
+ EndMethod\r
+ \r
+ Method Class()\r
+ Return GADGET_MENUITEM\r
+ EndMethod\r
+\r
+EndType\r
+\r
+Type TWindowsIconStrip Extends TIconStrip\r
+ \r
+ Field _blanks[]\r
+ Field _imagelist\r
+\r
+ Function DetectNotBlank(pixmap:TPixmap,xx,n)\r
+ Local c = pixmap.ReadPixel(xx,0), y\r
+ For Local x=0 Until n\r
+ For y=0 Until n\r
+ If pixmap.ReadPixel(xx+x,y)<>c Return True\r
+ Next\r
+ Next\r
+ EndFunction\r
+ \r
+ Method IsBlankIcon(n)\r
+ Return _blanks[n]\r
+ EndMethod\r
+ \r
+ Function RemoveMask(pixmap:TPixmap)\r
+ If pixmap.format<>( PF_RGBA8888 ) And pixmap.format<>( PF_BGRA8888 ) Return\r
+ Local w = pixmap.width, h = pixmap.height, y, c\r
+ For Local x=0 Until w\r
+ For y=0 Until h\r
+ c=pixmap.ReadPixel(x,y) \r
+ If c>=0 pixmap.WritePixel x,y,-1\r
+ Next\r
+ Next\r
+ EndFunction\r
+ \r
+ Function BuildImageList(pixmap:TPixmap)\r
+ Local bitmap,imagelist,sz,mask\r
+ sz=pixmap.height\r
+ If TWindowsGUIDriver.CheckCommonControlVersion() And (Pixmap.format=PF_RGBA8888 Or pixmap.format=PF_BGRA8888)\r
+ imagelist=ImageList_Create(sz,sz,ILC_COLOR32,0,1)\r
+ If imagelist\r
+ bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, True)\r
+ ImageList_Add(imagelist,bitmap,0)\r
+ EndIf\r
+ EndIf\r
+ If imagelist=0\r
+ bitmap=TWindowsGraphic.BitmapFromPixmap(pixmap, False)\r
+ mask=TWindowsGraphic.BitmapMaskFromPixmap(pixmap)\r
+ imagelist=ImageList_Create(sz,sz,ILC_COLOR24|ILC_MASK,0,1)\r
+ ImageList_Add(imagelist,bitmap,mask)\r
+ DeleteObject(mask)\r
+ EndIf\r
+ DeleteObject(bitmap)\r
+ Return imagelist\r
+ EndFunction\r
+\r
+ Function Create:TWindowsIconStrip(source:Object)\r
+ Local icons:TWindowsIconStrip\r
+ Local imagelist\r
+ Local n,i,sz\r
+ Local blanks[]\r
+ \r
+ 'Get a 24-bit pixmap from source \r
+ Local pix:TPixmap = TPixmap(source)\r
+ If Not pix pix = LoadPixmap(source)\r
+ If Not pix Return\r
+ \r
+ 'Detect blank icons in the set \r
+ sz=pix.height;If sz n=pix.width/sz\r
+ If n=0 Return \r
+ blanks=New Int[n]\r
+ For i=0 Until n\r
+ blanks[i]=Not DetectNotBlank(pix,i*sz,sz)\r
+ Next\r
+ \r
+ 'Build a Win32 Image-List\r
+ imagelist=BuildImageList(pix) \r
+ icons = New TWindowsIconStrip\r
+ icons.pixmap = pix\r
+ icons.count=n\r
+ icons._blanks=blanks\r
+ icons._imagelist=imagelist\r
+ \r
+ Return icons\r
+ EndFunction \r
+ \r
+ Function CreateBlank:TWindowsIconStrip()\r
+ Return Create(CreatePixmap(1,1,PF_BGR888))\r
+ EndFunction\r
+ \r
+ Method Delete()\r
+ If _imagelist Then\r
+ ImageList_Destroy(_imagelist)\r
+ _imagelist = 0\r
+ EndIf\r
+ EndMethod\r
+ \r
+EndType\r
+\r
+Type TWindowsFont Extends TGuiFont\r
+ \r
+ Method Load:TWindowsFont(_name$,_size:Double,_style)\r
+ \r
+ If handle Then DeleteObject handle;handle = 0\r
+ \r
+ Local cfweight = FW_NORMAL\r
+ Local cfsize = -LogicalUnitsFromSize( _size )\r
+ \r
+ If _style & FONT_BOLD cfweight=FW_BOLD\r
+ handle=CreateFontW( cfsize, 0,0,0,cfweight,..\r
+ (_style & FONT_ITALIC) ,..\r
+ (_style & FONT_UNDERLINE),..\r
+ (_style & FONT_STRIKETHROUGH),..\r
+ DEFAULT_CHARSET,..\r
+ OUT_DEFAULT_PRECIS,..\r
+ CLIP_DEFAULT_PRECIS,..\r
+ ANTIALIASED_QUALITY,..\r
+ DEFAULT_PITCH|FF_DONTCARE,..\r
+ _name.toWString())\r
+ \r
+ 'Now lets test to see whether the right font was found\r
+ \r
+ name = NameFromHandle(handle)\r
+ \r
+ 'If the font returned has a different name to that requested, let's try the symbol character set\r
+ \r
+ If name.ToLower() <> _name.ToLower() Then\r
+ Local tmpSymbolHandle = CreateFontW( cfsize, 0,0,0,cfweight,..\r
+ (_style & FONT_ITALIC) ,..\r
+ (_style & FONT_UNDERLINE),..\r
+ (_style & FONT_STRIKETHROUGH),..\r
+ SYMBOL_CHARSET,..\r
+ OUT_DEFAULT_PRECIS,..\r
+ CLIP_DEFAULT_PRECIS,..\r
+ ANTIALIASED_QUALITY,..\r
+ DEFAULT_PITCH|FF_DONTCARE,..\r
+ _name.toWString())\r
+ \r
+ Local strSymbolName:String = NameFromHandle(tmpSymbolHandle)\r
+ \r
+ 'If we now have a match, delete the first font returned and use the new symbol one.\r
+ \r
+ If strSymbolName.ToLower() = _name.ToLower() Then\r
+ DeleteObject handle\r
+ handle = tmpSymbolHandle\r
+ name = strSymbolName\r
+ Else\r
+ DeleteObject tmpSymbolHandle\r
+ EndIf\r
+ \r
+ EndIf\r
+ \r
+ size=_size\r
+ style=_style\r
+ \r
+ Return Self\r
+ \r
+ EndMethod\r
+ \r
+ Method LoadFromLogFont:TWindowsFont( pLogFont:LOGFONTW, pStyle% = 0, pSize:Double = 0:Double )\r
+ \r
+ If pLogFont.lfWeight>=FW_BOLD Then pStyle:| FONT_BOLD\r
+ If pLogFont.lfItalic Then pStyle:| FONT_ITALIC\r
+ If pLogFont.lfUnderline Then pStyle:| FONT_UNDERLINE\r
+ If pLogFont.lfStrikeOut Then pStyle:| FONT_STRIKETHROUGH\r
+ \r
+ style = pStyle\r
+ \r
+ If Not pSize Then pSize = SizeFromLogFont( pLogFont )\r
+ \r
+ size = pSize\r
+ \r
+ SetLogFontProperties( pLogFont, pStyle, pSize )\r
+ \r
+ name = String.FromWString( Varptr pLogFont.lfFaceName00 )\r
+ \r
+ If handle Then DeleteObject handle\r
+ handle = CreateFontIndirectW( pLogFont )\r
+ \r
+ Return Self\r
+ \r
+ EndMethod\r
+ \r
+ Method LoadFromHandle:TWindowsFont(hfont)\r
+ \r
+ Local tmpLogFont:LOGFONTW = New LOGFONTW\r
+ GetObjectW( hfont, SizeOf(LOGFONTW), tmpLogFont )\r
+ Return LoadFromLogFont( tmpLogFont )\r
+ \r
+ EndMethod\r
+ \r
+ Method CharWidth( charcode )\r
+ Local hdc=GetDC(0) \r
+ Local tfont=SelectObject( hdc,handle )\r
+ \r
+ Local width=8,widths[3]\r
+ \r
+ If GetCharABCWidthsW( hdc,charcode,charcode,widths )\r
+ width=widths[0]+widths[1]+widths[2]\r
+ Else If GetCharWidth32W( hdc,charcode,charcode,widths )\r
+ width=widths[0]\r
+ EndIf\r
+ \r
+ SelectObject hdc,tfont\r
+ ReleaseDC 0,hdc\r
+ \r
+ Return width\r
+ EndMethod\r
+ \r
+ Method GetMaxCharWidth() \r
+ Local hdc=GetDC(0)\r
+ Local tfont=SelectObject(hdc,handle)\r
+ Local tm:TEXTMETRIC=New TEXTMETRIC \r
+ GetTextMetricsW hdc,tm\r
+ SelectObject(hdc,tfont)\r
+ ReleaseDC(0,hdc) \r
+ Return tm.tmAveCharWidth\r
+ EndMethod\r
+ \r
+ Method Delete()\r
+ If handle Then DeleteObject handle\r
+ EndMethod\r
+ \r
+ Function Request:TWindowsFont(font:TGuiFont)\r
+ \r
+ Local lf:LOGFONTW = New LOGFONTW\r
+ Local cf:CHOOSEFONT = New CHOOSEFONT\r
+ \r
+ cf.lStructSize=SizeOf(cf)\r
+ cf.hwndOwner=TWindowsGUIDriver.GetActiveHwnd()\r
+ cf.lpLogFont=lf\r
+ cf.Flags=CF_BOTH\r
+ \r
+ If font\r
+ Local p:Short Ptr = Short Ptr(Varptr lf.lfFaceName00)\r
+ For Local i = 0 Until Min(font.name.length, 31)\r
+ p[i]=font.name[i]\r
+ Next\r
+ SetLogFontProperties( lf, font.style, font.size ) \r
+ cf.Flags:|CF_INITTOLOGFONTSTRUCT\r
+ EndIf\r
+ \r
+ Local hwnd = GetFocus()\r
+ Local n = ChooseFontW(cf)\r
+ SetFocus(hwnd)\r
+ If Not n Return\r
+ \r
+ Local style\r
+ If cf.nFontType&BOLD_FONTTYPE style:|FONT_BOLD\r
+ If cf.nFontType&ITALIC_FONTTYPE style:|FONT_ITALIC\r
+ Return New TWindowsFont.LoadFromLogFont( lf, style, cf.iPointSize/Double(10) )\r
+ \r
+ EndFunction\r
+ \r
+ Function DefaultFont:TWindowsFont( pFontSize:Double = 0, pFontStyle% = FONT_NORMAL )\r
+ \r
+ 'Attempts to get hold of the Windows themed font (typically Tahoma on XP, Segeo UI on Vista)\r
+ Local tmpNonClientMetrics:NONCLIENTMETRICSW = New NONCLIENTMETRICSW\r
+ \r
+ If SystemParametersInfoW And SystemParametersInfoW( SPI_GETNONCLIENTMETRICS, 0, Int Byte Ptr tmpNonClientMetrics, 0 ) Then\r
+ Local tmpLogFont:LOGFONTW = New LOGFONTW\r
+ MemCopy tmpLogFont, Varptr tmpNonClientMetrics.lfMessageFont_lfHeight, SizeOf(tmpLogFont)\r
+ Return New TWindowsFont.LoadFromLogFont( tmpLogFont, pFontStyle, pFontSize )\r
+ EndIf\r
+ \r
+ 'If these functions, for whatever reason, fail, then the default GUI font is used (typically MS Sans Serif).\r
+ 'Note: A font size of '8' has has been hard-coded in as no reliable substitute can be found, however this may cause\r
+ 'text to appear too small in some languages/lacalizations.\r
+ If pFontSize <= 0 Then pFontSize = 8\r
+ Return New TWindowsFont.Load( "MS Shell Dlg", pFontSize, pFontStyle )\r
+ \r
+ EndFunction\r
+ \r
+ Function NameFromHandle:String( pFntHandle:Int )\r
+ \r
+ Local hdc = GetDC(0), buffer:Short[512]\r
+ Local tfont = SelectObject(hdc,pFntHandle)\r
+ \r
+ If Not GetTextFaceW(hdc,buffer.length,buffer) buffer[0] = 0\r
+ \r
+ SelectObject(hdc, tfont)\r
+ ReleaseDC(0,hdc)\r
+ \r
+ Return String.FromWString(buffer)\r
+ \r
+ EndFunction\r
+ \r
+ Function LogicalUnitsFromSize( pSize:Double )\r
+ \r
+ Local tmpDC:Int = GetDC(0)\r
+ Local tmpSize:Int = (pSize * GetDeviceCaps(tmpDC,LOGPIXELSY))/72 + 0.5\r
+ ReleaseDC( 0, tmpDC )\r
+ Return tmpSize\r
+ \r
+ EndFunction\r
+ \r
+ Function SizeFromLogFont:Double( pLogFont:LOGFONTW )\r
+ \r
+ Local tmpDC:Int = GetDC(0)\r
+ Local tmpSize:Double = (Abs(pLogFont.lfHeight) * Double(72.0) )/GetDeviceCaps(tmpDC,LOGPIXELSY)\r
+ ReleaseDC( 0, tmpDC )\r
+ Return tmpSize\r
+ \r
+ EndFunction\r
+ \r
+ Function SetLogFontProperties( pLogFont:LOGFONTW, pFlags%, pSize:Double = 0:Double )\r
+ \r
+ If pFlags&FONT_BOLD Then pLogFont.lfWeight=FW_BOLD Else pLogFont.lfWeight=FW_NORMAL\r
+ If pFlags&FONT_ITALIC Then pLogFont.lfItalic=True Else pLogFont.lfItalic=False\r
+ If pFlags&FONT_UNDERLINE Then pLogFont.lfUnderline=True Else pLogFont.lfUnderline=False\r
+ If pFlags&FONT_STRIKETHROUGH Then pLogFont.lfStrikeOut=True Else pLogFont.lfStrikeOut=False\r
+ \r
+ If pSize > 0 Then pLogFont.lfHeight = -LogicalUnitsFromSize( pSize )\r
+ \r
+ EndFunction\r
+ \r
+EndType\r
+\r
+'A collection of functions that convert between Blitz pixmaps and Windows icons/bitmaps.\r
+Type TWindowsGraphic Final\r
+ \r
+ Function BitmapMaskFromPixmap:Int(pix:TPixmap)\r
+ \r
+ Local x, pix2:TPixmap, usealpha\r
+ \r
+ If PixmapFormat(pix) = PF_RGBA8888 Or PixmapFormat(pix) = PF_BGRA8888 Then usealpha = True\r
+ \r
+ pix2=ConvertPixmap(pix,PF_BGR888);ClearPixels(pix2)\r
+ \r
+ For Local y:Int = 0 Until pix.height\r
+ For x = 0 Until pix.width\r
+ If usealpha\r
+ If (ReadPixel(pix,x,y) Shr 24) < 128 Then WritePixel(pix2,x,y,$FFFFFF)\r
+ Else\r
+ If (ReadPixel(pix,x,y) & $FFFFFF) = $FFFFFF Then WritePixel(pix2,x,y,$FFFFFF)\r
+ EndIf\r
+ Next\r
+ Next\r
+ \r
+ Return BitmapFromPixmap(pix2,False)\r
+ \r
+ EndFunction\r
+ \r
+ Function PreMultipliedBitmapFromPixmap32:Int( pix:TPixmap )\r
+ \r
+ Local argb, a\r
+ Local pix2:TPixmap = CreatePixmap( pix.width, pix.height, pix.format), x\r
+ \r
+ For Local y:Int = 0 Until pix.height\r
+ For x = 0 Until pix.width\r
+ argb = ReadPixel(pix,x,y)\r
+ a = ((argb Shr 24) & $FF)\r
+ WritePixel(pix2,x,y,((((argb&$ff00ff)*a)Shr 8)&$ff00ff)|((((argb&$ff00)*a)Shr 8)&$ff00)|(a Shl 24))\r
+ Next\r
+ Next\r
+ \r
+ Return BitmapFromPixmap(pix2,True)\r
+ \r
+ EndFunction\r
+ \r
+ Function BitmapFromPixmap:Int(pix:TPixmap, alpha:Int = True)\r
+ \r
+ Local bitCount:Int = 32, format:Int = PF_BGRA8888, bm\r
+ \r
+ If Not alpha Then\r
+ bitCount = 24\r
+ format = PF_BGR888\r
+ EndIf\r
+ \r
+ pix=ConvertPixmap(pix,format)\r
+ \r
+ Local hdc = GetDC(0)\r
+ \r
+ Local bi:BITMAPINFOHEADER = New BITMAPINFOHEADER \r
+ bi.biSize=SizeOf(bi)\r
+ bi.biWidth=pix.width\r
+ bi.biHeight=-pix.height\r
+ bi.biPlanes=1\r
+ bi.biBitCount=bitCount\r
+ bi.biCompression=BI_RGB\r
+ \r
+ Local bits:Byte Ptr\r
+ Local src:Byte Ptr = pix.pixels\r
+ \r
+ If alpha\r
+ bm = CreateDibSection(hdc,bi,DIB_RGB_COLORS,Varptr bits,0,0)\r
+ Else\r
+ bm = CreateCompatibleBitmap(hdc,pix.width,pix.height)\r
+ EndIf\r
+ \r
+ Assert bm, "Cannot create bitmap. The computer may be running low on resources."\r
+ \r
+ For Local y:Int = 0 Until pix.height\r
+ SetDIBits(hdc,bm,pix.height-y-1,1,src,bi,DIB_RGB_COLORS)\r
+ src:+pix.pitch\r
+ Next\r
+ \r
+ ReleaseDC(0,hdc)\r
+ \r
+ Return bm\r
+ \r
+ EndFunction\r
+ \r
+ Function BitmapWithBackgroundFromPixmap32:Int( pix:TPixmap, pRed, pGreen, pBlue )\r
+ \r
+ Local tmpPixel, tmpRed, tmpGreen, tmpBlue, tmpAlpha, tmpAlphaFloat#, tmpAlphaFloat2#\r
+ Local pix2:TPixmap = CreatePixmap( pix.width, pix.height, pix.format), x\r
+ \r
+ For Local y:Int = 0 Until pix.height\r
+ For x = 0 Until pix.width\r
+ \r
+ 'Read pixel and alpha info\r
+ tmpPixel = ReadPixel(pix,x,y)\r
+ tmpAlpha = ((tmpPixel Shr 24) & $FF)\r
+ tmpAlphaFloat = tmpAlpha/255.0\r
+ tmpAlphaFloat2 = 1-tmpAlphaFloat\r
+ \r
+ 'Get individual colours\r
+ tmpBlue = tmpPixel & $FF;tmpGreen = (tmpPixel Shr 8) & $FF;tmpRed = (tmpPixel Shr 16)&$FF\r
+ \r
+ 'Courtesy of Mark T\r
+ tmpRed = (tmpRed * tmpAlphaFloat) + (tmpAlphaFloat2 * pRed)\r
+ tmpGreen = (tmpGreen * tmpAlphaFloat) + (tmpAlphaFloat2 * pGreen)\r
+ tmpBlue = (tmpBlue * tmpAlphaFloat) + (tmpAlphaFloat2 * pBlue)\r
+ \r
+ 'Write the new pixels\r
+ WritePixel(pix2,x,y,(tmpAlpha Shl 24)|(tmpRed Shl 16)|(tmpGreen Shl 8)|tmpBlue)\r
+ Next\r
+ Next\r
+ \r
+ Return BitmapFromPixmap(pix2,False)\r
+ \r
+ EndFunction\r
+\r
+ Function IconFromPixmap32:Int(pix:TPixmap)\r
+ \r
+ ' Convert the pixmap to a HBITMAP\r
+ Local bitmap = BitmapFromPixmap(pix,True)\r
+ \r
+ ' and then copy/resize it (to the default size for icons/cusors).\r
+ Local hSrcBMP = CopyImage(bitmap, IMAGE_BITMAP , 0 , 0 , LR_DEFAULTSIZE)\r
+ \r
+ ' Now we need to create a mask bitmap for the image\r
+ Local hMaskBMP = BitmapMaskFromPixmap( pix )\r
+ \r
+ ' So now we have our source and mask bitmaps, we can create an ICONINFO structure\r
+ Local IconInf:ICONINFO = New IconInfo\r
+ IconInf.fIcon = True\r
+ IconInf.hbmMask = hMaskBMP\r
+ IconInf.hbmColor = hSrcBMP\r
+ \r
+ ' Create the icon\r
+ Local tmpIcon = CreateIconIndirect(IconInf)\r
+ \r
+ ' Free our temporary bitmaps\r
+ DeleteObject(hMaskBMP)\r
+ DeleteObject(hSrcBMP)\r
+ DeleteObject(bitmap)\r
+ \r
+ Return tmpIcon\r
+ \r
+ EndFunction\r
+\r
+EndType\r
+\r
+Private\r
+\r
+Function KeyMods()\r
+ Local mods\r
+ If GetKeyState(VK_SHIFT)&$8000 mods:|MODIFIER_SHIFT\r
+ If GetKeyState(VK_CONTROL)&$8000 mods:|MODIFIER_CONTROL\r
+ If GetKeyState(VK_MENU)&$8000 mods:|MODIFIER_OPTION\r
+ If GetKeyState(VK_LWIN)&$8000 Or GetKeyState(VK_RWIN)&$8000 mods:|MODIFIER_SYSTEM\r
+ Return mods\r
+EndFunction\r
+\r
+Function FindGadgetWindowHwnd(g:TGadget)\r
+ Local wg:TWindowsWindow\r
+ While g\r
+ wg=TWindowsWindow(g)\r
+ If wg Return wg.Query(QUERY_HWND) 'handle\r
+ g=g.parent\r
+ Wend\r
+EndFunction\r
+\r
+Type TIntWrapper Final\r
+ Field value:Int\r
+ Function Create:TIntWrapper(value:Int)\r
+ Local tmpWrapper:TIntWrapper = New TIntWrapper\r
+ tmpWrapper.value = value\r
+ Return tmpWrapper\r
+ EndFunction\r
+ Method Compare( o:Object )\r
+ Local c:TIntWrapper = TIntWrapper(o)\r
+ If c Then Return (value - c.value)\r
+ Return Super.Compare(o)\r
+ EndMethod\r
+ Method ToString$()\r
+ Return value\r
+ EndMethod\r
+EndType\r
projects / blitzmax.git / commitdiff