cmnfunc.pas

源代码

unit CmnFunc;

{
  Inno Setup
  Copyright (C) 1997-2004 Jordan Russell
  Portions by Martijn Laan
  For conditions of distribution and use, see LICENSE.TXT.

  Common VCL functions

  $jrsoftware: issrc/Projects/CmnFunc.pas,v 1.13 2004/06/05 16:07:58 mlaan Exp $
}

{$B-}

interface

{$I VERSION.INC}

uses
  Windows, Messages, SysUtils, Forms, Graphics, Controls, StdCtrls, Classes;

{ Note: This type is also present in ScriptFunc_C.pas }
type
  TMsgBoxType = (mbInformation, mbConfirmation, mbError, mbCriticalError);

{ Useful constant }
const
  EnableColor: array[Boolean] of TColor = (clBtnFace, clWindow);

procedure UpdateHorizontalExtent(const ListBox: TCustomListBox);
function MinimizePathName(const Filename: String; const Font: TFont;
  MaxLen: Integer): String;
function AppMessageBox(const Text, Caption: PChar; Flags: Longint): Integer;
function MsgBoxP(const Text, Caption: PChar; const Typ: TMsgBoxType;
  const Buttons: Cardinal): Integer;
function MsgBox(const Text, Caption: String; const Typ: TMsgBoxType;
  const Buttons: Cardinal): Integer;
function MsgBoxFmt(const Text: String; const Args: array of const;
  const Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal): Integer;
procedure SetMessageBoxCaption(const Typ: TMsgBoxType; const NewCaption: PChar);

implementation

uses
  Consts, PathFunc, CmnFunc2;

var
  MessageBoxCaptions: array[TMsgBoxType] of PChar;

type
  TListBoxAccess = class(TCustomListBox);

procedure UpdateHorizontalExtent(const ListBox: TCustomListBox);
var
  I: Integer;
  Extent, MaxExtent: Longint;
  DC: HDC;
  Size: TSize;
  TextMetrics: TTextMetric;
begin
  DC := GetDC(0);
  try
    SelectObject(DC, TListBoxAccess(ListBox).Font.Handle);

    //Q66370 says tmAveCharWidth should be added to extent
    GetTextMetrics(DC, TextMetrics);

    MaxExtent := 0;
    for I := 0 to ListBox.Items.Count-1 do begin
      GetTextExtentPoint32(DC, PChar(ListBox.Items[I]), Length(ListBox.Items[I]), Size);
      Extent := Size.cx + TextMetrics.tmAveCharWidth;
      if Extent > MaxExtent then
        MaxExtent := Extent;
    end;

  finally
    ReleaseDC(0, DC);
  end;

  if MaxExtent > SendMessage(ListBox.Handle, LB_GETHORIZONTALEXTENT, 0, 0) then
    SendMessage(ListBox.Handle, LB_SETHORIZONTALEXTENT, MaxExtent, 0);
end;

function MinimizePathName(const Filename: String; const Font: TFont;
  MaxLen: Integer): String;

  procedure CutFirstDirectory(var S: String);
  var
    Root: Boolean;
    P: Integer;
  begin
    if S = '\' then
      S := ''
    else
    begin
      if S[1] = '\' then
      begin
        Root := True;
        Delete(S, 1, 1);
      end
      else
        Root := False;
      if S[1] = '.' then
        Delete(S, 1, 4);
      P := PathPos('\', S);
      if P <> 0 then
      begin
        Delete(S, 1, P);
        S := '...\' + S;
      end
      else
        S := '';
      if Root then
        S := '\' + S;
    end;
  end;

var
  DC: HDC;
  Drive, Dir, Name: String;
begin
  DC := GetDC(0);
  try
    SelectObject(DC, Font.Handle);

    Result := FileName;
    Dir := PathExtractPath(Result);
    Name := PathExtractName(Result);

    if (Length(Dir) >= 2) and (Dir[2] = ':') then
    begin
      Drive := Copy(Dir, 1, 2);
      Delete(Dir, 1, 2);
    end
    else
      Drive := '';
    while ((Dir <> '') or (Drive <> '')) and (GetTextWidth(DC, Result, False) > MaxLen) do
    begin
      if Dir = '\...\' then
      begin
        Drive := '';
        Dir := '...\';
      end
      else if Dir = '' then
        Drive := ''
      else
        CutFirstDirectory(Dir);
      Result := Drive + Dir + Name;
    end;
  finally
    ReleaseDC(0, DC);
  end;
end;

procedure SetMessageBoxCaption(const Typ: TMsgBoxType; const NewCaption: PChar);
begin
  StrDispose(MessageBoxCaptions[Typ]);
  MessageBoxCaptions[Typ] := nil;
  if Assigned(NewCaption) then
    MessageBoxCaptions[Typ] := StrNew(NewCaption);
end;

{$IFNDEF IS_D4}
function MoveAppWindowToActiveWindowMonitor(var OldRect: TRect): Boolean;
{ This moves the application window (Application.Handle) to the same monitor
  as the active window, so that a subsequent call to Application.MessageBox
  displays the message box on that monitor. Based on code from D4+'s
  TApplication.MessageBox. }
type
  HMONITOR = type THandle;
  TMonitorInfo = record
    cbSize: DWORD;
    rcMonitor: TRect;
    rcWork: TRect;
    dwFlags: DWORD;
  end;
const
  MONITOR_DEFAULTTONEAREST = $00000002;
var
  ActiveWindow: HWND;
  Module: HMODULE;
  MonitorFromWindow: function(hwnd: HWND; dwFlags: DWORD): HMONITOR; stdcall;
  GetMonitorInfo: function(hMonitor: HMONITOR; var lpmi: TMonitorInfo): BOOL; stdcall;
  MBMonitor, AppMonitor: HMONITOR;
  Info: TMonitorInfo;
begin
  Result := False;
  ActiveWindow := GetActiveWindow;
  if ActiveWindow = 0 then Exit;
  Module := GetModuleHandle(user32);
  MonitorFromWindow := GetProcAddress(Module, 'MonitorFromWindow');
  GetMonitorInfo := GetProcAddress(Module, 'GetMonitorInfoA');
  if Assigned(MonitorFromWindow) and Assigned(GetMonitorInfo) then begin
    MBMonitor := MonitorFromWindow(ActiveWindow, MONITOR_DEFAULTTONEAREST);
    AppMonitor := MonitorFromWindow(Application.Handle, MONITOR_DEFAULTTONEAREST);
    if MBMonitor <> AppMonitor then begin
      Info.cbSize := SizeOf(Info);
      if GetMonitorInfo(MBMonitor, Info) then begin
        GetWindowRect(Application.Handle, OldRect);
        SetWindowPos(Application.Handle, 0,
          Info.rcMonitor.Left + ((Info.rcMonitor.Right - Info.rcMonitor.Left) div 2),
          Info.rcMonitor.Top + ((Info.rcMonitor.Bottom - Info.rcMonitor.Top) div 2),
          0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER);
        Result := True;
      end;
    end;
  end;
end;
{$ENDIF}

function AppMessageBox(const Text, Caption: PChar; Flags: Longint): Integer;
{$IFNDEF IS_D4}
var
  DidMove: Boolean;
  OldRect: TRect;
{$ENDIF}
begin
  {$IFNDEF IS_D4}
  DidMove := MoveAppWindowToActiveWindowMonitor(OldRect);
  try
  {$ENDIF}
    Result := Application.MessageBox(Text, Caption, Flags);
  {$IFNDEF IS_D4}
  finally
    if DidMove then
      SetWindowPos(Application.Handle, 0,
        OldRect.Left + ((OldRect.Right - OldRect.Left) div 2),
        OldRect.Top + ((OldRect.Bottom - OldRect.Top) div 2),
        0, 0, SWP_NOACTIVATE or SWP_NOREDRAW or SWP_NOSIZE or SWP_NOZORDER);
  end;
  {$ENDIF}
end;

function MsgBoxP(const Text, Caption: PChar; const Typ: TMsgBoxType;
  const Buttons: Cardinal): Integer;
const
  IconFlags: array[TMsgBoxType] of Cardinal =
    (MB_ICONINFORMATION, MB_ICONQUESTION, MB_ICONEXCLAMATION, MB_ICONSTOP);
  {$IFNDEF Delphi3orHigher}
  DefaultCaptions: array[TMsgBoxType] of Word =
    (SMsgDlgInformation, SMsgDlgConfirm, SMsgDlgError, SMsgDlgError);
  {$ELSE}
  DefaultCaptions: array[TMsgBoxType] of Pointer =
    (@SMsgDlgInformation, @SMsgDlgConfirm, @SMsgDlgError, @SMsgDlgError);
  {$ENDIF}
var
  C: PChar;
  NewCaption: String;
begin
  C := Caption;
  if (C = nil) or (C[0] = #0) then begin
    C := MessageBoxCaptions[Typ];
    if C = nil then begin
      {$IFNDEF Delphi3orHigher}
      NewCaption := LoadStr(DefaultCaptions[Typ]);
      {$ELSE}
      NewCaption := LoadResString(DefaultCaptions[Typ]);
      {$ENDIF}
      C := PChar(NewCaption);
    end;
  end;
  Result := AppMessageBox(Text, C, Buttons or IconFlags[Typ]);
end;

function MsgBox(const Text, Caption: String; const Typ: TMsgBoxType;
  const Buttons: Cardinal): Integer;
begin
  Result := MsgBoxP(PChar(Text), PChar(Caption), Typ, Buttons);
end;

function MsgBoxFmt(const Text: String; const Args: array of const;
  const Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal): Integer;
begin
  Result := MsgBox(Format(Text, Args), Caption, Typ, Buttons);
end;

procedure FreeCaptions; far;
var
  T: TMsgBoxType;
begin
  for T := Low(T) to High(T) do begin
    StrDispose(MessageBoxCaptions[T]);
    MessageBoxCaptions[T] := nil;
  end;
end;

initialization
finalization
  FreeCaptions;
end.