Eine aufbereitete Darstellung der Quelle

 
     
 
 
Anforderungen  |   Konzepte  |   Entwurf  |   Entwicklung  |   Qualitätssicherung  |   Lebenszyklus  |   Steuerung
 
 
 
 

Benutzer

Quelle  util_MessageWithURL.isi  Sprache: unbekannt

 
Spracherkennung für: .isi vermutete Sprache: Delphi {Delphi[110] SPS[77] Fortran[64]} [Methode: maximale Elemente, drei Dimensionen]

[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 ExtractIcon(hInstance: Integer; lpszExeFileName: String; nIconIndex: Integer): Integer; external 'ExtractIconW@shell32.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;

 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);

 //Icon index from imageres.dll
 case Typ of
 mbInformation:
  TypIcon := 76;
 mbConfirmation:
  TypIcon := 94;
 mbError:
  TypIcon := 79;
 else
  TypIcon := 93;
 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 := ExtractIcon(0,'imageres.dll',TypIcon)
 //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 := GetThemedBgColor;
  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 := GetThemedBgColor;
  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(ScaleX(256), ScaleY(128), False, True);

 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;

[Dauer der Verarbeitung: 0.5 Sekunden, vorverarbeitet 2026-10-27]

                                                                                                                                                                                                                                                                                                                                                                                                     


Neuigkeiten

     Aktuelles
     Motto des Tages

Open Source Software

     Quellcodebibliothek
     Eigene Quellcodes
     Fremde Quellcodes
     Suchen

Jenseits des Üblichen ....
    

Besucherstatistik

Besucherstatistik

Statistik
#Sources=1104845
#Domains=499261