advmenuutil.pas

来自「delphi 第三方控件很出色,表格制作的」· PAS 代码 · 共 300 行

unit AdvMenuUtil;

{$I TMSDEFS.INC}

interface

uses
  Classes, Windows, Graphics, SysUtils, Menus
  {$IFDEF TMSDOTNET}
  , Types
  {$ENDIF}
  ;


resourcestring
  SInvalidPropertyIndexAt = 'Invalid property index %d at %s.';
  SInvalidPropertyIndex = 'Invalid property index %d.';
  SRequireOwner = 'Tried to create %s with no owner.';

type
  EInvalidPropertyIndex = class(Exception);
  ERequireOwner = class(Exception);

  TColorQuad = record
    Red, Green, Blue, Alpha: Byte;
  end;

  TSmallColorQuad = record
    Red, Green, Blue: Byte;
  end;

  TLargeColorQuad = record
    Red, Green, Blue, Alpha: Longint;
  end;

  T24bitScanLineElement = record
    Blue, Green, Red: Byte;
  end;

  T32bitScanLineElement = record
    Blue, Green, Red, Alpha: Byte;
  end;

  P24bitQuadScanLine = ^T24bitQuadScanLine;
  T24bitQuadScanLine = array[0..High(Word) div 3] of T24bitScanLineElement;

  P32bitQuadScanLine = ^T32bitQuadScanLine;
  T32bitQuadScanLine = array[0..High(Word) div 3] of T32bitScanLineElement;

  TOpacity = 0..255;

  {$IFNDEF TMSDOTNET}
  TSetLayeredWindowAttributes = function(hWnd: THandle; crKey: TColorRef; bAlpha: Byte;
    dwFlags: Cardinal): BOOL; stdcall;
  TUpdateLayeredWindow = function(hWnd: THandle; hdcDst: HDC; pptDst: PPoint;
    psize: PSize; hdcSrc: HDC; pptSrc: PPoint; crKey: TColorRef;
    pblend: PBlendFunction; dwFlags: Cardinal): BOOL; stdcall;
  {$ENDIF}

{$IFNDEF TMSDOTNET}
const
  LWA_ALPHA = $00000002;
  LWA_COLORKEY  = $00000001;
  ULW_COLORKEY  = $00000001;
  ULW_ALPHA     = $00000002;
  ULW_OPAQUE    = $00000004;
  AC_SRC_ALPHA  = $01;
  WS_EX_LAYERED = $00080000;

function SupportsLayeredWindows: Boolean;
function SetWindowLayered(Handle: THandle; Value: Boolean): Boolean;
{$ENDIF}

function ColorTo24bitScanLineElement(Color: TColor): T24bitScanLineElement;
function ColorTo32bitScanLineElement(Color: TColor): T32bitScanLineElement;
procedure ColorToRGBVal(AColor: TColor; var R,G,B: Integer);
function RGB(Red, Green, Blue: Byte; Alpha: Byte = $00): TColor;
function Min(Value1, Value2: Integer): Integer;
function Max(Value1, Value2: Integer): Integer;

function CreateRotatedFont(F: TFont; const Angle: Integer): HFont;

function RectWidth(const ARect: TRect): Integer;
function RectHeight(const ARect: TRect): Integer;
function RectInRect(const Source, Target: TRect): Boolean;
function CenterPoint(const ARect: TRect): TPoint;

function BitmapRect(const ABitmap: TBitmap): TRect;

var
  NilRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
{$IFNDEF TMSDOTNET}
  UpdateLayeredWindow: TUpdateLayeredWindow = nil;
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes = nil;
{$ENDIF}

implementation

{$IFNDEF TMSDOTNET}
var
  User32Dll: HMODULE;
  FSupportsLayeredWindows: Boolean;
{$ENDIF}  

{ ============================================================================
  CreateRotatedFont
  Description: Creates rotated font, returns handle to it
  ---------------------------------------------------------------------------- }
function CreateRotatedFont(F: TFont; const Angle: Integer): HFont;
var
  LF : TLogFont;
begin
{$IFNDEF TMSDOTNET}
  FillChar(LF, SizeOf(LF), #0);
{$ENDIF}  
  with LF do
  begin
    lfHeight := F.Height;
    lfWidth := 0;
    lfEscapement := Angle * 10;
    lfOrientation := 0;
    if fsBold in F.Style then
      lfWeight := FW_BOLD
    else
      lfWeight := FW_NORMAL;
    lfItalic := Byte(fsItalic in F.Style);
    lfUnderline := Byte(fsUnderline in F.Style);
    lfStrikeOut := Byte(fsStrikeOut in F.Style);
    lfCharSet := DEFAULT_CHARSET;

    {$IFNDEF TMSDOTNET}
    StrPCopy(lfFaceName, F.Name);
    {$ENDIF}
    {$IFDEF TMSDOTNET}
    lfFaceName := F.Name;
    {$ENDIF}
    
    lfQuality := DEFAULT_QUALITY;

    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    case F.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
    else
      lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LF);
end;


function RectInRect(const Source, Target: TRect): Boolean;
begin
  Result := (PtInRect(Target, Source.TopLeft) and PtInRect(Target, Source.BottomRight));
end;

function RectWidth(const ARect: TRect): Integer;
begin
  Result := ARect.Right - ARect.Left;
end;

function RectHeight(const ARect: TRect): Integer;
begin
  Result := ARect.Bottom - ARect.Top;
end;

function CenterPoint(const ARect: TRect): TPoint;
begin
  Result.X := (ARect.Left + ARect.Right) div 2;
  Result.Y := (ARect.Top + ARect.Bottom) div 2;
end;


function BitmapRect(const ABitmap: TBitmap): TRect;
begin
  if Assigned(ABitmap) then
    Result := Rect(0, 0, ABitmap.Width, ABitmap.Height)
  else
    Result := Rect(0, 0, 0, 0);
end;

procedure ColorToRGBVal(AColor: TColor; var R,G,B: Integer);
var
  rgb: Integer;
begin
  rgb := ColorToRGB(AColor);

  {$IFNDEF TMSDOTNET}
  R := TColorQuad(rgb).Red;
  G := TColorQuad(rgb).Green;
  B := TColorQuad(rgb).Blue;
  {$ENDIF}

  {$IFDEF TMSDOTNET}
  R := rgb and $FF;
  G := (rgb shr 8) and $FF;
  B := (rgb shr 16) and $FF;
  {$ENDIF}
end;

function ColorTo24bitScanLineElement(Color: TColor): T24bitScanLineElement;
{$IFDEF TMSDOTNET}
var
  rgb: Integer;
{$ENDIF}
begin
  {$IFNDEF TMSDOTNET}
  Result.Red := TColorQuad(Color).Red;
  Result.Green := TColorQuad(Color).Green;
  Result.Blue := TColorQuad(Color).Blue;
  {$ENDIF}

  {$IFDEF TMSDOTNET}
  rgb := ColorToRGB(Color);
  Result.Red := rgb and $FF;
  Result.Green := (rgb shr 8) and $FF;
  Result.Blue := (rgb shr 16) and $FF;
  {$ENDIF}
end;

function ColorTo32bitScanLineElement(Color: TColor): T32bitScanLineElement;
{$IFDEF TMSDOTNET}
var
  rgb: Integer;
{$ENDIF}
begin
{$IFNDEF TMSDOTNET}
  Result.Red := TColorQuad(Color).Red;
  Result.Green := TColorQuad(Color).Green;
  Result.Blue := TColorQuad(Color).Blue;
  Result.Alpha := TColorQuad(Color).Alpha;
{$ENDIF}
{$IFDEF TMSDOTNET}
  rgb := ColorToRGB(Color);
  Result.Red := rgb and $FF;
  Result.Green := (rgb shr 8) and $FF;
  Result.Blue := (rgb shr 16) and $FF;
  Result.Alpha := (rgb shr 24) and $FF;
{$ENDIF}
end;

function RGB(Red, Green, Blue: Byte; Alpha: Byte = $00): TColor;
begin
  Result := (Alpha shl 24) or (Blue shl 16) or (Green shl 8) or Red;
end;

function Min(Value1, Value2: Integer): Integer;
begin
  if Value1 > Value2 then
    Result := Value2
  else
    Result := Value1;
end;

function Max(Value1, Value2: Integer): Integer;
begin
  if Value1 < Value2 then
    Result := Value2
  else
    Result := Value1;
end;



{$IFNDEF TMSDOTNET}
function SupportsLayeredWindows: Boolean;
begin
  Result := FSupportsLayeredWindows;
end;

function SetWindowLayered(Handle: THandle; Value: Boolean): Boolean;
var Flags: Integer;
begin
  Result := True;
  Flags := GetWindowLong(Handle, GWL_EXSTYLE);
  if Value then
  begin
    if ((Flags and WS_EX_LAYERED) = 0) then
      SetWindowLong(Handle, GWL_EXSTYLE, Flags or WS_EX_LAYERED)
  end else if (Flags and WS_EX_LAYERED) <> 0 then
    SetWindowLong(Handle, GWL_EXSTYLE, Flags and not WS_EX_LAYERED);
end;

initialization
  User32Dll := LoadLibrary(user32);
  FSupportsLayeredWindows := False;
  if User32Dll <> 0 then
  begin
    UpdateLayeredWindow := GetProcAddress(User32Dll, 'UpdateLayeredWindow');
    SetLayeredWindowAttributes := GetProcAddress(User32Dll, 'SetLayeredWindowAttributes');
    FreeLibrary(User32Dll);

    FSupportsLayeredWindows := Assigned(SetLayeredWindowAttributes);
  end;
{$ENDIF}

end.