[Code] (* MessageWithURL * * Copyright (c) 2010-2011 Jernej Simončič * * This software is provided 'as-is', without any express or implied * warranty. In no event will the authors be held liable for any damages * arising from the use of this software. * * Permission is granted to anyone to use this software for any purpose, * including commercial applications, and to alter it and redistribute it * freely, subject to the following restrictions: * * 1. The origin of this software must not be misrepresented; you must * not claim that you wrote the original software. If you use this * software in a product, an acknowledgment in the product * documentation would be appreciated but is not required. * * 2. Altered source versions must be plainly marked as such, and must * not be misrepresented as being the original software. * * 3. This notice may not be removed or altered from any source * distribution. *) (* * * * * * * * * * * MessageWithURL(Message: TArrayOfString; Title: String: ButtonText: TArrayOfString; Typ: TMsgBoxType; * DefaultButton, CancelButton: Integer): Integer; * * Parameters: * Title dialog box caption * Message messages to display; if a message starts with _, the text following it up to the first space character * is interpreted as URL, and the rest of the message is used as clickable text for that URL * Typ icon to show * ButtonText buttons to show under the text * DefaultButton default button (first button = 1) * CancelButton cancel button (first button = 1) * * Return value button that was clicked (first button = 1); if running in silent mode, DefaultButton is returned *) function MessageWithURL(Message: TArrayOfString; const Title: String; ButtonText: TArrayOfString; const Typ: TMsgBoxType; const DefaultButton, CancelButton: Integer): Integer; forward; function GetSystemMetrics(nIndex: Integer): Integer; external 'GetSystemMetrics@User32 stdcall'; function GetDialogBaseUnits(): Integer; external 'GetDialogBaseUnits@User32 stdcall'; //function GetSysColor(nIndex: Integer): DWORD; external 'GetSysColor@user32.dll stdcall'; function LoadIcon(hInstance: Integer; lpIconName: Integer): Integer; external 'LoadIconW@user32 stdcall'; //function LoadImage(hinst: Integer; lpszName: Integer; uType: Cardinal; cxDesired, cyDesired: Integer; fuLoad: Cardinal): Integer; external 'LoadImageW@user32 stdcall'; function DrawIcon(hdc: HBitmap; x,y: Integer; hIcon: Integer): Integer; external 'DrawIcon@user32 stdcall'; //function DrawIconEx(hdc: HBitmap; xLeft,yTop: Integer; hIcon: Integer; cxWidth, cyWidth: Integer; istepIfAniCur: Cardinal; hbrFlickerFreeDraw: Integer; diFlags: Cardinal): Integer; external 'DrawIconEx@user32 stdcall'; //function DestroyIcon(hIcon: Integer): Integer; external 'DestroyIcon@user32 stdcall'; function DrawFocusRect(hDC: Integer; var lprc: TRect): BOOL; external 'DrawFocusRect@user32 stdcall'; type TArrayOfButton = Array of TNewButton; const //borders around message MWU_LEFTBORDER = 25; MWU_RIGHTBORDER = MWU_LEFTBORDER; MWU_TOPBORDER = 26; MWU_BOTTOMBORDER = MWU_TOPBORDER; //space between elements (icon-text and between buttons) MWU_HORZSPACING = 8; //space between labels MWU_VERTSPACING = 4; //button sizes MWU_BUTTONHEIGHT = 24; MWU_MINBUTTONWIDTH = 86; //height of area where buttons are placed MWU_BUTTONAREAHEIGHT = 45; SM_CXSCREEN = 0; SM_CXICON = 11; SM_CYICON = 12; SM_CXICONSPACING = 38; SM_CYICONSPACING = 39; //COLOR_HOTLIGHT = 26; OIC_HAND = 32513; OIC_QUES = 32514; OIC_BANG = 32515; OIC_NOTE = 32516; LR_DEFAULTSIZE = $00000040; LR_SHARED = $00008000; IMAGE_BITMAP = 0; IMAGE_ICON = 1; IMAGE_CURSOR = 2; DI_IMAGE = 1; DI_MASK = 2; DI_NORMAL = DI_IMAGE or DI_MASK; DI_DEFAULTSIZE = 8; var URLList: TArrayOfString; TextLabel: Array of TNewStaticText; URLFocusImg: Array of TBitmapImage; SingleLineHeight: Integer; procedure UrlClick(Sender: TObject); var ErrorCode: Integer; begin ShellExecAsOriginalUser('open',URLList[TNewStaticText(Sender).Tag],'','',SW_SHOWNORMAL,ewNoWait,ErrorCode); end; // calculates maximum width of text labels // also counts URLs, and sets the length of URLList accordingly function Message_CalcLabelWidth(var Message: TArrayOfString; MessageForm: TSetupForm): Integer; var MeasureLabel: TNewStaticText; i,URLCount,DlgUnit,ScreenWidth: Integer; begin MeasureLabel := TNewStaticText.Create(MessageForm); with MeasureLabel do begin Parent := MessageForm; Left := 0; Top := 0; AutoSize := True; end; MeasureLabel.Caption := 'X'; SingleLineHeight := MeasureLabel.Height; Result := 0; //minimum width URLCount := 0; for i := 0 to GetArrayLength(Message) - 1 do begin if Length(Message[i]) < 1 then //simplifies things Message[i] := ' '; if Message[i][1] <> '_' then MeasureLabel.Caption := Message[i] //not an URL else begin //URL - check only the displayed text if Pos(' ',Message[i]) > 0 then MeasureLabel.Caption := Copy(Message[i],Pos(' ',Message[i])+1,Length(Message[i])) else MeasureLabel.Caption := Copy(Message[i],2,Length(Message[i])); URLCount := URLCount + 1; end; if MeasureLabel.Width > Result then Result := MeasureLabel.Width; end; MeasureLabel.Free; SetArrayLength(URLList,URLCount); //needed later - no need to do a special loop just for this SetArrayLength(URLFocusImg,URLCount); DlgUnit := GetDialogBaseUnits() and $FFFF; //ensure the dialog isn't too wide ScreenWidth := GetSystemMetrics(SM_CXSCREEN); if Result > ((278 * DlgUnit) div 4) then //278 is from http://blogs.msdn.com/b/oldnewthing/archive/2011/06/24/10178386.aspx Result := ((278 * DlgUnit) div 4); if Result > (ScreenWidth * 3) div 4 then Result := (ScreenWidth * 3) div 4; end; //find the longest button function Message_CalcButtonWidth(const ButtonText: TArrayOfString; MessageForm: TSetupForm): Integer; var MeasureLabel: TNewStaticText; i: Integer; begin MeasureLabel := TNewStaticText.Create(MessageForm); with MeasureLabel do begin Parent := MessageForm; Left := 0; Top := 0; AutoSize := True; end; Result := ScaleX(MWU_MINBUTTONWIDTH - MWU_HORZSPACING * 2); //minimum width for i := 0 to GetArrayLength(ButtonText) - 1 do begin MeasureLabel.Caption := ButtonText[i] if MeasureLabel.Width > Result then Result := MeasureLabel.Width; end; MeasureLabel.Free; Result := Result + ScaleX(MWU_HORZSPACING * 2); //account for borders end; procedure Message_Icon(const Typ: TMsgBoxType; TypImg: TBitmapImage); var TypRect: TRect; Icon: THandle; TypIcon: Integer; begin TypRect.Left := 0; TypRect.Top := 0; TypRect.Right := GetSystemMetrics(SM_CXICON); TypRect.Bottom := GetSystemMetrics(SM_CYICON); case Typ of mbInformation: TypIcon := OIC_NOTE; mbConfirmation: TypIcon := OIC_QUES; mbError: TypIcon := OIC_BANG; else TypIcon := OIC_HAND; end; //TODO: icon loads with wrong size when using Large Fonts (SM_CXICON/CYICON is 40, but 32x32 icon loads - find out how to get the right size) Icon := LoadIcon(0,TypIcon); //Icon := LoadImage(0,TypIcon,IMAGE_ICON,0,0,LR_SHARED or LR_DEFAULTSIZE); with TypImg do begin Left := ScaleX(MWU_LEFTBORDER); Top := ScaleY(MWU_TOPBORDER); Center := False; Stretch := False; AutoSize := True; Bitmap.Width := GetSystemMetrics(SM_CXICON); Bitmap.Height := GetSystemMetrics(SM_CYICON); Bitmap.Canvas.Brush.Color := TPanel(Parent).Color; Bitmap.Canvas.FillRect(TypRect); DrawIcon(Bitmap.Canvas.Handle,0,0,Icon); //draws icon scaled //DrawIconEx(Bitmap.Canvas.Handle,0,0,Icon,0,0,0,0,DI_NORMAL {or DI_DEFAULTSIZE}); //draws icon without scaling end; //DestroyIcon(Icon); //not needed with LR_SHARED or with LoadIcon end; procedure Message_SetUpURLLabel(URLLabel: TNewStaticText; const Msg: String; const URLNum: Integer); var Blank: TRect; begin with URLLabel do begin if Pos(' ',Msg) > 0 then begin Caption := Copy(Msg,Pos(' ',Msg)+1,Length(Msg)); URLList[URLNum] := Copy(Msg, 2, Pos(' ',Msg)-1); end else begin //no text after URL - display just URL URLList[URLNum] := Copy(Msg, 2, Length(Msg)); Caption := URLList[URLNum]; end; Hint := URLList[URLNum]; ShowHint := True; Font.Color := GetSysColor(COLOR_HOTLIGHT); Font.Style := [fsUnderline]; Cursor := crHand; OnClick := @UrlClick; Tag := URLNum; //used to find the URL to open and bitmap to draw focus rectangle on if Height = SingleLineHeight then //shrink label to actual text width WordWrap := False; TabStop := True; //keyboard accessibility TabOrder := URLNum; end; URLFocusImg[URLNum] := TBitmapImage.Create(URLLabel.Parent); //focus rectangle needs a bitmap - prepare it here with URLFocusImg[URLNum] do begin Left := URLLabel.Left - 1; Top := URLLabel.Top - 1; Stretch := False; AutoSize := True; Parent := URLLabel.Parent; Bitmap.Width := URLLabel.Width + 2; Bitmap.Height := URLLabel.Height + 2; SendToBack; Blank.Left := 0; Blank.Top := 0; Blank.Right := Width; Blank.Bottom := Height; Bitmap.Canvas.Brush.Color := TPanel(Parent).Color; Bitmap.Canvas.FillRect(Blank); end; end; procedure Message_SetUpLabels(Message: TArrayOfString; TypImg: TBitmapImage; const DialogTextWidth: Integer; MessagePanel: TPanel); var i,URLNum,dy: Integer; begin SetArrayLength(TextLabel,GetArrayLength(Message)); URLNum := 0; for i := 0 to GetArrayLength(TextLabel) - 1 do begin TextLabel[i] := TNewStaticText.Create(MessagePanel); with TextLabel[i] do begin Parent := MessagePanel; Left := TypImg.Left + TypImg.Width + ScaleX(MWU_HORZSPACING); if i = 0 then Top := TypImg.Top else Top := TextLabel[i-1].Top + TextLabel[i-1].Height + ScaleY(MWU_VERTSPACING); WordWrap := True; AutoSize := True; Width := DialogTextWidth; if Message[i][1] <> '_' then Caption := Message[i] else begin // apply URL formatting Message_SetUpURLLabel(TextLabel[i], Message[i], URLNum); URLNum := URLNum + 1; end; end; end; i := GetArrayLength(TextLabel) - 1; if TextLabel[i].Top + TextLabel[i].Height < TypImg.Top + TypImg.Height then //center labels vertically begin dy := (TypImg.Top + TypImg.Height - TextLabel[i].Top - TextLabel[i].Height) div 2; for i := 0 to GetArrayLength(TextLabel) - 1 do TextLabel[i].Top := TextLabel[i].Top + dy; end; end; procedure Message_SetUpButtons(var Button: TArrayOfButton; ButtonText: TArrayOfString; const ButtonWidth, DefaultButton, CancelButton: Integer; MessageForm: TSetupForm); var i: Integer; begin SetArrayLength(Button,GetArrayLength(ButtonText)); for i := 0 to GetArrayLength(Button) - 1 do begin Button[i] := TNewButton.Create(MessageForm); with Button[i] do begin Parent := MessageForm; Width := ButtonWidth; Height := ScaleY(MWU_BUTTONHEIGHT); if i = 0 then begin Left := MessageForm.ClientWidth - (ScaleX(MWU_HORZSPACING) + ButtonWidth) * GetArrayLength(ButtonText); Top := MessageForm.ClientHeight - ScaleY(MWU_BUTTONAREAHEIGHT) + ScaleY(MWU_BUTTONAREAHEIGHT - MWU_BUTTONHEIGHT) div 2; end else begin Left := Button[i-1].Left + ScaleX(MWU_HORZSPACING) + ButtonWidth; Top := Button[i-1].Top; end; Caption := ButtonText[i]; ModalResult := i + 1; //set the initial focus to the default button TabOrder := ((i - (DefaultButton - 1)) + GetArrayLength(Button)) mod (GetArrayLength(Button)); if DefaultButton = i + 1 then Default := True; if CancelButton = i + 1 then Cancel := True; end; end; end; //find out if URL label has focus //draw focus rectangle around it if so and return index of focused label function Message_FocusLabel(): Integer; var i: Integer; FocusRect: TRect; begin Result := -1; for i := 0 to GetArrayLength(URLFocusImg) - 1 do //clear existing focus rectangle begin FocusRect.Left := 0; FocusRect.Top := 0; FocusRect.Right := URLFocusImg[i].Bitmap.Width; FocusRect.Bottom := URLFocusImg[i].Bitmap.Height; URLFocusImg[i].Bitmap.Canvas.FillRect(FocusRect); end; for i := 0 to GetArrayLength(TextLabel) - 1 do begin if TextLabel[i].Focused then begin Result := i; FocusRect.Left := 0; FocusRect.Top := 0; FocusRect.Right := URLFocusImg[TextLabel[i].Tag].Bitmap.Width; FocusRect.Bottom := URLFocusImg[TextLabel[i].Tag].Bitmap.Height; DrawFocusRect(URLFocusImg[TextLabel[i].Tag].Bitmap.Canvas.Handle, FocusRect); end; end; end; //TNewStaticText doesn't have OnFocus - handle that here //(not perfect - if you focus label with keyboard, then focus a button with mouse, the label keeps it's underline) procedure Message_KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); var URLIdx: Integer; begin case Key of 9,37..40: //tab, arrow keys begin Message_FocusLabel(); end; 13,32: //enter, spacebar begin URLIdx := Message_FocusLabel(); //get focused label if URLIdx > -1 then UrlClick(TextLabel[URLIdx]); end; end; end; function MessageWithURL(Message: TArrayOfString; const Title: String; ButtonText: TArrayOfString; const Typ: TMsgBoxType; const DefaultButton, CancelButton: Integer): Integer; var MessageForm: TSetupForm; Button: TArrayOfButton; DialogTextWidth, ButtonWidth: Integer; MessagePanel: TPanel; TypImg: TBitmapImage; i: Integer; begin if (not IsUninstaller and WizardSilent) or (IsUninstaller and UninstallSilent) then begin Result := DefaultButton; exit; end; MessageForm := CreateCustomForm(); MessageForm.Caption := Title; if (CancelButton = 0) or (CancelButton > GetArrayLength(ButtonText)) then //no cancel button - remove close button MessageForm.BorderIcons := MessageForm.BorderIcons - [biSystemMenu]; MessagePanel := TPanel.Create(MessageForm); //Vista-style background with MessagePanel do begin Parent := MessageForm; BevelInner := bvNone; BevelOuter := bvNone; BevelWidth := 0; ParentBackground := False; Color := clWindow; Left := 0; Top := 0; end; DialogTextWidth := Message_CalcLabelWidth(Message, MessageForm); ButtonWidth := Message_CalcButtonWidth(ButtonText, MessageForm); TypImg := TBitmapImage.Create(MessagePanel); TypImg.Parent := MessagePanel; Message_Icon(Typ, TypImg); Message_SetUpLabels(Message, TypImg, DialogTextWidth, MessagePanel); i := GetArrayLength(TextLabel) - 1; MessagePanel.ClientHeight := TextLabel[i].Top + TextLabel[i].Height + ScaleY(MWU_BOTTOMBORDER); MessagePanel.ClientWidth := DialogTextWidth + TypImg.Width + TypImg.Left + ScaleX(MWU_HORZSPACING + MWU_RIGHTBORDER); if MessagePanel.ClientWidth < (ButtonWidth + ScaleX(MWU_HORZSPACING)) * GetArrayLength(ButtonText) + ScaleX(MWU_HORZSPACING) then //ensure buttons fit MessagePanel.ClientWidth := (ButtonWidth + ScaleX(MWU_HORZSPACING)) * GetArrayLength(ButtonText) + ScaleX(MWU_HORZSPACING); MessageForm.ClientWidth := MessagePanel.Width; MessageForm.ClientHeight := MessagePanel.Height + ScaleY(MWU_BUTTONAREAHEIGHT); Message_SetUpButtons(Button, ButtonText, ButtonWidth, DefaultButton, CancelButton, MessageForm); MessageForm.OnKeyUp := @Message_KeyUp; //needed for keyboard access of URL labels MessageForm.KeyPreView := True; Result := MessageForm.ShowModal; for i := 0 to GetArrayLength(TextLabel) - 1 do TextLabel[i].Free; SetArrayLength(TextLabel,0); for i := 0 to GetArrayLength(URLFocusImg) - 1 do URLFocusImg[i].Free; SetArrayLength(URLFocusImg,0); MessageForm.Release; end;