jvgutils.pas

East make Tray Icon in delphi

  CreateBitmapExt(DC, SourceBitmap, R, X, Y, BitmapOption,
    DrawState, ATransparent, TransparentColor, DisabledMaskColor);
end;

//..DrawBitmap algorithm borrow from Delphi2 VCL Sources
{ create bimap based on SourceBitmap and write new bitmap to DC }

procedure CreateBitmapExt(DC: HDC; {target DC}
  SourceBitmap: TBitmap; R: TRect;
  X, Y: Integer; //...X,Y _in_ rect!
  BitmapOption: TglWallpaperOption; DrawState: TglDrawState;
  ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);
const
  ROP_DSPDxax = $00E20746;
var
  X1, Y1, H, W: Integer;
  D, D1: Double;
  TmpImage, MonoBMP: TBitmap;
  IWidth, IHeight: Integer;
  IRect, ORect: TRect;
  //  DestDC: HDC;
  BmpInfo: Windows.TBitmap;
  PtSize, PtOrg: TPoint;
  MemDC, ImageDC: HDC;
  OldBMP, OldMonoBMP, OldScreenImageBMP, OldMemBMP: HBITMAP;
  HMonoBMP, ScreenImageBMP, MemBMP: HBITMAP;
  MonoDC, ScreenImageDC: HDC;
  OldBkColor: COLORREF;
  SavedIHeight: Integer;

  procedure BitBltWorks;
  begin
    if ATransparent then
    begin
      { create copy of drawing image }
      BitBlt(MemDC, 0, 0, IWidth, IHeight, ImageDC, 0, 0, SRCCOPY);
      if DrawState = fdsDisabled then
        TransparentColor := clBtnFace;
      OldBkColor := SetBkColor(MemDC, ColorToRGB(TransparentColor));
      { create monohrome mask: TransparentColor -> white, other color -> black }
      BitBlt(MonoDC, 0, 0, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);
      SetBkColor(MemDC, OldBkColor);
      {create copy of screen image}
      BitBlt(ScreenImageDC, 0, 0, IWidth, IHeight, DC, X1, Y1, SRCCOPY);
      { put monochrome mask }
      BitBlt(ScreenImageDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, SRCAND);
      BitBlt(MonoDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, NOTSRCCOPY);
      { put inverse monochrome mask }
      BitBlt(MemDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, SRCAND);
      { merge Screen screen image(MemDC) and Screen image(ScreenImageDC) }
      BitBlt(MemDC, 0, 0, IWidth, IHeight, ScreenImageDC, 0, 0, SRCPAINT);
      { to screen }
      //    DSTINVERT MERGEPAINT
      BitBlt(DC, X1, Y1, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);
    end
    else
      BitBlt(DC, X1, Y1, IWidth, IHeight, ImageDC, 0, 0, SRCCOPY);
  end;

begin
  if (SourceBitmap.Width = 0) or (SourceBitmap.Height = 0) then
    Exit;

  X := X + R.Left;
  Y := Y + R.Top;
  X1 := X;
  Y1 := Y;
  OldBMP := 0;
  OldMemBMP := 0;
  OldMonoBMP := 0;
  OldScreenImageBMP := 0;
  MemDC := 0;
  ImageDC := 0;
  // MonoBMP := 0;
  // ScreenImageBMP := 0;
  // MemBMP := 0;
  MonoDC := 0;
  ScreenImageDC := 0;

  IWidth := SourceBitmap.Width; //Min( SourceBitmap.Width, R.Right-R.Left );
  IHeight := SourceBitmap.Height; //Min( SourceBitmap.Height, R.Bottom-R.Top );
  TmpImage := TBitmap.Create;
  try
    TmpImage.Width := IWidth;
    TmpImage.Height := IHeight;
    IRect := Rect(0, 0, IWidth, IHeight);
    ORect := Rect(0, 0, IWidth, IHeight);

    TmpImage.Canvas.Brush.Color := TransparentColor;
    TmpImage.Canvas.FillRect(Rect(0, 0, IWidth, IHeight));

    case DrawState of
      fdsDefault:
        BitBlt(TmpImage.Canvas.Handle, 0, 0, IWidth, IHeight,
          SourceBitmap.Canvas.Handle, 0, 0, SRCCOPY);
      fdsDelicate:
        begin
          with TmpImage.Canvas do
            BitBlt(Handle, 0, 0, IWidth, IHeight,
              SourceBitmap.Canvas.Handle, 0, 0, SRCCOPY);
          { Convert white to clBtnHighlight }
          ChangeBitmapColor(TmpImage, clWhite, clBtnHighlight);
          { Convert gray to clBtnShadow }
          ChangeBitmapColor(TmpImage, clGray, clBtnShadow);
          { Convert transparent color to clBtnFace }
          //     ChangeBitmapColor(TmpImage,ColorToRGB(}TransparentColor),clBtnFace);
        end;
      fdsDisabled:
        begin
          if DisabledMaskColor <> 0 then
            ChangeBitmapColor(TmpImage, DisabledMaskColor, clBlack);
          MonoBMP := TBitmap.Create;
          try { Create a disabled version }
            with MonoBMP do
            begin
              Assign(SourceBitmap);
              Canvas.Brush.Color := 0;
              Width := IWidth;
              if Monochrome then
              begin
                Canvas.Font.Color := clWhite;
                Monochrome := False;
                Canvas.Brush.Color := clWhite;
              end;
              Monochrome := True;
            end;
            with TmpImage.Canvas do
            begin
              Brush.Color := clBtnFace;
              FillRect(IRect);
              Brush.Color := clBtnHighlight;
              SetTextColor(Handle, 0);
              SetBkColor(Handle, clWhite);
              BitBlt(Handle, 1, 1, IWidth, IHeight,
                MonoBMP.Canvas.Handle, 0, 0, ROP_DSPDxax);
              Brush.Color := clBtnShadow;
              SetTextColor(Handle, 0);
              SetBkColor(Handle, clWhite);
              BitBlt(Handle, 0, 0, IWidth, IHeight,
                MonoBMP.Canvas.Handle, 0, 0, ROP_DSPDxax);
            end;
          finally
            MonoBMP.Free;
          end;
        end;
    end;

    with TmpImage.Canvas do
      if (BitmapOption = fwoStretch) or (BitmapOption = fwoPropStretch) then
      begin
        MemDC := CreateCompatibleDC(DC);
        MemBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, R.Right - R.Left, R.Bottom - R.Top);
        OldMemBMP := SelectObject(MemDC, MemBMP);
        W := R.Right - R.Left;
        H := R.Bottom - R.Top;
        if BitmapOption = fwoPropStretch then
        begin
          D1 := W / IWidth;
          D := H / IHeight;
          if D > D1 then
            D := D1; //...D == Min
          W := Trunc(IWidth * D);
          H := Trunc(IHeight * D);
        end;
        StretchBlt(MemDC, 0, 0, W, H, Handle, 0, 0, IWidth, IHeight, SRCCOPY);

        IWidth := W;
        IHeight := H;
        TmpImage.Width := W;
        TmpImage.Height := H;
        BitBlt(Handle, 0, 0, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);

        DeleteObject(SelectObject(MemDC, OldMemBMP));
        DeleteDC(MemDC);
      end;

    ImageDC := CreateCompatibleDC(DC);

    if ATransparent then
    begin
      MemDC := CreateCompatibleDC(DC);
      ScreenImageDC := CreateCompatibleDC(DC);
      MonoDC := CreateCompatibleDC(DC);

      HMonoBMP := CreateBitmap(IWidth, IHeight, 1, 1, nil);
      ScreenImageBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, IWidth, IHeight);
      MemBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, IWidth, IHeight);

      OldMonoBMP := SelectObject(MonoDC, HMonoBMP);
      OldScreenImageBMP := SelectObject(ScreenImageDC, ScreenImageBMP);
      OldMemBMP := SelectObject(MemDC, MemBMP);
    end;
    OldBMP := SelectObject(ImageDC, TmpImage.Handle);

    if OldBMP <> 0 then
    begin
      SetMapMode(ImageDC, GetMapMode(DC));
      GetObject(TmpImage.Handle, SizeOf(Windows.TBitmap), @BmpInfo);
      PtSize.X := BmpInfo.bmWidth;
      PtOrg.X := 0;
      PtSize.Y := BmpInfo.bmHeight;
      PtOrg.Y := 0;
      if ATransparent then
      begin
        DPtoLP(DC, PtSize, 1);
        DPtoLP(MemDC, PtOrg.Y, 1);
      end;
      if BitmapOption = fwoTile then
      begin
        //SavedIWidth:=IWidth;
        SavedIHeight := IHeight;
        while X1 < R.Right do
        begin
          //IWidth:=SavedIWidth; //SavedIWidth:=IWidth;
          if X1 + IWidth > R.Right then
            IWidth := R.Right - X1;
          while Y1 < R.Bottom do
          begin
            IHeight := SavedIHeight; // SavedIHeight:=IHeight;
            if Y1 + IHeight > R.Bottom then
              IHeight := R.Bottom - Y1;
            BitBltWorks;
            Inc(Y1, IHeight);
          end;
          Inc(X1, IWidth);
          Y1 := Y;
        end;
      end
      else
        BitBltWorks;
    end;
  finally
    DeleteObject(SelectObject(ImageDC, OldBMP));
    DeleteDC(ImageDC);
    if ATransparent then
    begin
      DeleteObject(SelectObject(MonoDC, OldMonoBMP));
      DeleteObject(SelectObject(ScreenImageDC, OldScreenImageBMP));
      DeleteObject(SelectObject(MemDC, OldMemBMP));
      DeleteDC(MonoDC);
      DeleteDC(ScreenImageDC);
      DeleteDC(MemDC);
    end;
    TmpImage.Free;
  end;

end;

{ Brings parent window to front }

procedure BringParentWindowToTop(Wnd: TWinControl);
begin
  if Wnd is TForm then
    BringWindowToTop(Wnd.Handle)
  else
  if Wnd.Parent is TWinControl then
    BringParentWindowToTop(Wnd.Parent);
end;

{ Gives parent window of TForm class }

function GetParentForm(Control: TControl): TForm;
begin
  if Control is TForm then
    Result := TForm(Control)
  else
  if Control.Parent is TWinControl then
    Result := GetParentForm(Control.Parent)
  else
    Result := nil;
end;


{ Paints TWinControl with all its content onto DC with offset(shift) X,Y
  ...from rxLib... :( very sorry }

procedure GetWindowImageFrom(Control: TWinControl; X, Y: Integer; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);
var
  I, Count, SaveIndex: Integer;
begin
  if Control = nil then
    Exit;
  Count := Control.ControlCount;

  { Copy self image }
  if ADrawSelf then
  begin
    SaveIndex := SaveDC(DC);
    SetViewportOrgEx(DC, X, Y, nil);
    TJvgPublicWinControl(Control).PaintWindow(DC);
    RestoreDC(DC, SaveIndex);
  end;
  { Copy images of graphic controls }
  for I := 0 to Count - 1 do
  begin
    if Control.Controls[I] <> nil then
    begin
      if Control.Controls[I] = Control then
        Break;
      if (Control.Controls[I] is TWinControl) and ADrawChildWindows then
        GetWindowImageFrom(TWinControl(Control.Controls[I]),
          TWinControl(Control.Controls[I]).Left,
          TWinControl(Control.Controls[I]).Top,
          True {ADrawSelf}, ADrawChildWindows, DC)
      else
        with Control.Controls[I] do
          if Visible then
          begin
            SaveIndex := SaveDC(DC);
            SetViewportOrgEx(DC, Left + X, Top + Y, nil);
            Perform(WM_PAINT, Longint(DC), 0);
            RestoreDC(DC, SaveIndex);
          end;
    end;
  end;
end;

{ Paints(renders) TWinControl with all its content onto DC with offset (0,0) }

procedure GetWindowImage(Control: TWinControl; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);
begin
  GetWindowImageFrom(Control, 0, 0, ADrawSelf, ADrawChildWindows, DC);
end;

{ Paints parent TWinControl with all its contents onto DC with limit of Rect }

procedure GetParentImageRect(Control: TControl; Rect: TRect; DC: HDC);
var
  I, Count, X, Y, SaveIndex: Integer;
  R, SelfR, CtlR: TRect;
begin
  if Control.Parent = nil then
    Exit;
  Count := Control.Parent.ControlCount;
  SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
  //  OffsetRect( Rect, Control.Left, Control.Top );
  IntersectRect(SelfR, SelfR, Rect);

  X := -Rect.Left;
  Y := -Rect.Top;
  { Copy parent control image }
  SaveIndex := SaveDC(DC);
  SetViewportOrgEx(DC, X, Y, nil);
  IntersectClipRect(DC, 0, 0, Rect.Right, Rect.Bottom);
  TJvgPublicWinControl(Control.Parent).PaintWindow(DC);
  RestoreDC(DC, SaveIndex);
  { Copy images of graphic controls }
  for I := 0 to Count - 1 do
  begin
    if (Control.Parent.Controls[I] <> nil) and
      not (Control.Parent.Controls[I] is TWinControl) then
    begin
      if Control.Parent.Controls[I] = Control then
        Break;
      with Control.Parent.Controls[I] do
      begin
        CtlR := Bounds(Left, Top, Width, Height);
        if IntersectRect(R, SelfR, CtlR) and Visible then
        begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_PAINT, Longint(DC), 0);
          RestoreDC(DC, SaveIndex);
        end;
      end;
    end;
  end;
end;

{-create a rotated font based on the font object F}

function CreateRotatedFont(F: TFont; Escapement: Integer): HFONT;
var
  LF: TLogFont;
begin
  FillChar(LF, SizeOf(LF), #0);
  with LF do
  begin
    lfHeight := F.Height;
    //    lfWidth        := 8;//FHeight div 4;
    lfEscapement := Escapement;
    lfOrientation := 0;
    if fsBold in F.Style then
      lfWeight := FW_BOLD
    else
      lfWeight := FW_NORMAL;
    //    if FFontWeight     <> fwDONTCARE then lfWeight:=uFontWeight;
    lfItalic := Ord(fsItalic in F.Style);
    lfUnderline := Ord(fsUnderline in F.Style);
    lfStrikeOut := Ord(fsStrikeOut in F.Style);
    lfCharSet := F.CHARSET;
    StrPCopy(lfFaceName, F.Name);
    lfQuality := DEFAULT_QUALITY;
    {everything else as default}
    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;

{ Returns main window of application }

function FindMainWindow(const AWndClass, AWndTitle: string): HWND;
begin
  Result := 0;
  if (AWndClass <> '') or (AWndTitle <> '') then
    Result := FindWindow(PChar(AWndClass), PChar(AWndTitle));
end;

{ Calculates colors of shadow and lighted border for given base color. }

procedure CalcShadowAndHighlightColors(BaseColor: TColor; Colors: TJvgLabelColors);
var
  R, G, B: Byte;
begin
  with Colors do
  begin
    if (BaseColor and $80000000) <> 0 then
      BaseColor := GetSysColor(BaseColor and $FF);
    B := (BaseColor and $00FF0000) shr 16;
    G := (BaseColor and $0000FF00) shr 8;
    R := BaseColor and $000000FF;
    if AutoShadow then
    begin
      {if R<G then limit:=R else limit:=G; if B<limit then limit:=B;//...Min
      if limit<FColorShadowShift then FColorShadowShift:=limit;
      FShadow := RGB(R-FColorShadowShift,G-FColorShadowShift,B-FColorShadowShift);}
      Shadow := RGB(Max(R - ColorShadowShift, 0), Max(G - ColorShadowShift, 0), Max(B - ColorShadowShift, 0));
    end;
    if AutoHighlight then
    begin
      {if R>G then limit:=R else limit:=G; if B>limit then limit:=B;//...Max
      if (255-limit)<FColorHighlightShift then FColorHighlightShift:=255-limit;
      FHighlight := RGB(R+FColorHighlightShift,G+FColorHighlightShift,B+FColorHighlightShift);}
      Highlight := RGB(Min(R + ColorHighlightShift, 255), Min(G + ColorHighlightShift, 255), Min(B +
        ColorHighlightShift, 255));
    end;
  end;
end;

{ Calculates arithmetic expression, given in string }

function CalcMathString(AExpression: string): Single;
var
  ExpressionPtr, ExpressionLength, BracketsCount: Integer;
  CalcResult: Boolean;
  CurrChar: Char;

  function Expression: Single; forward;

  procedure NextChar;
  begin
    Inc(ExpressionPtr);
    if ExpressionPtr <= ExpressionLength then
      CurrChar := AExpression[ExpressionPtr]
    else
      CurrChar := #0;
    if CurrChar = ' ' then
      NextChar;
    if CurrChar = #0 then
      Exit;
    if not (CurrChar in ['0'..'9', ',', '.', '-', '+', '/', '*', '(', ')']) then
      NextChar;
  end;

  function DigitsToValue: Single;
  var
    PointDepth: Integer;
    Point: Boolean;
  begin
    Result := 0;
    Point := False;
    PointDepth := 0;
    while CurrChar = ' ' do
      NextChar;

    if (CurrChar >= '0') and (CurrChar <= '9') then
    begin
      while (CurrChar >= '0') and (CurrChar <= '9') do
      begin
        Result := Result * 10 + Ord(CurrChar) - Ord('0');
        NextChar;
        if Point then
          Inc(PointDepth);
        if (CurrChar = '.') or (CurrChar = ',') then
        begin
          NextChar;
          Point := True;
        end;
      end;