jvqjvclutils.pas

East make Tray Icon in delphi

function PointInPolyRgn(const P: TPoint; const Points: array of TPoint):
  Boolean;
type
  PPoints = ^TPoints;
  TPoints = array [0..0] of TPoint;
var
  Rgn: HRGN;
begin
  Rgn := CreatePolygonRgn(PPoints(@Points)^, High(Points) + 1, WINDING);
  try
    Result := PtInRegion(Rgn, P.X, P.Y);
  finally
    DeleteObject(Rgn);
  end;
end;

function PaletteColor(Color: TColor): Longint;
begin
  Result := ColorToRGB(Color) or PaletteMask;
end;



procedure Delay(MSecs: Int64);
var
  FirstTickCount, Now: Int64;
begin
  FirstTickCount := GetTickCount64;
  repeat
    Application.ProcessMessages;
    { allowing access to other controls, etc. }
    Now := GetTickCount64;
  until (Now - FirstTickCount >= MSecs);
end;

function GetTickCount64: Int64;
var
  QFreq, QCount: Int64;
begin
   Result := GetTickCount;
   if QueryPerformanceFrequency(QFreq) then
   begin
     QueryPerformanceCounter(QCount);
     if QFreq <> 0 then
       Result := (QCount div QFreq) * 1000;
  end;
end;

procedure CenterControl(Control: TControl);
var
  X, Y: Integer;
begin
  X := Control.Left;
  Y := Control.Top;
  if Control is TForm then
  begin
    with Control do
    begin
      if (TForm(Control).FormStyle = fsMDIChild) and
        (Application.MainForm <> nil) then
      begin
        X := (Application.MainForm.ClientWidth - Width) div 2;
        Y := (Application.MainForm.ClientHeight - Height) div 2;
      end
      else
      begin
        X := (Screen.Width - Width) div 2;
        Y := (Screen.Height - Height) div 2;
      end;
    end;
  end
  else
  if Control.Parent <> nil then
  begin
    with Control do
    begin
      Parent.HandleNeeded;
      X := (Parent.ClientWidth - Width) div 2;
      Y := (Parent.ClientHeight - Height) div 2;
    end;
  end;
  if X < 0 then
    X := 0;
  if Y < 0 then
    Y := 0;
  with Control do
    SetBounds(X, Y, Width, Height);
end;

procedure MergeForm(AControl: TWinControl; AForm: TForm; Align: TAlign;
  Show: Boolean);
var
  R: TRect;
  AutoScroll: Boolean;
begin
  AutoScroll := AForm.AutoScroll;
  AForm.Hide;
  TCustomControlAccessProtected(AForm).DestroyHandle;
  with AForm do
  begin
    BorderStyle := fbsNone;
    BorderIcons := [];
    Parent := AControl;
  end;
  AControl.DisableAlign;
  try
    if Align <> alNone then
      AForm.Align := Align
    else
    begin
      R := AControl.ClientRect;
      AForm.SetBounds(R.Left + AForm.Left, R.Top + AForm.Top, AForm.Width,
        AForm.Height);
    end;
    AForm.AutoScroll := AutoScroll;
    AForm.Visible := Show;
  finally
    AControl.EnableAlign;
  end;
end;



function ScreenWorkArea: TRect;
begin
  {$IFDEF MSWINDOWS}
  if not SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0) then
  {$ENDIF MSWINDOWS}
    with Screen do
      Result := Bounds(0, 0, Width, Height);
end;

{ Standard Windows MessageBox function }

function MsgBox(const Caption, Text: string; Flags: Integer): Integer;


var
  Mbs: TMessageButtons;
  Def: TMessageButton;
  Style: TMessageStyle;
  DefFlags: Integer;
begin
  Mbs := [];
  DefFlags := Flags and $00000F00;
  case Flags and $0000000F of
    MB_OK:
      begin
        Mbs := [smbOk];
        Def := smbOk;
      end;
    MB_OKCANCEL:
      begin
        Mbs := [smbOk, smbCancel];
        Def := smbOk;
        if DefFlags <> MB_DEFBUTTON1 then
          Def := smbCancel;
      end;
    MB_ABORTRETRYIGNORE:
      begin
        Mbs := [smbAbort, smbRetry, smbIgnore];
        Def := smbAbort;
        case DefFlags of
          MB_DEFBUTTON2:
            Def := smbRetry;
          MB_DEFBUTTON3:
            Def := smbIgnore;
        end;
      end;
    MB_YESNOCANCEL:
      begin
        Mbs := [smbYes, smbNo, smbCancel];
        Def := smbYes;
        case DefFlags of
          MB_DEFBUTTON2:
            Def := smbNo;
          MB_DEFBUTTON3:
            Def := smbCancel;
        end;
      end;
    MB_YESNO:
      begin
        Mbs := [smbYes, smbNo];
        Def := smbYes;
        if DefFlags <> MB_DEFBUTTON1 then
          Def := smbNo;
      end;
    MB_RETRYCANCEL:
      begin
        Mbs := [smbRetry, smbCancel];
        Def := smbRetry;
        if DefFlags <> MB_DEFBUTTON1 then
          Def := smbCancel;
      end;
  else
    Mbs := [smbOk];
    Def := smbOk;
  end;

  case Flags and $000000F0 of
    MB_ICONWARNING:
      Style := smsWarning;
    MB_ICONERROR:
      Style := smsCritical;
  else
    Style := smsInformation;
  end;

  case Application.MessageBox(Text, Caption, Mbs, Style, Def) of
    smbOk:
      Result := IDOK;
    smbCancel:
      Result := IDCANCEL;
    smbAbort:
      Result := IDABORT;
    smbRetry:
      Result := IDRETRY;
    smbIgnore:
      Result := IDIGNORE;
    smbYes:
      Result := IDYES;
    smbNo:
      Result := IDNO;
  else
    Result := IDOK;
  end;
end;



{ Gradient fill procedure - displays a gradient beginning with a chosen        }
{ color and ending with another chosen color. Based on TGradientFill           }
{ component source code written by Curtis White, cwhite att teleport dott com. }

procedure GradientFillRect(Canvas: TCanvas; ARect: TRect; StartColor,
  EndColor: TColor; Direction: TFillDirection; Colors: Byte);
var
  StartRGB: array [0..2] of Byte; { Start RGB values }
  RGBDelta: array [0..2] of Integer;
  { Difference between start and end RGB values }
  ColorBand: TRect; { Color band rectangular coordinates }
  I, Delta: Integer;
  Brush: HBRUSH;
  TmpColor: TColor;
begin  
  Canvas.Start; 
  try
    if (StartColor = clNone) and (EndColor = clNone) then
      Exit;
    if not (IsRectEmpty(ARect) and (GetMapMode(Canvas.Handle) = MM_TEXT)) then
    begin  
      StartColor := ColorFromColormap(StartColor);
      EndColor := ColorFromColormap(EndColor); 
      if Direction in [fdBottomToTop, fdRightToLeft] then
      begin
        // just swap the colors
        TmpColor := StartColor;
        StartColor := EndColor;
        EndColor := TmpColor;
        if Direction = fdBottomToTop then
          Direction := fdTopToBottom
        else
          Direction := fdLeftToRight;
      end;
      if (Colors < 2) or (StartColor = EndColor) then
      begin
        Brush := CreateSolidBrush(ColorToRGB(StartColor));
        FillRect(Canvas.Handle, ARect, Brush);
        DeleteObject(Brush);
        Exit;
      end;
          { Set the Red, Green and Blue colors }
      StartRGB[0] := GetRValue(StartColor);
      StartRGB[1] := GetGValue(StartColor);
      StartRGB[2] := GetBValue(StartColor);
          { Calculate the difference between begin and end RGB values }
      RGBDelta[0] := GetRValue(EndColor) - StartRGB[0];
      RGBDelta[1] := GetGValue(EndColor) - StartRGB[1];
      RGBDelta[2] := GetBValue(EndColor) - StartRGB[2];
      { Calculate the color band's coordinates }
      ColorBand := ARect;
      if Direction = fdTopToBottom then
      begin
        Colors := Max(2, Min(Colors, RectHeight(ARect)));
        Delta := RectHeight(ARect) div Colors;
      end
      else
      begin
        Colors := Max(2, Min(Colors, RectWidth(ARect)));
        Delta := RectWidth(ARect) div Colors;
      end;
      with Canvas.Pen do
      begin { Set the pen style and mode }
        Style := psSolid;
        Mode := pmCopy;
      end;
      { Perform the fill }
      if Delta > 0 then
      begin
        for I := 0 to Colors - 1 do
        begin
          if Direction = fdTopToBottom then
          { Calculate the color band's top and bottom coordinates }
          begin
            ColorBand.Top := ARect.Top + I * Delta;
            ColorBand.Bottom := ColorBand.Top + Delta;
          end
          { Calculate the color band's left and right coordinates }
          else
          begin
            ColorBand.Left := ARect.Left + I * Delta;
            ColorBand.Right := ColorBand.Left + Delta;
          end;
        { Calculate the color band's color }
          Brush := CreateSolidBrush(RGB(
            StartRGB[0] + MulDiv(I, RGBDelta[0], Colors - 1),
            StartRGB[1] + MulDiv(I, RGBDelta[1], Colors - 1),
            StartRGB[2] + MulDiv(I, RGBDelta[2], Colors - 1)));
          FillRect(Canvas.Handle, ColorBand, Brush);
          DeleteObject(Brush);
        end;
      end;
      if Direction = fdTopToBottom then
        Delta := RectHeight(ARect) mod Colors
      else
        Delta := RectWidth(ARect) mod Colors;
      if Delta > 0 then
      begin
        if Direction = fdTopToBottom then
        { Calculate the color band's top and bottom coordinates }
        begin
          ColorBand.Top := ARect.Bottom - Delta;
          ColorBand.Bottom := ColorBand.Top + Delta;
        end
        else
        { Calculate the color band's left and right coordinates }
        begin
          ColorBand.Left := ARect.Right - Delta;
          ColorBand.Right := ColorBand.Left + Delta;
        end;
        Brush := CreateSolidBrush(EndColor);
        FillRect(Canvas.Handle, ColorBand, Brush);
        DeleteObject(Brush);
      end;
    end; //  if Not (IsRectEmpty(ARect) and ...
  finally  
    Canvas.Stop; 
  end;
end;

function GetAveCharSize(Canvas: TCanvas): TPoint;
var
  I: Integer;
  Buffer: array [0..51] of Char;
begin
  for I := 0 to 25 do
    Buffer[I] := Chr(I + Ord('A'));
  for I := 0 to 25 do
    Buffer[I + 26] := Chr(I + Ord('a')); 
  Canvas.Start; 
  GetTextExtentPoint32(Canvas.Handle, Buffer, 52, TSize(Result)); 
  Canvas.Stop; 
  Result.X := Result.X div 52;
end;

{ Cursor routines }

{$IFDEF MSWINDOWS}
function LoadAniCursor(Instance: THandle; ResID: PChar): HCURSOR;
{ Unfortunately I don't know how we can load animated cursor from
  executable resource directly. So I write this routine using temporary
  file and LoadCursorFromFile function. }
var
  S: TFileStream;
  Path, FileName: array[0..MAX_PATH] of Char;
  RSrc: HRSRC;
  Res: THandle;
  Data: Pointer;
begin
  Integer(Result) := 0;
  RSrc := FindResource(Instance, ResID, RT_ANICURSOR);
  if RSrc <> 0 then
  begin
    OSCheck(GetTempPath(MAX_PATH, Path) <> 0);
    OSCheck(GetTempFileName(Path, 'ANI', 0, FileName) <> 0);
    try
      Res := LoadResource(Instance, RSrc);
      try
        Data := LockResource(Res);
        if Data <> nil then
        try
          S := TFileStream.Create(StrPas(FileName), fmCreate);
          try
            S.WriteBuffer(Data^, SizeOfResource(Instance, RSrc));
          finally
            S.Free;
          end;
          Result := LoadCursorFromFile(FileName);
        finally
          UnlockResource(Res);
        end;
      finally
        FreeResource(Res);
      end;
    finally
      Windows.DeleteFile(FileName);
    end;
  end;
end;
{$ENDIF MSWINDOWS}

function GetNextFreeCursorIndex(StartHint: Integer; PreDefined: Boolean):
  Integer;
begin
  Result := StartHint;
  if PreDefined then
  begin
    if Result >= crSizeAll then Result := crSizeAll - 1;
  end
  else
  if Result <= crDefault then
    Result := crDefault + 1;
  while (Screen.Cursors[Result] <> Screen.Cursors[crDefault]) do
  begin
    if PreDefined then
      Dec(Result)
    else
      Inc(Result);
    if (Result < Low(TCursor)) or (Result > High(TCursor)) then
      raise EOutOfResources