{*------------------------------------------------------------------------------ A miniature framework for Win32 and WinCE applications @Author Patrick Michael Kolla @Version 0.3 @Todo Make listbox unsorted by default @Todo Create separate class for command bar on WinCE, or toolbar on Win32 @Todo Do not refresh window while controls are created? -------------------------------------------------------------------------------} // ***************************************************************************** // Copyright: © 2006 Safer Networking Limited. All rights reserved. // File: pkMiniGUI.pas // Compiler: FreePascal 2.1.1 // Purpose: A miniature framework for Win32 and WinCE applications // Authors: Patrick M. Kolla (pk) // ***************************************************************************** // Dependencies: // pkStrings (for a system-dependent definition of PChars and Strings) // ***************************************************************************** // Changelog (new entries first): // --------------------------------------- // 2006-07-28 pk 30m Updated documentation // 2006-07-27 pk 30m Added listview column and item handling // 2006-07-10 pk 30m Improved Align property // 2006-07-06 pk 1h Added code to read font size (sadly not working yet) // 2006-07-06 pk 90m Added Align, now supporting rotation // 2006-07-04 pk 30m Completed menus for Windows 32 // 2006-07-04 pk 30m Changed CreateFontIndirect to multiple CreateFont // 2006-06-28 pk 10m Added Visibility property // ***************************************************************************** unit pkMiniGUI; {$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF FPC} {$IFDEF WinCE} {$DEFINE UseUnicode} {$ENDIF WinCE} {$IFDEF Win32} {$UNDEF UseUnicode} {$ENDIF Win32} {.$DEFINE UseFontDirect} interface uses SysUtils, Windows, Messages, pkStrings, pkWinINet; type {$IFDEF UseUnicode} PMiniChar = PWideChar; /// A null-terminated string, Ansi or Unicode based on Operating System MiniString = WideString; /// A standard string, Ansi or Unicode based on Operating System MiniChar = WideChar; /// A standard character, Ansi or Unicode based on Operating System {$ELSE UseUnicode} PMiniChar = PAnsiChar; /// A null-terminated string, Ansi or Unicode based on Operating System MiniString = AnsiString; /// A standard string, Ansi or Unicode based on Operating System MiniChar = AnsiChar; /// A standard character, Ansi or Unicode based on Operating System {$ENDIF UseUnicode} /// A definition of possible text alignments TMiniTextAlign = (taLeft, taCenter, taRight); /// A definition of possible control alignments TMiniAlign = (malLeft, malTop, malRight, malBottom); /// A set for multiple control alignment parameters TMiniAligns = set of TMiniAlign; /// A handler for error events TOnMiniAppError = procedure(ErrorCode: integer; ErrorText: string) of object; /// A handler for click events TOnMiniClick = procedure() of object; /// A handler for change events TOnMiniChange = procedure() of object; /// A handler for character inputs TOnMiniChar = procedure(Key: MiniChar) of object; /// A handler for list item activations TOnMiniListItemActivate = procedure(ItemIndex, SubItemIndex: integer; NewState, OldState, Changed: DWord) of object; TTreeItemHandle = THandle; TWndMessageProc = function(hWnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LongInt; stdcall; { TMiniAppFont } /// Record that contains typical font properties TMiniAppFont = record Handle: THandle; FontName: PMiniChar; FontSize: integer; Italic, Underline, Strikethrough, Bold: boolean; end; { TMiniAppControl } TMiniAppWindow = class; /// The base class for most GUI controls TMiniAppControl = class private FAlign: TMiniAligns; FHandle: hWnd; FOnChar: TOnMiniChar; FOnClick: TOnMiniClick; FResourceID: integer; FTransparent: boolean; FVisible: boolean; FWindow: TMiniAppWindow; FOwner: TMiniAppControl; FParentControl: TMiniAppControl; FHeight: integer; FLeft: integer; FText: MiniString; FTop: integer; FWidth: integer; FComponents: array of TMiniAppControl; FComponentCount: integer; FDistanceLeft, FDistanceTop, FDistanceRight, FDistanceBottom: integer; FDefaultIconWidth: integer; FBackgroundDC: THandle; FOldMessageProc: TWndMessageProc; function GetClientHeight: integer; function GetClientRect: TRect; function GetClientWidth: integer; function GetDefaultIconWidth: integer; function GetIsSmartphone: boolean; function GetText: MiniString; function IsFontSupported: boolean; procedure SetAlign(const AValue: TMiniAligns); procedure SetBaseFont(AWindow: hWnd); procedure SetHeight(const AValue: integer); procedure SetLeft(const AValue: integer); procedure SetOnChar(const AValue: TOnMiniChar); procedure SetOnClick(const AValue: TOnMiniClick); procedure SetText(const AValue: MiniString); procedure SetTop(const AValue: integer); procedure SetTransparent(const AValue: boolean); procedure SetVisible(const AValue: boolean); procedure SetWidth(const AValue: integer); procedure RegisterChildControl(AChild: TMiniAppControl); function GetChildByHandle(AHandle: hWnd): TMiniAppControl; procedure UpdateControlPos(AMove: boolean = false); procedure UpdateAlignments; procedure UpdateChildAlignments; protected procedure ShiftPositionOffset(AOwner: TMiniAppControl; var ALeft, ATop, AWidth, AHeight: integer); public constructor Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth, AHeight: integer); overload; constructor Create(AExistingID: integer); overload; destructor Destroy; procedure AddControlStyle(dwStyle: DWord; bEx: boolean = false); procedure RemoveControlStyle(dwStyle: DWord; bEx: boolean = false); procedure SetControlStyle(dwStyle: DWord; bEx: boolean = false); procedure SetPositionAndSize(ALeft, ATop, AWidth, AHeight: integer); property ClientRect: TRect read GetClientRect; published property Handle: hWnd read FHandle; property Align: TMiniAligns read FAlign write SetAlign; property ClientWidth: integer read GetClientWidth; property ClientHeight: integer read GetClientHeight; property DefaultIconWidth: integer read GetDefaultIconWidth; property Left: integer read FLeft write SetLeft; property Top: integer read FTop write SetTop; property Width: integer read FWidth write SetWidth; property Height: integer read FHeight write SetHeight; property ParentControl: TMiniAppControl read FParentControl; property ResourceID: integer read FResourceID write FResourceID; property IsSmartphone: boolean read GetIsSmartphone; property Text: MiniString read GetText write SetText; property Transparent: boolean read FTransparent write SetTransparent; property Visible: boolean read FVisible write SetVisible; property OnClick: TOnMiniClick read FOnClick write SetOnClick; property OnChar: TOnMiniChar read FOnChar write SetOnChar; end; { TMiniAppLabel } /// Text label TMiniAppLabel = class(TMiniAppControl) private FTextAlign: TMiniTextAlign; procedure SetTextAlign(const AValue: TMiniTextAlign); public constructor Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth: integer; AHeight: integer = -1); published property TextAlign: TMiniTextAlign read FTextAlign write SetTextAlign; end; { TMiniAppButton } /// Standard button TMiniAppButton = class(TMiniAppControl) private public constructor Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth: integer; AHeight: integer = 23); overload; constructor Create(AExistingID: integer); overload; published end; { TMiniAppResourceImage } /// Image loaded from resource file TMiniAppResourceImage = class(TMiniAppControl) private public constructor Create(AOwner: TMiniAppControl; AResourceName: MiniString; ALeft, ATop, AWidth, AHeight: integer); published end; { TMiniAppResourceIcon } /// Icon loaded from resource file TMiniAppResourceIcon = class(TMiniAppControl) private public constructor Create(AOwner: TMiniAppControl; AResourceName: MiniString; ALeft, ATop, AWidth, AHeight: integer); published end; { TMiniAppListBox } /// Listbox TMiniAppListBox = class(TMiniAppControl) private function GetAnchorIndex: integer; function GetCaretIndex: integer; function GetCount: integer; public constructor Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); function AddString(AText: MiniString): integer; function DeleteString(AIndex: integer): integer; function InsertString(AText: MiniString; AIndex: integer = 0): integer; function FindString(AText: MiniString; AStartIndex: integer = -1): integer; function GetString(AIndex: integer): MiniString; procedure ClearStrings; published property AnchorIndex: integer read GetAnchorIndex; property CaretIndex: integer read GetCaretIndex; property Count: integer read GetCount; end; { TMiniAppComboBox } /// Combobox (pulldown list) TMiniAppComboBox = class(TMiniAppControl) private FMaxLength: integer; function GetCount: integer; function GetSelectedIndex: integer; procedure SetMaxLength(const AValue: integer); procedure SetSelectedIndex(const AValue: integer); public constructor Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth: integer; AHeight: integer = 96); overload; constructor Create(AExistingHandle: THandle); overload; function AddString(AText: MiniString): integer; function DeleteString(AIndex: integer): integer; function InsertString(AText: MiniString): integer; function FindString(AText: MiniString; AStartIndex: integer = -1): integer; procedure ClearStrings; published property SelectedIndex: integer read GetSelectedIndex write SetSelectedIndex; property MaxLength: integer read FMaxLength write SetMaxLength; property Count: integer read GetCount; end; { TMiniAppEdit } /// Single line edit field TMiniAppEdit = class(TMiniAppControl) private FOnChange: TOnMiniChange; FPassword: boolean; FPasswordChar: MiniChar; FReadOnly: boolean; procedure SetOnChange(const AValue: TOnMiniChange); procedure SetPassword(const AValue: boolean); procedure SetPasswordChar(const AValue: MiniChar); procedure SetReadOnly(const AValue: boolean); procedure UpdateControlStyle; public constructor Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth: integer; AHeight: integer = 21; AReadOnly: boolean = false; AMultiLine: boolean = false); property PasswordChar: MiniChar read FPasswordChar write SetPasswordChar; published property ReadOnly: boolean read FReadOnly write SetReadOnly; property Password: boolean read FPassword write SetPassword; property OnChange: TOnMiniChange read FOnChange write SetOnChange; end; { TMiniAppGroupbox } /// Group box (frame around controls) TMiniAppGroupbox = class(TMiniAppControl) private public constructor Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth, AHeight: integer); published end; // advanced controls { TMiniAppProgressbar } /// Simple progress bar, smooth by default, uses Common Controls TMiniAppProgressbar = class(TMiniAppControl) private FMax: DWord; FMin: DWord; FPosition: DWord; procedure SetMax(const AValue: DWord); procedure SetMin(const AValue: DWord); procedure SetPosition(const AValue: DWord); procedure UpdateMinMax; public constructor Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); published property Min: DWord read FMin write SetMin; property Max: DWord read FMax write SetMax; property Position: DWord read FPosition write SetPosition; end; { TMiniAppTreeview } /// Treeview control, uses Common Controls TMiniAppTreeview = class(TMiniAppControl) private public constructor Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); function InsertItemFirst(AParent: TTreeItemHandle; AText: MiniString): TTreeItemHandle; function InsertItemLast(AParent: TTreeItemHandle; AText: MiniString): TTreeItemHandle; function InsertItemSorted(AParent: TTreeItemHandle; AText: MiniString): TTreeItemHandle; function InsertItemAfter(AParent, AAfter: TTreeItemHandle; AText: MiniString): TTreeItemHandle; function SetItemText(AItem: TTreeItemHandle; AText: MiniString): boolean; published end; TMiniAppListview = class; { TMiniAppListItem } /// Item of a TMiniAppListview TMiniAppListItem = class private FListView: TMiniAppListview; FText: MiniString; FItem: LV_ITEM; FItemIndex: integer; FSubItemCount: integer; public constructor Create(AOwner: TMiniAppListview; AText: MiniString; AIndex: integer = 0); procedure AddSubItem(AText: MiniString); end; { TMiniAppListview } /// Listview control, uses Common Controls TMiniAppListview = class(TMiniAppControl) private FColumns: array of LV_COLUMN; FOnItemActivate: TOnMiniListItemActivate; protected procedure DoOnItemActivate(Info: PNMLISTVIEW); public constructor Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); function AddItem(AText: MiniString): TMiniAppListItem; function InsertItem(AText: MiniString): TMiniAppListItem; procedure InsertColumn(AText: MiniString; AIndex, AWidth: integer; AAlign: TMiniTextAlign = taLeft); procedure ClearItems; published property OnItemActivate: TOnMiniListItemActivate read FOnItemActivate write FOnItemActivate; end; TMiniAppMainMenu = class; TMiniAppToolbar = class; /// A handler assication for clicks based on control handles TMiniClickHandler = record Handle: hWnd; Handler: TOnMiniClick; end; /// A handler assication for clicks based on resource (or other) IDs TMiniResourceHandler = record ResourceID: Word; Handler: TOnMiniClick; end; /// A handler assication for character inputs TMiniCharHandler = record Handle: hWnd; Handler: TOnMiniChar; end; /// A handler assication for change events TMiniChangeHandler = record Handle: hWnd; Handler: TOnMiniChange; end; { TMiniAppWindow } /// A window aka form TMiniAppWindow = class(TMiniAppControl) private FAboutText: string; FBackgroundResource: MiniString; FBackgroundBitmap: THandle; FBackgroundOldBitmap: THandle; FDoneButtonVisible: boolean; FMenuBarHandle: hWnd; FCESIPBarHandle: hWnd; FCommandBarHandle: hWnd; FBaseFontName: string; FClassName: AnsiString; FFontHandle: hWnd; FMainMenu: TMiniAppMainMenu; FToolbar: TMiniAppToolbar; FOnMiniAppError: TOnMiniAppError; FShowSIPButton: boolean; FShowStartIcon: boolean; FShowTaskbar: boolean; FWindowClass: TWndClass; FWindowStyle: DWord; FWindowTitle: MiniString; FOnMiniClickHandlers: array of TMiniClickHandler; FOnMiniResourceHandlers: array of TMiniResourceHandler; FOnMiniCharHandlers: array of TMiniCharHandler; FOnMiniChangeHandlers: array of TMiniChangeHandler; procedure FireMiniAppError(ErrorText: MiniString); function GetMainMenu: TMiniAppMainMenu; function GetToolbar: TMiniAppToolbar; function GetMiniClickHandler(AHandle: integer): TOnMiniClick; function GetMiniResourceHandler(AResourceID: Word): TOnMiniClick; function GetMiniCharHandler(AHandle: integer): TOnMiniChar; function GetMiniChangeHandler(AHandle: integer): TOnMiniChange; procedure DoCreate; procedure DoDestroy; procedure DoActivate(AActive: Word; AMinimized: Word; AHandlePrev: hWnd); procedure DoNotify(AControl: THandle; AHeader: PNMHDR); procedure DoCommand(ANotifyCode, AID: Word; AParam: Integer); procedure DoMenu(ANotifyCode, AID: Word); procedure DoChar(ACharCode, AKeyCode: integer); procedure DoSettingChange(AFlag: Word; ASectionName: PMiniChar); procedure DoCalcSize; function GetToolbarHeight: integer; procedure SetDoneButtonVisible(const AValue: boolean); procedure SetShowSIPButton(const AValue: boolean); procedure SetShowStartIcon(const AValue: boolean); procedure SetShowTaskbar(const AValue: boolean); procedure SetWindowTitle(const AValue: MiniString); procedure UpdateFullScreen; protected public constructor Create; destructor Destroy; procedure Initialize(AClassName: AnsiString = 'pkMiniGUIApp'; AResourceMenuID: integer = 0); procedure Run; // Handlers procedure AddMiniClickHandler(AHandle: hWnd; AHandler: TOnMiniClick); procedure AddMiniResourceHandler(AResourceID: Word; AHandler: TOnMiniClick); procedure AddMiniCharHandler(AHandle: hWnd; AHandler: TOnMiniChar); procedure AddMiniChangeHandler(AHandle: hWnd; AHandler: TOnMiniChange); // Message functions function AppMessageBox(ACaption: PMiniChar; AType: UINT): LongInt; overload; function AppMessageBox(ACaption: MiniString; AType: UINT): LongInt; overload; function AppErrorBox(ACaption: PMiniChar): LongInt; overload; function AppErrorBox(ACaption: MiniString): LongInt; overload; function AppExclamationBox(ACaption: PMiniChar): LongInt; overload; function AppExclamationBox(ACaption: MiniString): LongInt; overload; function AppInformationBox(ACaption: PMiniChar): LongInt; overload; function AppInformationBox(ACaption: MiniString): LongInt; overload; function AppWarningBox(ACaption: PMiniChar): LongInt; overload; function AppWarningBox(ACaption: MiniString): LongInt; overload; function AppConfirmationBox(ACaption: PMiniChar; AWithCancel: boolean = false): LongInt; overload; function AppConfirmationBox(ACaption: MiniString; AWithCancel: boolean = false): LongInt; overload; {$IFDEF Win32} function AppCustomIconBox(ACaption, AResourceName: PMiniChar; AType: UINT): boolean; {$ENDIF Win32} published property AboutText: string read FAboutText write FAboutText; property BaseFontName: string read FBaseFontName write FBaseFontName; property BackgroundResource: MiniString read FBackgroundResource write FBackgroundResource; property ClassName: AnsiString read FClassName write FClassName; property DoneButtonVisible: boolean read FDoneButtonVisible write SetDoneButtonVisible; // pay attention, this may brake closing the app! property MainMenu: TMiniAppMainMenu read GetMainMenu; property Toolbar: TMiniAppToolbar read GetToolbar; property ToolbarHeight: integer read GetToolbarHeight; property WindowTitle: MiniString read FWindowTitle write SetWindowTitle; property WindowStyle: DWord read FWindowStyle write FWindowStyle; property OnMiniAppError: TOnMiniAppError read FOnMiniAppError write FOnMiniAppError; property ShowTaskbar: boolean read FShowTaskbar write SetShowTaskbar; property ShowSIPButton: boolean read FShowSIPButton write SetShowSIPButton; property ShowStartIcon: boolean read FShowStartIcon write SetShowStartIcon; property MenuBarHandle: hWnd read FMenuBarHandle write FMenuBarHandle; property CESIPBarHandle: hWnd read FCESIPBarHandle write FCESIPBarHandle; property CommandBarHandle: hWnd read FCommandBarHandle write FCommandBarHandle; end; { TMiniAppMenuItem } /// Item of a menu TMiniAppMenuItem = class private FID: DWord; public published property ID: DWord read FID write FID; end; { TMiniAppMenuPopup } /// A submenu TMiniAppMenuPopup = class private FHandle: THandle; public function AddItem(AText: PMiniChar): TMiniAppMenuItem; function AddSeparator: TMiniAppMenuItem; function AddPopup(AText: PMiniChar): TMiniAppMenuPopup; published property Handle: THandle read FHandle write FHandle; end; { TMiniAppMainMenu } /// The main menu, like TMiniAppMenuPopup but unqiue TMiniAppMainMenu = class(TMiniAppMenuPopup) private public constructor Create(AOwnerWindow: TMiniAppWindow); published end; { TMiniAppToolButton } /// A button on a toolbar, has an ID instead of handle. TMiniAppToolButton = class private FID: DWord; FOwnerWindow: TMiniAppWindow; FOwnerToolbar: TMiniAppToolbar; FOnClick: TOnMiniClick; procedure SetOnClick(const AValue: TOnMiniClick); public constructor Create(AOwnerWindow: TMiniAppWindow; AOwnerToolbar: TMiniAppToolbar; AID: DWord = 0); published property ID: DWord read FID write FID; property OnClick: TOnMiniClick read FOnClick write SetOnClick; end; { TMiniAppToolbar } /// A toolbar for buttons or other controls TMiniAppToolbar = class(TMiniAppMenuPopup) private FOwnerWindow: TMiniAppWindow; FVisible: boolean; function GetHeight: integer; function GetVisible: boolean; procedure SetVisible(const AValue: boolean); public constructor Create(AOwnerWindow: TMiniAppWindow); function AddAdornments(AHelpButton, AOKButton: boolean): boolean; function AddButton(AText: PMiniChar; AImageIndex: integer = -1): TMiniAppToolButton; function AddComboBox(AWidth: DWord; APos: DWord = 0): TMiniAppComboBox; function AddMainMenu: boolean; function AddPopupMenu(AMenu: TMiniAppMenuPopup): boolean; function AddSystemBitmaps(ViewBitmaps: boolean = false): integer; destructor Destroy; function MyDrawMenuBar(AButtonIndex: Word = 0): boolean; published property Height: integer read GetHeight; property Visible: boolean read GetVisible write SetVisible; end; var MiniApp: TMiniAppWindow; const GWLP_WNDPROC : integer = -4; {$IFDEF WinCE} const SHFS_SHOWTASKBAR = $01; /// Used by SHFullScreen to toggle full screen behaviour SHFS_HIDETASKBAR = $02; /// Used by SHFullScreen to toggle full screen behaviour SHFS_SHOWSIPBUTTON = $04; /// Used by SHFullScreen to toggle full screen behaviour SHFS_HIDESIPBUTTON = $08; /// Used by SHFullScreen to toggle full screen behaviour SHFS_SHOWSTARTICON = $10; /// Used by SHFullScreen to toggle full screen behaviour SHFS_HIDESTARTICON = $20; /// Used by SHFullScreen to toggle full screen behaviour SHDB_SHOW = $0001; /// Used with SHDoneButton to show the OK button SHDB_HIDE = $0002; /// Used with SHDoneButton to hide the OK button CMDBAR_HELP = $000B; /// Used to show Help button with CommandBar_AddAdornments CMDBAR_OK = $F000; /// Used to show OK button with CommandBar_AddAdornments PBM_SETRANGE32 = 1030; BATTERY_FLAG_HIGH = 1; /// Battery status us high BATTERY_FLAG_LOW = 2; /// Battery status us low BATTERY_FLAG_CRITICAL = 4; /// Battery status us critical BATTERY_FLAG_CHARGING = 8; /// Device is currently charged BATTERY_FLAG_NO_BATTERY = 128; /// No battery was found BATTERY_FLAG_UNKNWON = 255; /// Battery status is unknown type TSYSTEM_POWER_STATUS_EX = packed record /// Information about the power/battery status of the device ACLineStatus: Byte; /// ACLineStatus: Status of AC power BatteryFlag: Byte; /// BatteryFlag: Charge status of battery BatteryLifePercent: Byte; /// BatteryLifePercent: Charge status of battery in percent Reserved1: Byte; /// Reserved1: Reserved; set to zero BatteryLifeTime: DWord; /// BatteryLifeTime: Seconds of battery remaining BatteryFullLifeTime: DWord; /// BatteryFullLifeTime: Total of battery life in seconds Reserved2: Byte; /// Reserved2: Reserved; set to zero BackupBatteryFlag: Byte; /// BackupBatteryFlag: Charge status of battery BackupBatteryLifePercent: Byte; /// BackupBatteryLifePercent: Charge status of battery in percent Reserved3: Byte; /// Reserved3: Reserved; set to zero BackupBatteryLifeTime: DWord; /// BackupBatteryLifeTime: Seconds of battery remaining BackupBatteryFullLifeTime: DWord; /// BackupBatteryFullLifeTime: Total of battery life in seconds end; /// See MSDN function SHDoneButton(hwndRequester: hWnd; dwState: DWord): WINBOOL; external UserDLLAyg name 'SHDoneButton'; /// See MSDN function SHFullScreen(hwndRequester: hWnd; dwState: DWord): WINBOOL; external UserDLLAyg name 'SHFullScreen'; /// See MSDN function SHSetNavBarText(hwndRequester: hWnd;pszText: PWideChar): WINBOOL; external UserDLLAyg name 'SHSetNavBarText'; /// See MSDN function GetSystemPowerStatusEx(varpsStatus: TSYSTEM_POWER_STATUS_EX; fUpdate: boolean): WINBOOL; external KernelDLL name 'GetSystemPowerStatusEx'; /// See MSDN function CommandBar_AddAdornments(hwndCB: hWnd; dwFlags, dwReserved: DWord): WINBOOL; external ComctlDLL name 'CommandBar_AddAdornments'; /// See MSDN function CommandBar_AddBitmap(hwndCB: hWnd; hInst: THandle; idBitmap, iNumImages, iImageWidth, iImageHeight: integer): integer; external ComctlDLL name 'CommandBar_AddBitmap'; /// See MSDN function CommandBar_Create(hInst: THandle; hwndParent: hWnd; idCmdBar: integer): hWnd; external ComctlDLL name 'CommandBar_Create'; /// See MSDN function CommandBar_DrawMenuBar(hwndCB: hWnd; iButton: Word): WINBOOL; external ComctlDLL name 'CommandBar_DrawMenuBar'; /// See MSDN function CommandBar_GetMenu(hwndCB: hWnd; iButton: Word): THandle; external ComctlDLL name 'CommandBar_GetMenu'; /// See MSDN function CommandBar_Height(hwndCB: hWnd): integer; external ComctlDLL name 'CommandBar_Height'; /// See MSDN function CommandBar_InsertComboBox(hwndCB: hWnd; hInst: THandle; iWidth: integer; dwStyle: UInt; idComboBox, iButton: Word): hWnd; external ComctlDLL name 'CommandBar_InsertComboBox'; /// See MSDN function CommandBar_InsertMenubar(hwndCB: hWnd; hInst: THandle; idMenu, iButton: Word): WINBOOL; external ComctlDLL name 'CommandBar_InsertMenubar'; /// See MSDN function CommandBar_InsertMenubarEx(hwndCB: hWnd; hInst: THandle; pszMenu: PWideChar; iButton: Word): WINBOOL; external ComctlDLL name 'CommandBar_InsertMenubarEx'; /// See MSDN function CommandBar_Show(hwndCB: hWnd; fShow: boolean): WINBOOL; external ComctlDLL name 'CommandBar_Show'; // Makros function CommandBar_AddButtons(hwndCB: hWnd; uNumButtons: UInt; var lpButtons: array of TBBUTTON): WINBOOL; function CommandBar_AddToolTips(hwndCB: hWnd; uNumToolTips: UInt; lpToolTips: PWideChar): WINBOOL; procedure CommandBar_Destroy(hwndCB: hWnd); function CommandBar_IsVisible(hwndCB: hWnd): WINBOOL; function CommandBar_InsertButton(hwndCB: hWnd; iButton: integer; lpButton: TBBUTTON): WINBOOL; {$ENDIF WinCE} const PBS_SMOOTH = 1; ICC_LISTVIEW_CLASSES = $0001; ICC_TREEVIEW_CLASSES = $0002; ICC_BAR_CLASSES = $0004; ICC_TAB_CLASSES = $0008; ICC_UPDOWN_CLASS = $0010; ICC_PROGRESS_CLASS = $0020; ICC_DATE_CLASSES = $0100; ICC_COOL_CLASSES = $0400; ICC_TOOLTIP_CLASSES = $1000; ICC_CAPEDIT_CLASS = $2000; // ICC_SBEDIT_CLASSES = ; {$IFDEF Win32} ICC_HOTKEY_CLASS = $0040; ICC_ANIMATE_CLASS = $0080; ICC_USEREX_CLASSES = $0200; ICC_INTERNET_CLASSES = $0800; ICC_PAGESCROLLER_CLASS = $1000; ICC_NATIVEFNTCTL_CLASS = $2000; ICC_FE_CLASSES = $4000; ICC_WIN95_CLASSES = $00FF; {$ENDIF Win32} type tagINITCOMMONCONTROLSEX = packed record dwSize: DWord; dwICC: DWord; end; TINITCOMMONCONTROLSEX = tagINITCOMMONCONTROLSEX; LPINITCOMMONCONTROLSEX = ^TINITCOMMONCONTROLSEX; /// See MSDN procedure InitCommonControlsEx(var lpInitCtrls: TINITCOMMONCONTROLSEX); external 'comctl32' name 'InitCommonControlsEx'; implementation var MessageProcHandles: array of hWnd; MessageProcWindows: array of TMiniAppWindow; GAllControls: array of TMiniAppControl; GDefaultFontHandle: hWnd; GFontHandles: array of TMiniAppFont; GControlIDOffset: DWord; GToolbarOffset: DWord; GLastBackgroundDC: THandle; GOldGroupboxMessageProc: TWndMessageProc = nil; {*------------------------------------------------------------------------------ Finds a control in the global control storage by using its handle @param AHandle handle to the control to be searched for @return The control object if found, otherwise nil. @see AddNewGlobalControl -------------------------------------------------------------------------------} function FindGlobalControl(AHandle: THandle): TMiniAppControl; var iControl: integer; begin Result := nil; for iControl := 0 to Pred(Length(GAllControls)) do begin if GAllControls[iControl].Handle = AHandle then begin Result := GAllControls[iControl]; Exit; end; end; end; {*------------------------------------------------------------------------------ Adds a new control to a global control storage @param AControl Control object to store @return Index of the control in the global control storage @see FindGlobalControl -------------------------------------------------------------------------------} function AddNewGlobalControl(AControl: TMiniAppControl): integer; begin Result := Length(GAllControls); SetLength(GAllControls, Length(GAllControls) + 1); GAllControls[Pred(Length(GAllControls))] := AControl; end; {*------------------------------------------------------------------------------ Loads a font and returns the handle to it @param AAppFont Settings of Font to add to global font storage @return Handle of the stored font @see GetGlobalFont -------------------------------------------------------------------------------} function AddNewGlobalFont(AAppFont: TMiniAppFont): THandle; overload; var iIndex: integer; begin iIndex := Length(GFontHandles); SetLength(GFontHandles, iIndex+1); GFontHandles[iIndex] := AAppFont; Result := AAppFont.Handle; end; {*------------------------------------------------------------------------------ Loads a font and returns the handle to it @param AFontName Name of the font to be loaded. @param AFontSize Size of the font; 16 is about average on Win32? @param AItalic Whether the font should be italic @param AUnderline Whether the font should be underlined @param AStrikethrough Whether the font should be stroked out @param ABold Whether the font should be standard bold @return Handle of the loaded font @see GetGlobalFont -------------------------------------------------------------------------------} function AddNewGlobalFont(AFontName: PMiniChar; AFontSize: integer; AItalic, AUnderline, AStrikethrough, ABold: boolean): THandle; overload; var AppFont: TMiniAppFont; iWeight: Integer; dwItalic, dwUnderline, dwSwtrikethrough: DWord; lfMain: LogFont; begin with AppFont do begin FontName := AFontName; FontSize := AFontSize; Italic := AItalic; Underline := AUnderline; Strikethrough := AStrikethrough; Bold := ABold; end; if ABold then iWeight := FW_BOLD else iWeight := FW_NORMAL; dwItalic := DWord(AItalic); dwUnderline := DWord(AUnderline); dwSwtrikethrough := DWord(AStrikethrough); FillChar(lfMain, SizeOf(lfMain), 0); lfMain.lfHeight := AFontSize; lfMain.lfEscapement := 10*45; lfMain.lfOrientation := 10*45; lfMain.lfCharSet := DEFAULT_CHARSET; lfMain.lfWeight := iWeight; lfMain.lfItalic := dwItalic; lfMain.lfUnderline := dwUnderline; lfMain.lfStrikeOut := dwSwtrikethrough; {$IFDEF Win32} lfMain.lfFaceName := 'MS Sans Serif'; {$ENDIF Win32} AppFont.Handle := CreateFontIndirect(@lfMain); AddNewGlobalFont(AppFont); Result := AppFont.Handle; (* AppFont.Handle := CreateFont(AFontSize, 0, 0, 0, iWeight, dwItalic, dwUnderline, dwSwtrikethrough, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, AFontName); AddNewGlobalFont(AppFont); Result := AppFont.Handle;*) end; {*------------------------------------------------------------------------------ Checks for a font, and if not loaded, loads it. @param AFontName Name of the font to be loaded. @param AFontSize Size of the font; 16 is about average on Win32? @param AItalic Whether the font should be italic @param AUnderline Whether the font should be underlined @param AStrikethrough Whether the font should be stroked out @param ABold Whether the font should be standard bold @return Handle of the loaded font @see AddNewGlobalFont -------------------------------------------------------------------------------} function GetGlobalFont(AFontName: PMiniChar; AFontSize: integer; AItalic, AUnderline, AStrikethrough, ABold: boolean): THandle; var iIndex: integer; begin Result := 0; if Length(GFontHandles)>0 then for iIndex := 0 to Pred(Length(GFontHandles)) do if (GFontHandles[iIndex].FontName = AFontName) and (GFontHandles[iIndex].FontSize = AFontSize) and (GFontHandles[iIndex].Italic = AItalic) and (GFontHandles[iIndex].Underline = AUnderline) and (GFontHandles[iIndex].Strikethrough = AStrikethrough) and (GFontHandles[iIndex].Bold = ABold) then Result := GFontHandles[iIndex].Handle; if Result=0 then Result := AddNewGlobalFont(AFontName, AFontSize, AItalic, AUnderline, AStrikethrough, ABold); end; {*------------------------------------------------------------------------------ Adds a new window to the list used by the global message procedure @param AHandle Handle of a window the message proc should deal with @param AWindow Window object for the handle @see WndMessageProc -------------------------------------------------------------------------------} procedure AddMessageProc(AHandle: hWnd; AWindow: TMiniAppWindow); var iIndex: integer; begin iIndex := Length(MessageProcHandles); SetLength(MessageProcHandles, iIndex+1); SetLength(MessageProcWindows, iIndex+1); MessageProcHandles[iIndex] := AHandle; MessageProcWindows[iIndex] := AWindow; end; {*------------------------------------------------------------------------------ The child control message loop of any pkMiniGUI application @see AddMessageProc @see WndMessageProcChilds -------------------------------------------------------------------------------} function WndMessageProc(hWnd: HWND; Msg: UINT; wParam: wPARAM; lParam: LPARAM): LongInt; stdcall; var win: TMiniAppWindow; control: TMiniAppControl; iIndex: integer; lw,hw: Word; r, rClient: TRect; pr: ^TRect; hDC, hDCBackground, hBrush: THandle; begin Result := 0; win := nil; for iIndex := 0 to Pred(Length(MessageProcHandles)) do if MessageProcHandles[iIndex]=hWnd then win := MessageProcWindows[iIndex]; if win=nil then begin control := FindGlobalControl(hwnd); if Assigned(control) then while (not (control is TMiniAppWindow)) and (Assigned(control.FParentControl)) do control := control.FParentControl; if Assigned(control) then if (control is TMiniAppWindow) then win := (control as TMiniAppWindow); end; case Msg of WM_CREATE: begin if Assigned(win) then win.DoCreate; end; WM_DESTROY: begin if Assigned(win) then win.DoDestroy; PostQuitMessage(0); end; WM_ACTIVATE: begin if Assigned(win) then win.DoActivate(Lo(wParam),Hi(wParam),lParam); end; WM_CLOSE: ; WM_NOTIFY: begin if Assigned(win) then win.DoNotify(wParam, PNMHDR(lParam)); end; WM_KEYUP: begin // TODO // MessageBox(0,'WM_CLOSE','WM_CLOSE',0); end; WM_CHAR: begin // MessageBox(0,'WM_CHAR','WM_CHAR',0); if Assigned(win) then win.DoChar(wParam, lParam); end; WM_SETTINGCHANGE: begin if Assigned(win) then win.DoSettingChange(wParam, PMiniChar(lParam)); end; WM_NCCALCSIZE: begin if Assigned(win) then win.DoCalcSize; end; WM_CTLCOLORSTATIC: begin // hwnd = Parent device // wParam = hDCStatic (Device context of control to be drawn) // lParam = hWndStatic (Window handle of control to be drawn) control := FindGlobalControl(lParam); if Assigned(control) and Assigned(win) then begin if (control.Transparent) and (win.FBackgroundDC>0) then begin SetBkMode(wParam, TRANSPARENT); GetClientRect(lParam, @rClient); //GetWindowRect(lParam, @r); if control.FParentControl=win then begin // hwnd = window // lParam = control GetWindowRect(lParam, @r); {$IFDEF WinCE} MapWindowPoints(HWND_DESKTOP, hwnd, @r, 2); {$ELSE WinCE} pr := @r; MapWindowPoints(HWND_DESKTOP, hwnd, pr, 2); {$ENDIF WinCE} end else begin // hwnd = group box // lParam = sub-control pr := @r; GetWindowRect(lParam, @r); {$IFDEF WinCE} MapWindowPoints(HWND_DESKTOP, hwnd, @r, 2); {$ELSE WinCE} pr := @r; MapWindowPoints(HWND_DESKTOP, hwnd, pr, 2); {$ENDIF WinCE} r.Top := r.Top + control.FParentControl.Top; r.Left := r.Left + control.FParentControl.Left; end; (*if control.FParentControl=win then MapWindowPoints(HWND_DESKTOP, hwnd, @r, 2) else MapWindowPoints(control.FParentControl.Handle, hwnd, @r, 2);*) BitBlt(wParam, 0, 0, rClient.right, rClient.bottom, win.FBackgroundDC, r.left, r.top, SRCCOPY); hBrush := GetStockObject(NULL_BRUSH); Result := hBrush; Exit; end; end; end; WM_ERASEBKGND: begin // TODO : if background image is smaller than area, draw the rest // with the default background color! if Assigned(win) then hDCBackground := win.FBackgroundDC else hDCBackground := GLastBackgroundDC; if hDCBackground>0 then begin GetClientRect(hwnd, @r); // BitBlt(wParam, r.Left, r.Top, r.Right-r.Left, r.Bottom-r.Top, win.FBackgroundDC, 0, 0, WHITENESS); BitBlt(wParam, r.Left, r.Top, r.Right-r.Left, r.Bottom-r.Top, win.FBackgroundDC, 0, 0, SRCCOPY); Result := 1; Exit; end; end; WM_COMMAND: begin lw := Lo(wParam); hw := Hi(wParam); if lw=199 then PostQuitMessage(0); if lw=IDOK then PostQuitMessage(0); if Assigned(win) then begin if (lw>0) then win.DoMenu(hw,lw); if (lParam>0) then win.DoCommand(hw, lw, lParam); end; end; end; Result := DefWindowProc(hWnd,Msg,wParam,lParam); end; {*------------------------------------------------------------------------------ The child control message loop for groupboxes @see AddMessageProc @see WndMessageProc -------------------------------------------------------------------------------} function WndMessageProcGroupbox(hWnd: HWND; Msg: UINT; wParam: wPARAM; lParam: LPARAM): LongInt; stdcall; var control: TMiniAppControl; begin if Msg=WM_CTLCOLORSTATIC then begin Result := WndMessageProc(hWnd, Msg, wParam, lParam) end else begin Result := CallWindowProc(GOldGroupboxMessageProc, hWnd, Msg, wParam, lParam) (*control := FindGlobalControl(hwnd); if Assigned(control) then begin if control.FOldMessageProc<>nil then begin Result := CallWindowProc(control.FOldMessageProc, hWnd, Msg, wParam, lParam) end else MessageBox(0, 'old msg proc emtpy!', 'pkMiniGUIApp', MB_OK); end else MessageBox(0, 'could not find control!', 'pkMiniGUIApp', MB_OK);*) end; end; // Command Bar Helper Macros // These are defined as makros in C, since they just wrap standard calls. {$IFDEF WinCE} {*------------------------------------------------------------------------------ Adds one or more buttons to a CommandBar @param hwndCB Handle to the command bars window, returned by CommandBar_Create @param uNumButtons Number of buttons to add @param lpButtons Array of records describing the buttons to add @return Returns the success status @see CommandBar_InsertButton @see CommandBar_AddToolTips -------------------------------------------------------------------------------} function CommandBar_AddButtons(hwndCB: hWnd; uNumButtons: UInt; var lpButtons: array of TBBUTTON): WINBOOL; begin Result := SendMessage(hwndCB, TB_ADDBUTTONS, uNumButtons, LongInt(@lpButtons[0])) = 0; end; {*------------------------------------------------------------------------------ Adds tooltips to buttons on a command bar @param hwndCB Handle to the command bars window, returned by CommandBar_Create @param uNumButtons Number of tooltips to add @param lpButtons Array of strings containing tooltips @return Returns the success status @see CommandBar_InsertButton @see CommandBar_AddButtons -------------------------------------------------------------------------------} function CommandBar_AddToolTips(hwndCB: hWnd; uNumToolTips: UInt; lpToolTips: PWideChar): WINBOOL; begin Result := SendMessage(hwndCB, TB_SETTOOLTIPS, uNumToolTips, LongInt(lpToolTips)) = 0; end; {*------------------------------------------------------------------------------ Destroys a command bar @param hwndCB Handle to the command bars window, returned by CommandBar_Create -------------------------------------------------------------------------------} procedure CommandBar_Destroy(hwndCB: hWnd); begin DestroyWindow(hwndCB); end; {*------------------------------------------------------------------------------ Checks whether a command bar is visible @param hwndCB Handle to the command bars window, returned by CommandBar_Create @return Visibility of command bar. -------------------------------------------------------------------------------} function CommandBar_IsVisible(hwndCB: hWnd): WINBOOL; begin Result := IsWindowVisible(hwndCB); end; {*------------------------------------------------------------------------------ Inserts a button into a toolbar @param hwndCB Handle to the command bars window, returned by CommandBar_Create @param iButton Index of the button to add @param lpButtons Record describing the buttons to add @return Returns the success status @see CommandBar_AddButtons @see CommandBar_AddToolTips -------------------------------------------------------------------------------} function CommandBar_InsertButton(hwndCB: hWnd; iButton: integer; lpButton: TBBUTTON): WINBOOL; begin Result := SendMessage(hwndCB, TB_INSERTBUTTON, iButton, LongInt(@lpButton)) = 0; end; {$ENDIF WinCE} { TMiniAppWindow } {*------------------------------------------------------------------------------ Calls the applications event handler for errors @param ErrorText Plaintext description of the error. -------------------------------------------------------------------------------} procedure TMiniAppWindow.FireMiniAppError(ErrorText: MiniString); var dwError: DWord; begin dwError := GetLastError; if Assigned(FOnMiniAppError) then FOnMiniAppError(dwError, ErrorText) else AppErrorBox(PMiniChar(ErrorText)); end; {*------------------------------------------------------------------------------ Returns the forms main menu object, and creates a main menu if it doesn't exist yet @return Main menu object -------------------------------------------------------------------------------} function TMiniAppWindow.GetMainMenu: TMiniAppMainMenu; begin if not Assigned(FMainMenu) then FMainMenu := TMiniAppMainMenu.Create(Self); Result := FMainMenu; end; {*------------------------------------------------------------------------------ Returns the forms main toolbar object, and creates a main toolbar if it doesn't exist yet @return Main menu object -------------------------------------------------------------------------------} function TMiniAppWindow.GetToolbar: TMiniAppToolbar; begin if not Assigned(FToolbar) then FToolbar := TMiniAppToolbar.Create(Self); Result := FToolbar; end; {*------------------------------------------------------------------------------ Looks for a stored OnClick handler @param AHandle Handle of the object that fired the OnClick event @return Returns the OnClick handler, if one exists, otherwise nil -------------------------------------------------------------------------------} function TMiniAppWindow.GetMiniClickHandler(AHandle: integer): TOnMiniClick; var i: integer; begin Result := nil; for i := 0 to Pred(Length(FOnMiniClickHandlers)) do if Integer(FOnMiniClickHandlers[i].Handle)=AParam then Result := FOnMiniClickHandlers[i].Handler; end; {*------------------------------------------------------------------------------ Looks for a OnClick handler associated with a resource ID. @param AResourceID ID of the control specified in the resource file @return Returns the OnClick handler, if one exists, otherwise nil -------------------------------------------------------------------------------} function TMiniAppWindow.GetMiniResourceHandler(AResourceID: Word): TOnMiniClick; var i: integer; begin Result := nil; for i := 0 to Pred(Length(FOnMiniResourceHandlers)) do if Integer(FOnMiniResourceHandlers[i].ResourceID)=AResourceID then Result := FOnMiniResourceHandlers[i].Handler; end; {*------------------------------------------------------------------------------ Adds a character input handler to a control by handle. NOT YET FULLY IMPLEMENTED @param AHandle Handle to the control this handler is for. @param AHandler Handler for character input events. -------------------------------------------------------------------------------} procedure TMiniAppWindow.AddMiniCharHandler(AHandle: hWnd; AHandler: TOnMiniChar); var iIndex: integer; begin iIndex := Length(FOnMiniCharHandlers); SetLength(FOnMiniCharHandlers,iIndex+1); FOnMiniCharHandlers[iIndex].Handle := AHandle; FOnMiniCharHandlers[iIndex].Handler := AHandler; end; {*------------------------------------------------------------------------------ Adds a textfield change handler to a control by handle @param AHandle Handle to the control this handler is for. @param AHandler Handler for text change events. -------------------------------------------------------------------------------} procedure TMiniAppWindow.AddMiniChangeHandler(AHandle: hWnd; AHandler: TOnMiniChange); var iIndex: integer; begin iIndex := Length(FOnMiniChangeHandlers); SetLength(FOnMiniChangeHandlers,iIndex+1); FOnMiniChangeHandlers[iIndex].Handle := AHandle; FOnMiniChangeHandlers[iIndex].Handler := AHandler; end; {*------------------------------------------------------------------------------ Looks if a handler for a character input on a control was set. @param AHandle Handle to the control this handler is for. @return Handler for character input, if one was associated with that handle, otherwise nil. -------------------------------------------------------------------------------} function TMiniAppWindow.GetMiniCharHandler(AHandle: integer): TOnMiniChar; var i: integer; begin Result := nil; for i := 0 to Pred(Length(FOnMiniCharHandlers)) do if Integer(FOnMiniCharHandlers[i].Handle)=AParam then Result := FOnMiniCharHandlers[i].Handler; end; {*------------------------------------------------------------------------------ Looks if a handler for text change on a control was set. @param AHandle Handle to the control this handler is for. @return Handler for text changes, if one was associated with that handle, otherwise nil. -------------------------------------------------------------------------------} function TMiniAppWindow.GetMiniChangeHandler(AHandle: integer): TOnMiniChange; var i: integer; begin Result := nil; for i := 0 to Pred(Length(FOnMiniChangeHandlers)) do if Integer(FOnMiniChangeHandlers[i].Handle)=AParam then Result := FOnMiniChangeHandlers[i].Handler; end; {*------------------------------------------------------------------------------ Method for handling things once form has been created, NOT YET IN USE. -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoCreate; begin // not used currently end; {*------------------------------------------------------------------------------ Method for handling things when form gets destroyed, NOT YET IN USE. -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoDestroy; begin // not used currently end; {*------------------------------------------------------------------------------ This method gets called when the windows gets activated or deactivated. @Param AActive Tells about the active status of the application. @Param AMinized Specifies whether to window is minimized. @Param AHandlePrev Handle to the window that gets activated (AActive=WA_INACTIVE), or gets deactivated (AActive=WA_ACTIVE or WA_CLICKACTIVE). -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoActivate(AActive: Word; AMinimized: Word; AHandlePrev: hWnd); begin // WA_CLICKACTIVE Activated by a mouse click // WA_ACTIVE Activated by some other method // WA_INACTIVE Deactivated if (AActive=WA_ACTIVE) or (AActive=WA_CLICKACTIVE) then try UpdateFullScreen; except end; end; {*------------------------------------------------------------------------------ This method processes WM_NOTIFY messages and calls associated framework handlers if they exist @Param AControl Handle of control that the WM_NOTIFY is about. @Param AHeader A pointer to a NMHDR header, may also point to a larger structure, then with NMHDR as the first part of them. -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoNotify(AControl: THandle; AHeader: PNMHDR); var maControl: TMiniAppControl; begin maControl := GetChildByHandle(AHeader^.hwndFrom); if not Assigned(maControl) then Exit; if (maControl is TMiniAppTreeView) then case AHeader^.code of TVN_SELCHANGING: begin // TODO : implement SelChanging handler, containing which parameters? // MessageBox(0,'TVN_SELCHANGING','TVN_SELCHANGING',0); end; TVN_SELCHANGED: begin // TODO : implement SelChanging handler, containing which parameters? // MessageBox(0,'TVN_SELCHANGED','TVN_SELCHANGED',0); end; TVN_BEGINLABELEDIT: ; TVN_ENDLABELEDIT: ; TVN_DELETEITEM: ; TVN_ITEMEXPANDED: ; TVN_ITEMEXPANDING: ; TVN_BEGINDRAG: ; TVN_KEYDOWN: ; end; if (maControl is TMiniAppListView) then case AHeader^.code of LVN_ITEMACTIVATE: begin // DONE : implement item notification here! (maControl as TMiniAppListView).DoOnItemActivate(PNMLISTVIEW(AHeader)); end; end; end; {*------------------------------------------------------------------------------ This method processes WM_COMMAND messages and calls associated framework handlers if they exist @Param ANotifyCode Code of event that takes place. @Param AID Identifier of menu item, control or accelerator. @Param AParam Handle to the control the event is about. -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoCommand(ANotifyCode, AID: Word; AParam: Integer); var handlerClick: TOnMiniClick; handlerChange: TOnMiniChange; begin handlerClick := GetMiniClickHandler(AParam); if Assigned(handlerClick) then handlerClick; case ANotifyCode of EN_CHANGE: begin handlerChange := GetMiniChangeHandler(AParam); if Assigned(handlerChange) then handlerChange; end; end; // case end; {*------------------------------------------------------------------------------ This method processes a menu item event @Param ANotifyCode Code of event that takes place. @Param AID Identifier of menu item, control or accelerator. -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoMenu(ANotifyCode, AID: Word); var handler: TOnMiniClick; begin handler := GetMiniResourceHandler(AID); if Assigned(handler) then handler; end; {*------------------------------------------------------------------------------ This method processes character inputs. @Param ACharCode Code of char pressed @Param AKeyCode Code of key pressed -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoChar(ACharCode, AKeyCode: integer); var handler: TOnMiniChar; ControlHandle: hWnd; key: MiniChar; begin // TODO // This function should be completely overhauled! ControlHandle := 0; handler := GetMiniCharHandler(integer(ControlHandle)); key := MiniChar(ACharCode); if Assigned(handler) then handler(key); end; {*------------------------------------------------------------------------------ This method processes changes in global system settings It is very useful to get notification of screen rotations, in which case we need to readjust alignments. @Param AFlag Flag of change @Param SectionName Name of section that experiences change -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoSettingChange(AFlag: Word; ASectionName: PMiniChar); begin // TODO : it may be better to react to WM_NCCALCSIZE with UpdateChildAlignments // when rotating the device, we get: // AFlag = 224 = SPI_SETSIPINFO ... = 1110 0000 = E0 ... // AFlag =1 2290; in bytes: 48 = SPI_GETWORKAREA, 2 = 08F2... if AFlag=224 then UpdateChildAlignments; end; {*------------------------------------------------------------------------------ Re-calculates alignments of control on form -------------------------------------------------------------------------------} procedure TMiniAppWindow.DoCalcSize; begin UpdateAlignments; end; {*------------------------------------------------------------------------------ Checks the height of the main toolbar @return The height of the toolbar, or 0 if not toolbar exists. -------------------------------------------------------------------------------} function TMiniAppWindow.GetToolbarHeight: integer; begin if Assigned(FToolbar) then Result := FToolbar.Height else Result := 0; end; {*------------------------------------------------------------------------------ Enables or disables the OK button in the title bar This works only on Windows CE. @param AValue Boolean that determines if the OK button should be visible. -------------------------------------------------------------------------------} procedure TMiniAppWindow.SetDoneButtonVisible(const AValue: boolean); begin if FDoneButtonVisible=AValue then Exit; FDoneButtonVisible := AValue; {$IFDEF WinCE} case AValue of true: SHDoneButton(FHandle, SHDB_SHOW); false: SHDoneButton(FHandle, SHDB_HIDE); end; {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Enables or disables the Special Input Panel button responsible for showing/hiding the virtual keyboard. This works only on Windows CE. @param AValue Boolean that determines if the SIP should be visible. -------------------------------------------------------------------------------} procedure TMiniAppWindow.SetShowSIPButton(const AValue: boolean); begin if FShowSIPButton=AValue then Exit; FShowSIPButton := AValue; UpdateFullScreen; end; {*------------------------------------------------------------------------------ Enables or disables the start icon. This works only on Windows CE. @param AValue Boolean that determines if the SIP should be visible. -------------------------------------------------------------------------------} procedure TMiniAppWindow.SetShowStartIcon(const AValue: boolean); begin if FShowStartIcon=AValue then Exit; FShowStartIcon := AValue; UpdateFullScreen; end; {*------------------------------------------------------------------------------ Enables or disables the task bar. This works only on Windows CE. @param AValue Boolean that determines if the SIP should be visible. -------------------------------------------------------------------------------} procedure TMiniAppWindow.SetShowTaskbar(const AValue: boolean); begin if FShowTaskbar=AValue then Exit; FShowTaskbar := AValue; UpdateFullScreen; end; {*------------------------------------------------------------------------------ Sets the title of the current window. Without this, fullscreen mode on Windows CE devices would still have the name of the previously active application on its task bar. This works only on Windows CE currently, should be expanded to Win32. @param AValue Title of window -------------------------------------------------------------------------------} procedure TMiniAppWindow.SetWindowTitle(const AValue: MiniString); begin if AValue=FWindowTitle then Exit; FWindowTitle := AValue; FText := AValue; {$IFDEF WinCE} SHSetNavBarText(FHandle, PWideChar(FWindowTitle)); {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Updates the window with full-screen, task bar, start icon and SIP button settings This works only on Windows CE. -------------------------------------------------------------------------------} procedure TMiniAppWindow.UpdateFullScreen; var dwState: Dword; {$IFDEF WinCE} shidi: SHINITDLGINFO; {$ENDIF WinCE} begin dwState := 0; {$IFDEF WinCE} if FShowTaskBar then dwState := dwState or SHFS_SHOWTASKBAR else dwState := dwState or SHFS_HIDETASKBAR; if FShowSIPButton then dwState := dwState or SHFS_SHOWSIPBUTTON else dwState := dwState or SHFS_HIDESIPBUTTON; if FShowStartIcon then dwState := dwState or SHFS_SHOWSTARTICON else dwState := dwState or SHFS_HIDESTARTICON; shidi.hDlg := FHandle; shidi.dwMask := SHIDIM_FLAGS; shidi.dwFlags := SHIDIF_SIZEDLGFULLSCREEN or SHIDIF_DONEBUTTON; SHInitDialog(@shidi); // SetForegroundWindow(FHandle); if not SHFullScreen(FHandle, dwState) then ; // AppErrorBox('Could not switch fullscreen mode!'); // TODO {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Adds a click handler to a control by handle. @param AHandle Handle to the control this handler is for. @param AHandler Handler for click events. -------------------------------------------------------------------------------} procedure TMiniAppWindow.AddMiniClickHandler(AHandle: hWnd; AHandler: TOnMiniClick); var iIndex: integer; begin iIndex := Length(FOnMiniClickHandlers); SetLength(FOnMiniClickHandlers,iIndex+1); FOnMiniClickHandlers[iIndex].Handle := AHandle; FOnMiniClickHandlers[iIndex].Handler := AHandler; end; {*------------------------------------------------------------------------------ Adds a click handler to a control by resource ID. Intended for controls created from the resource file, like the Windows CE menu buttons at the bottom, which are currently only supported this way. @param AHandle ID of the resource this handler is for. @param AHandler Handler for click events. -------------------------------------------------------------------------------} procedure TMiniAppWindow.AddMiniResourceHandler(AResourceID: Word; AHandler: TOnMiniClick); var iIndex: integer; begin iIndex := Length(FOnMiniResourceHandlers); SetLength(FOnMiniResourceHandlers,iIndex+1); FOnMiniResourceHandlers[iIndex].ResourceID := AResourceID; FOnMiniResourceHandlers[iIndex].Handler := AHandler; end; {*------------------------------------------------------------------------------ This is the main application loop, which handles receiving, translating and dispatching messages. You should call this at the end of your inherited classes constructor. -------------------------------------------------------------------------------} procedure TMiniAppWindow.Run; var msgMain: TMSG; begin {$IFDEF Win32} if Assigned(FMainMenu) then SetMenu(FHandle, FMainMenu.Handle); {$ENDIF Win32} GLastBackgroundDC := 0; while GetMessage(@msgMain,0,0,0) do begin TranslateMessage(@msgMain); DispatchMessage(@msgMain); end; end; {*------------------------------------------------------------------------------ This open a modal message box dialog that belongs to the current window. This is the version for null-terminated strings. @param ACaption Text that should be displayed on message box. @param AType Type of message box, see MSDN MessageBox for more information. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppMessageBox(ACaption: PMiniChar; AType: UINT): LongInt; begin Result := MessageBox(Handle, ACaption, PMiniChar(FWindowTitle), AType); end; {*------------------------------------------------------------------------------ This open a modal message box dialog that belongs to the current window. This is the version for Pascal type strings. @param ACaption Text that should be displayed on message box. @param AType Type of message box, see MSDN MessageBox for more information. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppMessageBox(ACaption: MiniString; AType: UINT ): LongInt; begin Result := AppMessageBox(PMiniChar(ACaption), AType); end; {*------------------------------------------------------------------------------ This open an modal error text message box that belongs to the current window. This is the version for null-terminated strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppErrorBox(ACaption: PMiniChar): LongInt; begin Result := AppMessageBox(ACaption, MB_OK or MB_ICONERROR); end; {*------------------------------------------------------------------------------ This open an modal error text message box that belongs to the current window. This is the version for Pascal type strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppErrorBox(ACaption: MiniString): LongInt; begin Result := AppErrorBox(PMiniChar(ACaption)); end; {*------------------------------------------------------------------------------ This open an modal important text message box that belongs to the current window. This is the version for null-terminated strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppExclamationBox(ACaption: PMiniChar): LongInt; begin Result := AppMessageBox(ACaption, MB_OK or MB_ICONEXCLAMATION); end; {*------------------------------------------------------------------------------ This open an modal important text message box that belongs to the current window. This is the version for Pascal type strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppExclamationBox(ACaption: MiniString): LongInt; begin Result := AppExclamationBox(PMiniChar(ACaption)); end; {*------------------------------------------------------------------------------ This open an modal information text message box that belongs to the current window. This is the version for null-terminated strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppInformationBox(ACaption: PMiniChar): LongInt; begin Result := AppMessageBox(ACaption, MB_OK or MB_ICONINFORMATION); end; {*------------------------------------------------------------------------------ This open an modal information text message box that belongs to the current window. This is the version for Pascal type strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppInformationBox(ACaption: MiniString): LongInt; begin Result := AppInformationBox(PMiniChar(ACaption)); end; {*------------------------------------------------------------------------------ This open an modal warning text message box that belongs to the current window. This is the version for null-terminated strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppWarningBox(ACaption: PMiniChar): LongInt; begin Result := AppMessageBox(ACaption, MB_OK or MB_ICONWARNING); end; {*------------------------------------------------------------------------------ This open an modal warning text message box that belongs to the current window. This is the version for Pascal type strings. @param ACaption Text that should be displayed on message box. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppWarningBox(ACaption: MiniString): LongInt; begin Result := AppWarningBox(PMiniChar(ACaption)); end; {*------------------------------------------------------------------------------ This open an modal confirmation text message box that belongs to the current window. This is the version for null-terminated strings. @param ACaption Text that should be displayed on message box. @param AWithCancel If set to true, the message box will also offer a Cancel button. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppConfirmationBox(ACaption: PMiniChar; AWithCancel: boolean): LongInt; begin if AWithCancel then Result := AppMessageBox(ACaption, MB_YESNOCANCEL or MB_ICONQUESTION) else Result := AppMessageBox(ACaption, MB_YESNO or MB_ICONQUESTION); end; {*------------------------------------------------------------------------------ This open an modal confirmation text message box that belongs to the current window. This is the version for Pascal type strings. @param ACaption Text that should be displayed on message box. @param AWithCancel If set to true, the message box will also offer a Cancel button. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppConfirmationBox(ACaption: MiniString; AWithCancel: boolean): LongInt; begin Result := AppConfirmationBox(PMiniChar(ACaption), AWithCancel); end; {$IFDEF Win32} {*------------------------------------------------------------------------------ This open an custom message box that belongs to the current window. This is only available on Win32 machines, not on WinCE! @param ACaption Text that should be displayed on message box. @param AResourceName Name of the resource containing the message icon. @param AType Type of message box, see MSDN MessageBox for more information. @return ID of button pressed. -------------------------------------------------------------------------------} function TMiniAppWindow.AppCustomIconBox(ACaption, AResourceName: PMiniChar; AType: UINT): boolean; var mbp: MSGBOXPARAMS; begin FillChar(mbp, SizeOf(mbp), 0); mbp.cbSize := SizeOf(mbp); mbp.hwndOwner := Handle; mbp.hInstance := hInstance; mbp.lpszText := ACaption; mbp.lpszCaption := PMiniChar(FWindowTitle); mbp.dwStyle := AType; mbp.lpszIcon := AResourceName; Result := MessageBoxIndirect(mbp); end; {$ENDIF Win32} {*------------------------------------------------------------------------------ Constructor of form. Use inherited version to create your controls on the form. -------------------------------------------------------------------------------} constructor TMiniAppWindow.Create; begin inherited Create(nil,'',0,0,0,0); FToolbar := nil; FMainMenu := nil; FBackgroundResource := ''; FMenuBarHandle := 0; FCESIPBarHandle := 0; FCommandBarHandle := 0; FHandle := 0; FMenuBarHandle := 0; FCommandBarHandle := 0; FWindowStyle := WS_VISIBLE or WS_MAXIMIZE or WS_SYSMENU; // or WS_CAPTION; // or WS_CAPTION : ONLY for non-fullscreen pages? // or WS_OVERLAPPED // or WS_MAXIMIZE // or WS_DLGFRAME FWindowTitle := 'Mini GUI sample application'; FBaseFontName := 'MS Sans Serif'; FClassName := 'pkMiniGUIApp'; FAboutText := 'This application was created using FreePascal and the pkMiniGUI framework.'; {$IFDEF WinCE} FLeft := Integer(CW_USEDEFAULT); FTop := Integer(CW_USEDEFAULT); FWidth := Integer(CW_USEDEFAULT); FHeight := Integer(CW_USEDEFAULT); {$ENDIF WinCE} {$IFDEF Win32} FLeft := 0; FTop := 0; FWidth := 240; FHeight := 288; {$ENDIF Win32} FDoneButtonVisible := true; FShowSIPButton := true; FShowStartIcon := true; FShowTaskbar := true; SetLength(FOnMiniClickHandlers,0); SetLength(FOnMiniResourceHandlers,0); SetLength(FOnMiniCharHandlers,0); SetLength(FOnMiniChangeHandlers,0); end; {*------------------------------------------------------------------------------ Destructor of form. -------------------------------------------------------------------------------} destructor TMiniAppWindow.Destroy; begin SetLength(FOnMiniClickHandlers,0); SetLength(FOnMiniResourceHandlers,0); SetLength(FOnMiniCharHandlers,0); SetLength(FOnMiniChangeHandlers,0); if Assigned(FToolbar) then FToolbar.Free; if Assigned(FMainMenu) then FMainMenu.Free; if FBackgroundDC>0 then begin // clean up background image SelectObject(FBackgroundDC, FBackgroundOldBitmap); FBackgroundOldBitmap := 0; DeleteDC(FBackgroundDC); FBackgroundDC := 0; DeleteObject(FBackgroundBitmap); FBackgroundBitmap := 0; end; inherited; end; {*------------------------------------------------------------------------------ Initialization of form, you should call this at the very beginning of your inherited constructor of the window. If you want to use the two menu buttons at the bottom of your Windows CE application, you need to set AResourceMenuID here! @param AClassName Name of window class, should be unique. @param AResourceMenuID ID of resource containing your menu (Windows CE). -------------------------------------------------------------------------------} procedure TMiniAppWindow.Initialize(AClassName: AnsiString; AResourceMenuID: integer); var rectWindow: TRect; dwExStyle: DWord; tmpMenu: THandle; hDC: THandle; {$IFDEF WinCE} mbiMain: SHMenuBarInfo; {$ENDIF WinCE} begin FClassName := AClassName; FWindowClass.hInstance := hInstance; if IsFontSupported then begin {$IFDEF Win32} FFontHandle := GetGlobalFont('MS Sans Serif', 16, true, false, false, false); {$ELSE Win32} // FFontHandle := GetGlobalFont('', 16, true, false, false, false); FFontHandle := 0; {$ENDIF Win32} GDefaultFontHandle := FFontHandle; end; with FWindowClass do begin style := 0; hIcon := LoadIcon(hInstance,'MAINICON'); lpfnWndProc := TWndMessageProc(@WndMessageProc); {$IFDEF WinCE} hbrBackground := COLOR_BTNFACE; {$ELSE WinCE} hbrBackground := COLOR_BTNFACE+1; {$ENDIF WinCE} // COLOR_BTNFACE is not a brush, but sets it to a system brush of that Color lpszClassName := PMiniChar(MiniString(AClassName)); cbClsExtra := 0; cbWndExtra := 0; {$IFDEF Win32} hCursor := LoadCursor(0,IDC_ARROW); lpszMenuName := ''; {$ENDIF Win32} end; RegisterClass(FWindowClass); dwExStyle := 0; {$IFDEF WinCE} dwExStyle := WS_EX_NODRAG or WS_EX_NOANIMATION or WS_EX_CAPTIONOKBTN; {$ENDIF WinCE} // WS_EX_NODRAG : window can't be moved // WS_EX_NOANIMATION : start menu doesn't get moved to the bottom FMenuBarHandle := CreateMenu; FHandle := CreateWindowEx(dwExStyle, FWindowClass.lpszClassName, PMiniChar(FWindowTitle), FWindowStyle, FLeft, FTop, FWidth, FHeight, 0, FMenuBarHandle, hInstance, nil); if Handle = 0 then begin FireMiniAppError('Could not create application window!'); UnRegisterClass(FWindowClass.lpszClassName, hInstance); Exit; end; // Add message loop AddMessageProc(Handle, Self); // Add background image if Length(FBackgroundResource)>0 then begin hDC := GetDC(FHandle); if hDC>0 then begin FBackgroundBitmap := LoadImage(hInstance, PMiniChar(FBackgroundResource), IMAGE_BITMAP, 0, 0, 0); FBackgroundDC := CreateCompatibleDC(hDC); FBackgroundOldBitmap := SelectObject(FBackgroundDC, FBackgroundBitmap); GLastBackgroundDC := FBackgroundDC; ReleaseDC(FHandle, hDC); end; end; // Set fonts SetBaseFont(Handle); {$IFDEF WinCE} // Attention with the menu; PPC2002 shows a full menu, smartphones and // Mobile 5.0 devices only two buttons. if AResourceMenuID>0 then begin // We have been told to load a menu from the version resources. FillChar(mbiMain,SizeOf(mbiMain),Byte(0)); with mbiMain do begin cbSize := SizeOf(mbiMain); hwndParent := Handle; dwFlags := SHCMBF_HMENU; nToolBarID := 202; hInstRes := hInstance; nBmpId := 0; cBmpImages := 0; clrBk := 0; end; if not SHCreateMenuBar(@mbiMain) then begin FCESIPBarHandle := 0; {AOwnerWindow.}AppErrorBox('Could not create menu bar!'); end else begin FCESIPBarHandle := mbiMain.hwndMB; // CommandBar_InsertMenubarEx(ceMenuBar, 0, FMenuBarHandle, 0); end; end else begin // Let's build our own menu. FillChar(mbiMain,SizeOf(mbiMain),Byte(0)); with mbiMain do begin cbSize := SizeOf(mbiMain); hwndParent := Handle; dwFlags := SHCMBF_EMPTYBAR; nToolBarID := 0; hInstRes := hInstance; nBmpId := 0; cBmpImages := 0; clrBk := 0; end; if not SHCreateMenuBar(@mbiMain) then begin FCESIPBarHandle := 0; {AOwnerWindow.}AppErrorBox('Could not create menu bar!'); end else begin FCESIPBarHandle := mbiMain.hwndMB; end; end; {$ENDIF WinCE} ShowWindow(FHandle, SW_SHOW); UpdateFullScreen; {$IFDEF WinCE} SHSetNavBarText(FHandle, nil); {$ENDIF WinCE} UpdateWindow(FHandle); GetWindowRect(Handle,@rectWindow); FLeft := rectWindow.Left; FTop := rectWindow.Top; FWidth := rectWindow.Right - rectWindow.Left; FHeight := rectWindow.Bottom - rectWindow.Top; end; { TMiniAppControl } {*------------------------------------------------------------------------------ Checks if fonts are supported on this system; was useful only when we didn't have font support for Windows CE devices yet. @return Support status -------------------------------------------------------------------------------} function TMiniAppControl.IsFontSupported: boolean; begin Result := true; end; {*------------------------------------------------------------------------------ Sets the alignment borders of a control. @param AValue The borders the control should be aligned to. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetAlign(const AValue: TMiniAligns); begin if FAlign=AValue then Exit; FAlign := AValue; if not Assigned(FParentControl) then Exit; FDistanceLeft := Self.Left; FDistanceTop := Self.Top; FDistanceRight := FParentControl.Width - Self.Left - Self.Width; FDistanceBottom := FParentControl.Height - Self.Height - Self.Top; end; {*------------------------------------------------------------------------------ Returns the coordinates of the client area rectangle. @return The coordinates of the client area rectangle. -------------------------------------------------------------------------------} function TMiniAppControl.GetClientRect: TRect; begin Windows.GetClientRect(FHandle, @Result); end; {*------------------------------------------------------------------------------ Returns the height of the client area. @return The height of the client area. -------------------------------------------------------------------------------} function TMiniAppControl.GetClientHeight: integer; begin Result := ClientRect.Bottom; end; {*------------------------------------------------------------------------------ Returns the width of the client area. @return The width of the client area. -------------------------------------------------------------------------------} function TMiniAppControl.GetClientWidth: integer; begin Result := ClientRect.Right; end; {*------------------------------------------------------------------------------ Returns the default icon width on this system. Important for example on QVGA Windows Mobile smartphones, which may have the unusual icon width of 44 pixels. @return The default icon width on this system -------------------------------------------------------------------------------} function TMiniAppControl.GetDefaultIconWidth: integer; begin if FDefaultIconWidth>0 then Result := FDefaultIconWidth else begin FDefaultIconWidth := GetSystemMetrics(SM_CXICON); Result := FDefaultIconWidth; end; end; {*------------------------------------------------------------------------------ Right now just a preliminary way to check if this device needs special icon handling. @return Whether this device is a smartphone. -------------------------------------------------------------------------------} function TMiniAppControl.GetIsSmartphone: boolean; begin Result := GetDefaultIconWidth<>32; end; {*------------------------------------------------------------------------------ Returns the text of a control. @return The text. -------------------------------------------------------------------------------} function TMiniAppControl.GetText: MiniString; var dwLen: DWord; pc: PMiniChar; begin dwLen := GetWindowTextLength(FHandle); if dwLen=0 then begin FText := ''; Result := ''; end else begin GetMem(pc, dwLen+1); GetWindowText(FHandle, pc, dwLen+1); Result := pc; FreeMem(pc, dwLen+1); FText := Result; end; end; {*------------------------------------------------------------------------------ Sets the font settings of a control to the default font settings. @param AWindow Handle to the control that should receive the font settings. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetBaseFont(AWindow: hWnd); begin if IsFontSupported then SendMessage(AWindow, WM_SETFONT, GDefaultFontHandle, 0); end; {*------------------------------------------------------------------------------ Changes the height of a control. @param AValue New height for control. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetHeight(const AValue: integer); begin if FHeight=AValue then Exit; FHeight := Avalue; UpdateControlPos; end; {*------------------------------------------------------------------------------ Changes the left border of a control. @param AValue New left border for control. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetLeft(const AValue: integer); begin if FLeft=AValue then Exit; FLeft := Avalue; UpdateControlPos; end; {*------------------------------------------------------------------------------ Sets an event handler for character input events. @param AValue Handler for character inputs. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetOnChar(const AValue: TOnMiniChar); begin if FOnChar=AValue then Exit; // TODO: change event loop here! if Assigned(FWindow) then begin if Assigned(FOnChar) then begin // TODO: remove old handler end; FWindow.AddMiniCharHandler(FHandle, AValue); end; FOnChar := AValue; end; {*------------------------------------------------------------------------------ Sets an event handler for click events. @param AValue Handler for clicks. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetOnClick(const AValue: TOnMiniClick); begin if FOnClick=AValue then Exit; // TODO: change event loop here! if Assigned(FWindow) then begin if Assigned(FOnClick) then begin // TODO: remove old handler end; if FHandle>0 then FWindow.AddMiniClickHandler(FHandle, AValue) else if FResourceID>0 then FWindow.AddMiniResourceHandler(FResourceID, AValue); end; FOnClick := AValue; end; {*------------------------------------------------------------------------------ Sets the text displayed by a control. @param AValue New text for control. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetText(const AValue: MiniString); begin FText := AValue; if not SetWindowText(FHandle, PMiniChar(FText)) then MessageBox(0,PMiniChar(FText),'Text set error',MB_OK); end; {*------------------------------------------------------------------------------ Sets the top border of a control. @param AValue The new top border for the control. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetTop(const AValue: integer); begin if FTop=AValue then Exit; FTop := Avalue; UpdateControlPos; end; {*------------------------------------------------------------------------------ Toggles whether a control should have a transparent background. @param AValue Set to true if control should be transparent. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetTransparent(const AValue: boolean); begin if AValue=FTransparent then Exit; FTransparent := AValue; UpdateWindow(FHandle); ShowWindow(FHandle, SW_SHOW); InvalidateRect(FHandle, nil, true); end; {*------------------------------------------------------------------------------ Toggles whether a control should be visible. @param AValue Set to false if you want to hide the control. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetVisible(const AValue: boolean); begin if FVisible=AValue then Exit; FVisible := AValue; case FVisible of true: ShowWindow(FHandle, SW_SHOW); // AddControlStyle(WS_VISIBLE); false: ShowWindow(FHandle, SW_HIDE); // RemoveControlStyle(WS_VISIBLE); end; end; {*------------------------------------------------------------------------------ Sets the width of a control. @param AValue The new width for the control. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetWidth(const AValue: integer); begin if FWidth=AValue then Exit; FWidth := Avalue; UpdateControlPos; end; {*------------------------------------------------------------------------------ Adds a new control to the list of childs of this one. @param AChild The object of a new child control of this control. -------------------------------------------------------------------------------} procedure TMiniAppControl.RegisterChildControl(AChild: TMiniAppControl); begin Inc(FComponentCount); SetLength(FComponents, FComponentCount); FComponents[Pred(FComponentCount)] := AChild; end; {*------------------------------------------------------------------------------ Returns the object of a child control known only by handle. @param AHandle Handle of the child to look for. @return The control, if found, otherwise nil. -------------------------------------------------------------------------------} function TMiniAppControl.GetChildByHandle(AHandle: hWnd): TMiniAppControl; var iComponent: integer; begin Result := nil; if FComponentCount=0 then Exit; for iComponent := 0 to Pred(FComponentCount) do begin if FComponents[iComponent].FHandle=AHandle then begin Result := FComponents[iComponent]; Exit; end; end; end; {*------------------------------------------------------------------------------ Updates the position and size of a control. @param AMove Determines if the change includes a change of position or only of size. -------------------------------------------------------------------------------} procedure TMiniAppControl.UpdateControlPos(AMove: boolean); begin if AMove then SetWindowPos(FHandle, 0, FLeft, FTop, FWidth, FHeight, SWP_NOMOVE or SWP_NOZORDER) else SetWindowPos(FHandle, 0, FLeft, FTop, FWidth, FHeight, {SWP_NOMOVE or }SWP_NOZORDER); end; {*------------------------------------------------------------------------------ Updates the alignments to borders based on the Align property. @see UpdateChildAlignments @see Align -------------------------------------------------------------------------------} procedure TMiniAppControl.UpdateAlignments; var bMove: boolean; rectControl, rectParent: TRect; begin if not Assigned(FParentControl) then Exit; if FAlign <> [] then begin FTop := FDistanceTop; // horizontal alignments if (malLeft in FAlign) and (not (malRight in FAlign)) // just left then FLeft := FDistanceLeft else if (malLeft in FAlign) and (malRight in FAlign) // both then FWidth := FParentControl.Width - FDistanceLeft - FDistanceRight else if (not (malLeft in FAlign)) and (malRight in FAlign) // just right then FLeft := FParentControl.Width - FWidth - FDistanceRight; // vertical alignments // TODO if (malTop in FAlign) and (not (malBottom in FAlign)) then begin // just top FTop := FDistanceTop; end else if (malTop in FAlign) and (malBottom in FAlign) then begin// both FHeight := FParentControl.Height - FDistanceTop - FDistanceBottom; end else if (not (malTop in FAlign)) and (malBottom in FAlign) then begin // just bottom FTop := FParentControl.Height - FHeight - FDistanceBottom; end; bMove := (malRight in FAlign) or (malBottom in FAlign); UpdateControlPos(bMove); end; UpdateChildAlignments; end; {*------------------------------------------------------------------------------ Updates the alignment of child controls based on the Align property. @see UpdateAlignments @see Align -------------------------------------------------------------------------------} procedure TMiniAppControl.UpdateChildAlignments; var iComponent: integer; rectWindow: TRect; begin GetWindowRect(Handle,@rectWindow); // rectWindow := GetClientRect; FLeft := rectWindow.Left; FTop := rectWindow.Top; FWidth := rectWindow.Right - rectWindow.Left; FHeight := rectWindow.Bottom - rectWindow.Top; if FComponentCount=0 then Exit; for iComponent := 0 to Pred(FComponentCount) do begin FComponents[iComponent].UpdateAlignments; end; end; {*------------------------------------------------------------------------------ Shifts coordinates by offsets used by e.g. a toolbar. @param AOwner Parent control object. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. -------------------------------------------------------------------------------} procedure TMiniAppControl.ShiftPositionOffset(AOwner: TMiniAppControl; var ALeft, ATop, AWidth, AHeight: integer); begin if Assigned(AOwner) then if (AOwner is TMiniAppWindow) then begin Inc(ATop, (AOwner as TMiniAppWindow).ToolbarHeight); end; end; {*------------------------------------------------------------------------------ Standard constructor for controls. @param AOwner Parent control object. @param AText Default text for control. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. -------------------------------------------------------------------------------} constructor TMiniAppControl.Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth, AHeight: integer); var mac: TMiniAppControl; begin FParentControl := AOwner; Create(0); FText := AText; FLeft := ALeft; FTop := ATop; FWidth := AWidth; FHeight := AHeight; ShiftPositionOffset(AOwner, FLeft, FTop, FWidth, FHeight); mac := AOwner; if Assigned(mac) then mac.RegisterChildControl(Self); while Assigned(mac) do begin if (mac is TMiniAppWindow) then FWindow := TMiniAppWindow(mac); mac := AOwner.FOwner; end; end; {*------------------------------------------------------------------------------ Experimental constructor for creating a class object for an already existing control, by using its resource ID. @param AExistingID Resource ID of control. -------------------------------------------------------------------------------} constructor TMiniAppControl.Create(AExistingID: integer); begin inherited Create; AddNewGlobalControl(Self); FOldMessageProc := nil; FTransparent := false; FBackgroundDC := 0; FComponentCount := 0; SetLength(FComponents, FComponentCount); FResourceID := AExistingID; FVisible := true; FWindow := nil; FOnClick := nil; FOnChar := nil; end; {*------------------------------------------------------------------------------ Standard destructor for controls. -------------------------------------------------------------------------------} destructor TMiniAppControl.Destroy; begin inherited; end; {*------------------------------------------------------------------------------ Adds additional styles to a control, preserving existing ones. @param dwStyle Styles to add. @param bEx Set to true of styles are extended styles. -------------------------------------------------------------------------------} procedure TMiniAppControl.AddControlStyle(dwStyle: DWord; bEx: boolean = false); var dwControlStyle, nIndex: LongInt; begin case bEx of true: nIndex := GWL_EXSTYLE; false: nIndex := GWL_STYLE; end; dwControlStyle := GetWindowLong(FHandle, nIndex); dwControlStyle := dwControlStyle or dwStyle; SetWindowLong(FHandle, nIndex, dwControlStyle); end; {*------------------------------------------------------------------------------ Removes styles to a control, preserving unmentioned ones. @param dwStyle Styles to remove. @param bEx Set to true of styles are extended styles. -------------------------------------------------------------------------------} procedure TMiniAppControl.RemoveControlStyle(dwStyle: DWord; bEx: boolean = false); var dwControlStyle, nIndex: LongInt; begin case bEx of true: nIndex := GWL_EXSTYLE; false: nIndex := GWL_STYLE; end; dwControlStyle := GetWindowLong(FHandle, nIndex); if (dwControlStyle and dwStyle)>0 then begin dwControlStyle := dwControlStyle - dwStyle; SetWindowLong(FHandle, nIndex, dwControlStyle); end; end; {*------------------------------------------------------------------------------ Sets styles to a control, discarding existing ones. @param dwStyle Styles to add. @param bEx Set to true of styles are extended styles. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetControlStyle(dwStyle: DWord; bEx: boolean = false); var nIndex: LongInt; begin case bEx of true: nIndex := GWL_EXSTYLE; false: nIndex := GWL_STYLE; end; SetWindowLong(FHandle, nIndex, dwStyle); end; {*------------------------------------------------------------------------------ Sets the position and sizes of a control in one step. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. -------------------------------------------------------------------------------} procedure TMiniAppControl.SetPositionAndSize(ALeft, ATop, AWidth, AHeight: integer); begin FLeft := ALeft; FTop := ATop; FWidth := AWidth; FHeight := AHeight; UpdateControlPos; end; { TMiniAppLabel } {*------------------------------------------------------------------------------ Sets the alignment of text inside a label control. @param AValue Alignment parameter. -------------------------------------------------------------------------------} procedure TMiniAppLabel.SetTextAlign(const AValue: TMiniTextAlign); var dwControlStyle, nIndex: LongInt; procedure Check(AAlign: TMiniTextAlign; dwStyle: LongInt); begin if AValue=AAlign then begin if (dwControlStyle and dwStyle)=0 then dwControlStyle := dwControlStyle or dwStyle; end else begin if (dwControlStyle and dwStyle)>0 then dwControlStyle := dwControlStyle - dwStyle; end; end; begin if FTextAlign=AValue then Exit; nIndex := GWL_STYLE; dwControlStyle := GetWindowLong(FHandle, nIndex); Check(taLeft, SS_LEFT); Check(taCenter, SS_CENTER); Check(taRight, SS_RIGHT); SetWindowLong(FHandle, GWL_STYLE, dwControlStyle); FTextAlign := AValue; end; {*------------------------------------------------------------------------------ Constructor for label controls. @param AOwner Parent control object. @param AText Default text for label. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. If not specified or -1, the height will be guessed based on the default fonts text metrics. -------------------------------------------------------------------------------} constructor TMiniAppLabel.Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth, AHeight: integer); var ttm: tagTEXTMETRIC; ts: tagSIZE; hDC: THandle; begin inherited; FTextAlign := taLeft; if FHeight=-1 then begin hDC := GetWindowDC(0); if hDC>0 then begin //GetTextExtentPoint(hDC, PMiniChar(AText), Length(AText), @ts); //FHeight := ts.cy + 2; // GetTextExtentPoint returns the same as GetTextMetrics GetTextMetrics(hDC,@ttm); FHeight := ttm.tmHeight + 2; ReleaseDC(0, hDC); end else FHeight := 16; // our default, for problem cases end; FHandle := CreateWindow('STATIC', PMiniChar(AText), WS_VISIBLE or WS_CHILD or SS_NOTIFY or CS_CLASSDC, // or SS_NOPREFIX FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); // The following was just an example, but belongs into WM_PAINT as well (* hDC := GetDC(FHandle); if hDC>0 then begin SetBkMode(hDC, TRANSPARENT); ReleaseDC(FHandle, hDC); end; *) SetBaseFont(FHandle); end; { TMiniAppButton } {*------------------------------------------------------------------------------ Constructor for button controls. @param AOwner Parent control object. @param AText Default text for button. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. If not specified, the default height of 23 will be used. -------------------------------------------------------------------------------} constructor TMiniAppButton.Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth: integer; AHeight: integer); begin inherited; FHandle := CreateWindow('BUTTON', PMiniChar(AText), WS_VISIBLE or WS_CHILD or WS_TABSTOP or BS_PUSHBUTTON or BS_TEXT, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); SetBaseFont(FHandle); end; {*------------------------------------------------------------------------------ Experimental alternative constructor for creating a control for controls already existing due to the resource file. @param AExistingID Resource ID of button. -------------------------------------------------------------------------------} constructor TMiniAppButton.Create(AExistingID: integer); begin // TODO : doesn't really work, maybe we should remove it again // was intended to have full command bar button support only inherited Create(AExistingID); end; { TMiniAppResourceImage } {*------------------------------------------------------------------------------ Constructor for image controls based on images from the resource file. @param AOwner Parent control object. @param AResourceName Name of resource containing the image. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. -------------------------------------------------------------------------------} constructor TMiniAppResourceImage.Create(AOwner: TMiniAppControl; AResourceName: MiniString; ALeft, ATop, AWidth, AHeight: integer); begin inherited; FHandle := CreateWindow('STATIC', PMiniChar(AResourceName), WS_VISIBLE or WS_CHILD or SS_NOTIFY or SS_BITMAP, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); end; { TMiniAppResourceIcon } {*------------------------------------------------------------------------------ Constructor for icon controls based on icons from the resource file. @param AOwner Parent control object. @param AResourceName Name of resource containing the icon. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. -------------------------------------------------------------------------------} constructor TMiniAppResourceIcon.Create(AOwner: TMiniAppControl; AResourceName: MiniString; ALeft, ATop, AWidth, AHeight: integer); begin inherited; FHandle := CreateWindow('STATIC', PMiniChar(AResourceName), WS_VISIBLE or WS_CHILD or SS_NOTIFY or SS_ICON, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); end; { TMiniAppListBox } {*------------------------------------------------------------------------------ Returns the index of the currently selected item in a listbox. @return Index of selected item. -------------------------------------------------------------------------------} function TMiniAppListBox.GetAnchorIndex: integer; begin Result := SendMessage(FHandle, LB_GETANCHORINDEX, 0, 0); end; {*------------------------------------------------------------------------------ Returns the index of the item in a listbox having the caret. @return Index of careted item. -------------------------------------------------------------------------------} function TMiniAppListBox.GetCaretIndex: integer; begin Result := SendMessage(FHandle, LB_GETCARETINDEX, 0, 0); end; {*------------------------------------------------------------------------------ Returns the number of entries in a listbox. @return Number of entries. -------------------------------------------------------------------------------} function TMiniAppListBox.GetCount: integer; begin Result := SendMessage(FHandle, LB_GETCOUNT, 0, 0); end; {*------------------------------------------------------------------------------ Constructor for listbox controls. @param AOwner Parent control object. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. -------------------------------------------------------------------------------} constructor TMiniAppListBox.Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); var dwExStyle: DWord; begin {$IFDEF WinCE} dwExStyle := 0; {$ELSE WinCE} dwExStyle := WS_EX_CLIENTEDGE; {$ENDIF WinCE} inherited Create(AOwner, '', ALeft, ATop, AWidth, AHeight); FHandle := CreateWindowEx(dwExStyle, 'Listbox', nil, WS_VISIBLE or WS_CHILD or WS_TABSTOP or LBS_STANDARD or LBS_HASSTRINGS or LBS_DISABLENOSCROLL, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); SetBaseFont(FHandle); end; {*------------------------------------------------------------------------------ Adds an item to a listbox. @param AText Text to add. @return Index of new item. @see InsertString @see DeleteString @see FindString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppListBox.AddString(AText: MiniString): integer; begin Result := SendMessage(FHandle, LB_ADDSTRING, 0, Integer(PMiniChar(AText))); end; {*------------------------------------------------------------------------------ Removes an item from a listbox. @param AIndex Index of item to remove. @return The number of items left probably. @see AddString @see InsertString @see FindString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppListBox.DeleteString(AIndex: integer): integer; begin Result := SendMessage(FHandle, CB_DELETESTRING, AIndex, 0); end; {*------------------------------------------------------------------------------ Inserts an item into a listbox at a given position. @param AText Text to add. @param AIndex Position where to add string, first position will be used if this is not specified. @return Index of new item. @see AddString @see FindString @see DeleteString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppListBox.InsertString(AText: MiniString; AIndex: integer): integer; begin Result := SendMessage(FHandle, LB_INSERTSTRING, 0, Integer(PMiniChar(AText))); end; {*------------------------------------------------------------------------------ Looks for a string inside a listbox. @param AText Text to search for. @param AStartIndex Index where to start the search. @return Index of found item, or LB_ERR if nothing was found. @see AddString @see InsertString @see DeleteString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppListBox.FindString(AText: MiniString; AStartIndex: integer): integer; begin Result := SendMessage(FHandle, LB_FINDSTRING, AStartIndex, LongInt(PMiniChar(AText))); end; {*------------------------------------------------------------------------------ Returns the text of a listbox item. @param AIndex the index of the item. @return The text of the itme. @see AddString @see InsertString @see DeleteString @see FindString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppListBox.GetString(AIndex: integer): MiniString; var pcText: PMiniChar; dwLen: DWord; begin Result := ''; dwLen := SendMessage(FHandle, LB_GETTEXTLEN, AIndex, 0); if dwLen = LB_ERR then Exit; GetMem(pcText, dwLen+1); SendMessage(FHandle, LB_GETTEXT, AIndex, LongInt(pcText)); Result := pcText; FreeMem(pcText, dwLen+1); end; {*------------------------------------------------------------------------------ Removes all strings from a listbox. @see AddString @see InsertString @see DeleteString @see FindString @see GetString @see ClearStrings -------------------------------------------------------------------------------} procedure TMiniAppListBox.ClearStrings; begin SendMessage(FHandle, LB_RESETCONTENT, 0, 0); end; { TMiniAppEdit } {*------------------------------------------------------------------------------ Sets whether an edit control should be read-only. @param AValue Set to true if edit control should be readonly. -------------------------------------------------------------------------------} procedure TMiniAppEdit.SetReadOnly(const AValue: boolean); begin if FReadOnly=AValue then Exit; FReadOnly := AValue; UpdateControlStyle; end; {*------------------------------------------------------------------------------ Sets whether a control should be a password field. @param AValue Set to true if edit control should be a password field. -------------------------------------------------------------------------------} procedure TMiniAppEdit.SetPassword(const AValue: boolean); begin if FPassword=AValue then Exit; FPassword := AValue; UpdateControlStyle; end; {*------------------------------------------------------------------------------ Sets the event handler for text changes of an edit control. @param AValue Handler for changes. -------------------------------------------------------------------------------} procedure TMiniAppEdit.SetOnChange(const AValue: TOnMiniChange); begin if FOnChange=AValue then Exit; // TODO: change event loop here! if Assigned(FWindow) then begin if Assigned(FOnChange) then begin // TODO: remove old handler end; FWindow.AddMiniChangeHandler(Handle, AValue); end; FOnChange := AValue; end; {*------------------------------------------------------------------------------ Sets the char used in password fields to mask the input from the user. @param AValue Character to use. -------------------------------------------------------------------------------} procedure TMiniAppEdit.SetPasswordChar(const AValue: MiniChar); begin if FPasswordChar=AValue then Exit; FPasswordChar := AValue; SendMessage(FHandle, EM_SETPASSWORDCHAR, Ord(AValue), 0); end; {*------------------------------------------------------------------------------ Updates the control style of an object. This procedure exists to save one or more additional calls to SetControlStyle. -------------------------------------------------------------------------------} procedure TMiniAppEdit.UpdateControlStyle; var dwStyle: DWord; begin dwStyle := GetWindowLong(FHandle, GWL_STYLE); // TODO : use existing style instead? if FReadOnly then dwStyle := dwStyle or ES_READONLY else if (dwStyle and ES_READONLY)>0 then Dec(dwStyle, ES_READONLY); if FPassword then dwStyle := dwStyle or ES_PASSWORD else if (dwStyle and ES_PASSWORD)>0 then Dec(dwStyle, ES_PASSWORD); SetControlStyle(dwStyle); end; {*------------------------------------------------------------------------------ Constructor for edit field controls. You need to use AReadOnly and AMultiLine here currently, since the properties do not really work well yet. @param AOwner Parent control object. @param AText Default text of edit control. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. If not specified, a default height of 21 will be assumed. @param AReadOnly Set to true if control should be read only. @param AMultiLine Set to true if control should allow multiple lines. -------------------------------------------------------------------------------} constructor TMiniAppEdit.Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth: integer; AHeight: integer; AReadOnly: boolean; AMultiLine: boolean); var dwStyle, dwExStyle: DWord; begin {$IFDEF WinCE} dwExStyle := 0; {$ELSE WinCE} dwExStyle := WS_EX_CLIENTEDGE; {$ENDIF WinCE} inherited Create(AOwner, AText, ALeft, ATop, AWidth, AHeight); FPassword := false; FReadOnly := AReadOnly; SetPasswordChar('*'); dwStyle := WS_VISIBLE or WS_CHILD or WS_BORDER or WS_TABSTOP; if AReadOnly then dwStyle := dwStyle or ES_READONLY; if AMultiLine then dwStyle := dwStyle or ES_MULTILINE or ES_WANTRETURN or ES_AUTOVSCROLL or WS_VSCROLL; {or ES_READONLY or ES_AUTOVSCROLL or ES_WANTRETURN or ES_MULTILINE} FHandle := CreateWindowEx(dwExStyle, 'Edit', PMiniChar(AText), dwStyle, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); SetBaseFont(FHandle); end; { TMiniAppGroupbox } {*------------------------------------------------------------------------------ Constructor for group box controls. @param AOwner Parent control object. @param AText Default text of group box control. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of control. @param AHeight Height of control. -------------------------------------------------------------------------------} constructor TMiniAppGroupbox.Create(AOwner: TMiniAppControl; AText: MiniString; ALeft, ATop, AWidth, AHeight: integer); begin inherited; FHandle := CreateWindow('Button', PMiniChar(AText), WS_VISIBLE or WS_CHILD or BS_GROUPBOX, // or SS_NOPREFIX FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); SetBaseFont(FHandle); if GOldGroupboxMessageProc=nil then GOldGroupboxMessageProc := TWndMessageProc(GetWindowLong(FHandle, GWLP_WNDPROC)); SetWindowLong(FHandle, GWLP_WNDPROC, LongInt(TWndMessageProc(@WndMessageProcGroupbox))); end; { TMiniAppProgressbar } {*------------------------------------------------------------------------------ Sets the maximum value of the progress bar. @param AValue The maximum value of the progress bar. -------------------------------------------------------------------------------} procedure TMiniAppProgressbar.SetMax(const AValue: DWord); begin if FMax=AValue then Exit; FMax := AValue; UpdateMinMax; end; {*------------------------------------------------------------------------------ Sets the minimum value of the progress bar. @param AValue The minimum value of the progress bar. -------------------------------------------------------------------------------} procedure TMiniAppProgressbar.SetMin(const AValue: DWord); begin if FMin=AValue then Exit; FMin := AValue; UpdateMinMax; end; {*------------------------------------------------------------------------------ Sets the position of the progress bar. @param AValue The current position in the progress bar. -------------------------------------------------------------------------------} procedure TMiniAppProgressbar.SetPosition(const AValue: DWord); begin if FPosition=AValue then Exit; FPosition := AValue; SendMessage(FHandle, PBM_SETPOS, FPosition, 0); end; {*------------------------------------------------------------------------------ Applies minimum and maximum values to the control. -------------------------------------------------------------------------------} procedure TMiniAppProgressbar.UpdateMinMax; begin // TODO: does not work yet! SendMessage(FHandle, PBM_SETRANGE32, FMin, FMax); // SendMessage(FHandle, PBM_SETRANGE, 0, (FMin + (FMax shl 16))); end; {*------------------------------------------------------------------------------ Constructor for progress bar controls. @param AOwner Parent control object. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of progress bar. @param AHeight Height of progress bar. -------------------------------------------------------------------------------} constructor TMiniAppProgressbar.Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); begin inherited Create(AOwner, '', ALeft, ATop, AWidth, AHeight); FMax := 0; FMin := 100; FHandle := CreateWindowEx(0, PROGRESS_CLASS, '', WS_VISIBLE or WS_CHILD or PBS_SMOOTH, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); end; { TMiniAppTreeview } {*------------------------------------------------------------------------------ Constructor for tree view controls. @param AOwner Parent control object. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of tree view. @param AHeight Height of tree view. -------------------------------------------------------------------------------} constructor TMiniAppTreeview.Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); var dwExStyle: DWord; begin {$IFDEF WinCE} dwExStyle := 0; {$ELSE WinCE} dwExStyle := WS_EX_CLIENTEDGE; {$ENDIF WinCE} inherited Create(AOwner, '', ALeft, ATop, AWidth, AHeight); FHandle := CreateWindowEx(dwExStyle, WC_TREEVIEW, '', WS_VISIBLE or WS_CHILD or WS_BORDER or WS_TABSTOP or TVS_HASLINES or TVS_LINESATROOT or TVS_HASBUTTONS, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); SetBaseFont(FHandle); end; {*------------------------------------------------------------------------------ Inserts an item in the first position of a level of a tree view. @param AParent Parent tree view item, nil of adding to root. @param AText Text to add to tree view. @return Handle to tree view item. -------------------------------------------------------------------------------} function TMiniAppTreeview.InsertItemFirst(AParent: TTreeItemHandle; AText: MiniString): TTreeItemHandle; begin Result := InsertItemAfter(AParent, LongWord(TVI_FIRST), AText); end; {*------------------------------------------------------------------------------ Inserts an item in the last position of a level of a tree view. @param AParent Parent tree view item, nil of adding to root. @param AText Text to add to tree view. @return Handle to tree view item. -------------------------------------------------------------------------------} function TMiniAppTreeview.InsertItemLast(AParent: TTreeItemHandle; AText: MiniString): TTreeItemHandle; begin Result := InsertItemAfter(AParent, LongWord(TVI_LAST), AText); end; {*------------------------------------------------------------------------------ Inserts an item into an alphabetically sorted position of a level of a tree view. @param AParent Parent tree view item, nil of adding to root. @param AText Text to add to tree view. @return Handle to tree view item. -------------------------------------------------------------------------------} function TMiniAppTreeview.InsertItemSorted(AParent: TTreeItemHandle; AText: MiniString): TTreeItemHandle; begin Result := InsertItemAfter(AParent, LongWord(TVI_SORT), AText); end; {*------------------------------------------------------------------------------ Inserts an item after another on the same level into a treeview control. @param AParent Parent tree view item, nil of adding to root. @param AAfter Tree view item after which to add this one. @param AText Text to add to tree view. @return Handle to tree view item. -------------------------------------------------------------------------------} function TMiniAppTreeview.InsertItemAfter(AParent, AAfter: TTreeItemHandle; AText: MiniString): TTreeItemHandle; var tItem: _TV_ITEM; tInsert: TV_INSERTSTRUCT; begin FillChar(tItem, SizeOf(tItem), 0); tItem.mask := TVIF_TEXT; tItem.pszText := PMiniChar(AText); tItem.cchTextMax := Length(AText)+1; tInsert.hParent := HTreeItem(AParent); tInsert.hInsertAfter := HTreeItem(AAfter); tInsert.item := tItem; Result := TreeView_InsertItem(FHandle, @tInsert); end; {*------------------------------------------------------------------------------ Changes the text displayed by a tree view item. @param AItem Handle to item that you want to change. @param AText New text for the item. @return Success status -------------------------------------------------------------------------------} function TMiniAppTreeview.SetItemText(AItem: TTreeItemHandle; AText: MiniString): boolean; var tItem: _TV_ITEM; begin tItem.mask := TVIF_TEXT; tItem.pszText := PMiniChar(AText); tItem.cchTextMax := Length(AText)+1; tItem.hItem := HTreeItem(AItem); Result := TreeView_SetItem(FHandle, tItem)=1; end; var icosex: TINITCOMMONCONTROLSEX; { TMiniAppListview } {*------------------------------------------------------------------------------ Handler for actions when a list view item gets activated. @param Info Control structure for list view events. -------------------------------------------------------------------------------} procedure TMiniAppListview.DoOnItemActivate(Info: PNMLISTVIEW); begin if Assigned(FOnItemActivate) then FOnItemActivate(Info^.iItem, Info^.iSubItem, Info^.uNewState, Info^.uOldState, Info^.uChanged); end; {*------------------------------------------------------------------------------ Constructor for list view controls. @param AOwner Parent control object. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of list view. @param AHeight Height of list view. -------------------------------------------------------------------------------} constructor TMiniAppListview.Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth, AHeight: integer); var dwExStyle: DWord; begin {$IFDEF WinCE} dwExStyle := 0; {$ELSE WinCE} dwExStyle := WS_EX_CLIENTEDGE; {$ENDIF WinCE} dwExStyle := dwExStyle or LVS_EX_FULLROWSELECT; inherited Create(AOwner, '', ALeft, ATop, AWidth, AHeight); FHandle := CreateWindowEx(dwExStyle, WC_LISTVIEW, '', WS_VISIBLE or WS_CHILD or WS_BORDER or WS_TABSTOP or LVS_AUTOARRANGE or LVS_REPORT or LVS_NOSORTHEADER or LVS_SHOWSELALWAYS or LVS_SINGLESEL, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); SetBaseFont(FHandle); SetLength(FColumns, 0); end; {*------------------------------------------------------------------------------ Adds an item to a list view. @param AText Text for item to add. @return List item object. -------------------------------------------------------------------------------} function TMiniAppListview.AddItem(AText: MiniString): TMiniAppListItem; begin Result := TMiniAppListItem.Create(Self, AText, ListView_GetItemCount(FHandle)); end; {*------------------------------------------------------------------------------ Inserts an item into a list view. @param AText Text for item to add. @return List item object. -------------------------------------------------------------------------------} function TMiniAppListview.InsertItem(AText: MiniString): TMiniAppListItem; begin Result := TMiniAppListItem.Create(Self, AText); end; {*------------------------------------------------------------------------------ Inserts a column for report style lisrt views. @param AText Text for the column. @param AIndex Index where to add column. @param AWidth Width of column. @param AAlign Alignment of column, including any list items in this column. -------------------------------------------------------------------------------} procedure TMiniAppListview.InsertColumn(AText: MiniString; AIndex, AWidth: integer; AAlign: TMiniTextAlign); var iColumn: integer; begin iColumn := Length(FColumns); SetLength(FColumns, Succ(iColumn)); FillChar(FColumns[iColumn], SizeOf(FColumns[iColumn]), 0); FColumns[iColumn].mask := LVCF_TEXT or LVCF_FMT; FColumns[iColumn].pszText := PMiniChar(AText); FColumns[iColumn].cchTextMax := Length(AText); case AAlign of taLeft: FColumns[iColumn].fmt := LVCFMT_LEFT; taCenter: FColumns[iColumn].fmt := LVCFMT_CENTER; taRight: FColumns[iColumn].fmt := LVCFMT_RIGHT; end; ListView_InsertColumn(Handle, AIndex, FColumns[iColumn]); ListView_SetColumnWidth(Handle, AIndex, AWidth); end; {*------------------------------------------------------------------------------ Removes all items from the list. -------------------------------------------------------------------------------} procedure TMiniAppListview.ClearItems; begin ListView_DeleteAllItems(Handle); end; { TMiniAppToolbar } {*------------------------------------------------------------------------------ Toggles whether the toolbar should be visible. This overrides the generic TMiniAppControl behaviour, since command bars have their own command for this. @param AValue Set to false if you want to hide the toolbar. -------------------------------------------------------------------------------} procedure TMiniAppToolbar.SetVisible(const AValue: boolean); begin if FVisible=AValue then Exit; FVisible := AValue; {$IFDEF WinCE} if FHandle>0 then CommandBar_Show(FHandle, FVisible) else FVisible := false; {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Checks the height of the toolbar. @return The height of the toolbar. -------------------------------------------------------------------------------} function TMiniAppToolbar.GetHeight: integer; begin Result := 0; {$IFDEF WinCE} if FHandle>0 then Result := CommandBar_Height(FHandle); {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Checks if the toolbar is visible. @return If visible, true is returned. -------------------------------------------------------------------------------} function TMiniAppToolbar.GetVisible: boolean; begin {$IFDEF WinCE} FVisible := CommandBar_IsVisible(FHandle); Result := FVisible; {$ELSE WinCE} Result := false; {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Constructor for a toolbar, Windows CE only currently. @param AOwnerWindow The window that should show this toolbar. -------------------------------------------------------------------------------} constructor TMiniAppToolbar.Create(AOwnerWindow: TMiniAppWindow); var mii: TMenuItemInfo; tmp: THandle; cbiButtons: array of TBBUTTON; begin inherited Create; FOwnerWindow := AOwnerWindow; FVisible := true; // So far, we can create the command bar, and insert a combobox // @Todo Add buttons // @Todo Add this later upon wish only {$IFDEF WinCE} FHandle := CommandBar_Create(hInstance, AOwnerWindow.Handle, 302); if FHandle=0 then AOwnerWindow.AppErrorBox('Could not create command bar!'); // The following functions could net yet be tested! //SetLength(cbiButtons,1); //cbiButtons[0] := cbiButton; // CommandBar_InsertMenubar(FCommandBarHandle, hInstance, 0, 0); // CommandBar_AddButtons(FCommandBarHandle, 1, cbiButtons); // CommandBar_AddButtons(FCommandBarHandle,1,tbCmdButtons); // CommandBar_AddBitmap(FCommandBarHandle, HINST_COMMCTRL, IDB_VIEW_SMALL_COLOR or STD_FIND, 0, 16, 16)<0*) // CommandBar_AddBitmap(FCommandBarHandle, hInstance, 133, 0, 16, 16)<0 {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Adds special buttons to the toolbar. @param AHelpButton Set to true if you want a help button on the right side of the toolbar. @param AOKButton Set to true if an additional OK button should appear here. -------------------------------------------------------------------------------} function TMiniAppToolbar.AddAdornments(AHelpButton, AOKButton: boolean): boolean; var dwFlags: DWord; begin dwFlags := 0; {$IFDEF WinCE} if AHelpButton then dwFlags := dwFlags or CMDBAR_HELP; if AOKButton then dwFlags := dwFlags or CMDBAR_OK; CommandBar_AddAdornments(FHandle, dwFlags, 0); {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Adds a button to the toolbar. @param AText Text the button should show. @param AImageIndex Index of the image to associate with the new button. @return A button object. -------------------------------------------------------------------------------} function TMiniAppToolbar.AddButton(AText: PMiniChar; AImageIndex: integer): TMiniAppToolButton; var cbiButton: TBBUTTON; begin {$IFDEF WinCE} FillChar(cbiButton, SizeOf(cbiButton), 0); cbiButton.iBitmap := AImageIndex; cbiButton.idCommand := GControlIDOffset; cbiButton.fsState := TBSTATE_ENABLED; cbiButton.fsStyle := TBSTYLE_AUTOSIZE; // TBSTYLE_BUTTON cbiButton.dwData := 0; cbiButton.iString := LongInt(AText); if CommandBar_InsertButton(FHandle, 1, cbiButton) then begin Result := TMiniAppToolButton.Create(FOwnerWindow, Self, GControlIDOffset); Inc(GControlIDOffset); Inc(GToolbarOffset); end else Result := nil; {$ELSE WinCE} Result := nil; {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Adds a combobox to the toolbar. @param AWidth Width of the combo box to add. @param APos Position where to add combo box. @return A combobox object. -------------------------------------------------------------------------------} function TMiniAppToolbar.AddComboBox(AWidth: DWord; APos: DWord): TMiniAppComboBox; var h: Thandle; begin {$IFDEF WinCE} h := CommandBar_InsertComboBox(FHandle, hInstance, AWidth, WS_VISIBLE or WS_CHILD or WS_TABSTOP or CBS_AUTOHSCROLL or CBS_DROPDOWNLIST, GToolbarOffset, APos); // Inc(GControlIDOffset); // The ID is probably only a resource ID? if h>0 then begin Inc(GToolbarOffset); Result := TMiniAppComboBox.Create(h) end else Result := nil; {$ELSE WinCE} Result := nil; {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Adds a command bar on Windows CE devices. Nothing done on Win32 yet. @return Whether the main menu was created. -------------------------------------------------------------------------------} function TMiniAppToolbar.AddMainMenu: boolean; begin {$IFDEF WinCE} Result := CommandBar_InsertMenubarEx(FHandle, 0, PWideChar(FOwnerWindow.MenuBarHandle), GToolbarOffset); {$ELSE WinCE} Result := false; {$ENDIF WinCE} if Result then Inc(GToolbarOffset); end; {*------------------------------------------------------------------------------ Adds a popup menu to a command bar on Windows CE devices. Nothing done on Win32 yet. @param AMenu The menu to add. @return Whether the main menu was created. -------------------------------------------------------------------------------} function TMiniAppToolbar.AddPopupMenu(AMenu: TMiniAppMenuPopup): boolean; begin if not Assigned(AMenu) then begin Result := false; Exit; end; {$IFDEF WinCE} Result := CommandBar_InsertMenubarEx(FHandle, 0, PWideChar(AMenu.Handle), GToolbarOffset); {$ELSE WinCE} Result := false; {$ENDIF WinCE} if Result then Inc(GToolbarOffset); end; {*------------------------------------------------------------------------------ Adds standard bitmaps to be used for buttons on a command bar. @param ViewBitmaps If set, the view style bitmaps will be added, otherwise standard bitmaps will be added. @return The number of buttons that were added. -------------------------------------------------------------------------------} function TMiniAppToolbar.AddSystemBitmaps(ViewBitmaps: boolean): integer; begin {$IFDEF WinCE} if ViewBitmaps then Result := CommandBar_AddBitmap(FHandle, HINST_COMMCTRL, IDB_VIEW_SMALL_COLOR, 0, 16, 16) else Result := CommandBar_AddBitmap(FHandle, HINST_COMMCTRL, IDB_STD_SMALL_COLOR, 0, 16, 16); {$ELSE WinCE} Result := 0; {$ENDIF WinCE} end; {*------------------------------------------------------------------------------ Destructor of toolbar. -------------------------------------------------------------------------------} destructor TMiniAppToolbar.Destroy; begin {$IFDEF WinCE} if FHandle>0 then CommandBar_Destroy(FHandle); {$ENDIF WinCE} inherited; end; {*------------------------------------------------------------------------------ Redraws a button on a command bar on Windows CE devices. @param AButtonIndex Index of button to draw. @return Sucess status. -------------------------------------------------------------------------------} function TMiniAppToolbar.MyDrawMenuBar(AButtonIndex: Word): boolean; begin Result := false; {$IFDEF WinCE} if FHandle>0 then Result := CommandBar_DrawMenuBar(FHandle, AButtonIndex); {$ENDIF WinCE} end; { TMiniAppComboBox } {*------------------------------------------------------------------------------ Constructor for combo box controls. @param AOwner Parent control object. @param ALeft Left coordinate. @param ATop Top coordinate. @param AWidth Width of combo box. @param AHeight Height of combo box. -------------------------------------------------------------------------------} constructor TMiniAppComboBox.Create(AOwner: TMiniAppControl; ALeft, ATop, AWidth: integer; AHeight: integer); begin inherited Create(AOwner, '', ALeft, Atop, AWidth, AHeight); FMaxLength := 0; FHandle := CreateWindow('ComboBox', '', WS_VISIBLE or WS_CHILD or WS_TABSTOP or CBS_AUTOHSCROLL or CBS_DROPDOWNLIST, FLeft, FTop, FWidth, FHeight, AOwner.Handle, 0, hInstance, nil); SetBaseFont(FHandle); end; {*------------------------------------------------------------------------------ Experimental alternative constructor for creating a control for controls already existing, by using their handle. This is used in combination with combo boxes on command bars that need to be created using a special function. @param AExistingHandle Handle of existing combo box. -------------------------------------------------------------------------------} constructor TMiniAppComboBox.Create(AExistingHandle: THandle); begin FMaxLength := 0; FHandle := AExistingHandle; // TODO : get dimensions SetBaseFont(FHandle); end; {*------------------------------------------------------------------------------ Counts the number of items of a combo box. @return The number of items of a combo box. -------------------------------------------------------------------------------} function TMiniAppComboBox.GetCount: integer; begin Result := SendMessage(FHandle, CB_GETCOUNT, 0, 0); end; {*------------------------------------------------------------------------------ Retrieves the index of the currently selected combo box entry. @return The index of the currently selected combo box entry. -------------------------------------------------------------------------------} function TMiniAppComboBox.GetSelectedIndex: integer; begin Result := SendMessage(FHandle, CB_GETCURSEL, 0, 0); end; {*------------------------------------------------------------------------------ Sets the maximum length for combo box entries. @value AValue The maximum length for combo box entries. -------------------------------------------------------------------------------} procedure TMiniAppComboBox.SetMaxLength(const AValue: integer); begin if FMaxLength=AValue then Exit; FMaxLength := AValue; SendMessage(FHandle, CB_LIMITTEXT, AValue, 0); end; {*------------------------------------------------------------------------------ Selects a combo box entry. @value AValue The index of the item to select. -------------------------------------------------------------------------------} procedure TMiniAppComboBox.SetSelectedIndex(const AValue: integer); begin SendMessage(FHandle, CB_SETCURSEL, AValue, 0); end; {*------------------------------------------------------------------------------ Adds an item to a combo box. @param AText Text to add. @return Index of new item. @see InsertString @see DeleteString @see FindString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppComboBox.AddString(AText: MiniString): integer; begin Result := SendMessage(FHandle, CB_ADDSTRING, 0, Integer(PMiniChar(AText))); end; {*------------------------------------------------------------------------------ Removes an item from a combo box. @param AIndex Index of item to remove. @return The number of items left probably. @see AddString @see InsertString @see FindString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppComboBox.DeleteString(AIndex: integer): integer; begin Result := SendMessage(FHandle, CB_DELETESTRING, AIndex, 0); end; {*------------------------------------------------------------------------------ Inserts an item into a combo box at a given position. @param AText Text to add. @return Index of new item. @see AddString @see FindString @see DeleteString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppComboBox.InsertString(AText: MiniString): integer; begin Result := SendMessage(FHandle, CB_INSERTSTRING, 0, Integer(PMiniChar(AText))); end; {*------------------------------------------------------------------------------ Looks for a string inside a combo box. @param AText Text to search for. @param AStartIndex Index where to start the search. @return Index of found item, or LB_ERR if nothing was found. @see AddString @see InsertString @see DeleteString @see ClearStrings -------------------------------------------------------------------------------} function TMiniAppComboBox.FindString(AText: MiniString; AStartIndex: integer ): integer; begin Result := SendMessage(FHandle, CB_FINDSTRING, AStartIndex, LongInt(PMiniChar(Atext))); end; {*------------------------------------------------------------------------------ Removes all strings from a combo box. @see AddString @see InsertString @see DeleteString @see FindString @see GetString @see ClearStrings -------------------------------------------------------------------------------} procedure TMiniAppComboBox.ClearStrings; begin SendMessage(FHandle, CB_RESETCONTENT, 0, 0); end; { TMiniAppMenuPopup } {*------------------------------------------------------------------------------ Adds an item to a popup menu. @param AText Text to display on menu item @return A menu item object. @see AddSeparator @see AddPopup -------------------------------------------------------------------------------} function TMiniAppMenuPopup.AddItem(AText: PMiniChar): TMiniAppMenuItem; begin Result := TMiniAppMenuItem.Create; AppendMenu(FHandle, MF_STRING, GControlIDOffset, AText); Result.ID := GControlIDOffset; Inc(GControlIDOffset); end; {*------------------------------------------------------------------------------ Adds a separator to a popup menu. @return A menu item object. @see AddItem @see AddPopup -------------------------------------------------------------------------------} function TMiniAppMenuPopup.AddSeparator: TMiniAppMenuItem; begin Result := TMiniAppMenuItem.Create; AppendMenu(FHandle, MF_SEPARATOR, GControlIDOffset, nil); Result.ID := GControlIDOffset; Inc(GControlIDOffset); end; {*------------------------------------------------------------------------------ Adds an popup menu to a popup menu. @param AText Text to display on submenu @return A popup menu object. @see AddItem @see AddSeparator -------------------------------------------------------------------------------} function TMiniAppMenuPopup.AddPopup(AText: PMiniChar): TMiniAppMenuPopup; begin Result := TMiniAppMenuPopup.Create; Result.Handle := CreateMenu; AppendMenu(FHandle, MF_POPUP or MF_STRING, Result.Handle, AText); end; { TMiniAppMainmenu } {*------------------------------------------------------------------------------ Constructor of a main menu @param AOwnerWindow Form that owns this menu. -------------------------------------------------------------------------------} constructor TMiniAppMainMenu.Create(AOwnerWindow: TMiniAppWindow); begin FHandle := AOwnerWindow.FMenuBarHandle; // FHandle := GetSystemMenu(AOwnerWindow.Handle, false); if FHandle=0 then begin AOwnerWindow.AppErrorBox('Could not create main menu!'); end else begin {$IFDEF Win32} SetMenu(AOwnerWindow.Handle, FHandle); {$ENDIF Win32} end; end; { TMiniAppToolButton } {*------------------------------------------------------------------------------ Sets the click event handler for a tool button. @param AValue Handler for clicks. -------------------------------------------------------------------------------} procedure TMiniAppToolButton.SetOnClick(const AValue: TOnMiniClick); begin // TODO : why is this an access violation ??? if FOnClick=AValue then Exit; // TODO: change event loop here! if Assigned(FOwnerWindow) then begin if Assigned(FOnClick) then begin // TODO: remove old handler end; if FID>0 then FOwnerWindow.AddMiniResourceHandler(FID, AValue); end; FOnClick := AValue; end; {*------------------------------------------------------------------------------ Constructor for tool buttons. @param AOwnerWindow Form that owns this toolbar. @param AOwnerToolbar Toolbar where button should be added. @param AID ID of tool button to add. -------------------------------------------------------------------------------} constructor TMiniAppToolButton.Create(AOwnerWindow: TMiniAppWindow; AOwnerToolbar: TMiniAppToolbar; AID: DWord); begin inherited Create; FOnClick := nil; FOwnerWindow := AOwnerWindow; FOwnerToolbar := AOwnerToolbar; FID := AID; end; { TMiniAppListItem } {*------------------------------------------------------------------------------ Constructor for list view items. @param AOwner List view that should contain this list item. @param AText Text for item to add. @param AIndex Index where to add item. -------------------------------------------------------------------------------} constructor TMiniAppListItem.Create(AOwner: TMiniAppListview; AText: MiniString; AIndex: integer); begin FSubItemCount := 1; FListView := AOwner; FillChar(FItem, SizeOf(FItem), 0); FItem.iItem := AIndex; FItem.mask := LVIF_TEXT; FItem.pszText := PMiniChar(AText); FItem.cchTextMax := Length(AText); FItemIndex := ListView_InsertItem(FListView.Handle, FItem); end; {*------------------------------------------------------------------------------ Adds a sub item to an existing list item, visible only in report mode. @param AText Text for subitem to add. -------------------------------------------------------------------------------} procedure TMiniAppListItem.AddSubItem(AText: MiniString); var subItem: LV_ITEM; begin FillChar(FItem, SizeOf(FItem), 0); subItem.mask := LVIF_TEXT; subItem.pszText := PMiniChar(AText); subItem.cchTextMax := Length(AText); subItem.iItem := FItemIndex; subItem.iSubItem := FSubItemCount; ListView_SetItem(FListView.Handle, subItem); Inc(FSubItemCount); end; begin icosex.dwSize := SizeOf(icosex); icosex.dwICC := ICC_PROGRESS_CLASS or ICC_LISTVIEW_CLASSES or ICC_TREEVIEW_CLASSES; InitCommonControlsEx(icosex); SetLength(MessageProcHandles, 0); SetLength(MessageProcWindows, 0); SetLength(GAllControls, 0); SetLength(GFontHandles, 0); GControlIDOffset := 500; GToolbarOffset := 0; MiniApp := TMiniAppWindow.Create; end.