jvglabel.pas

East make Tray Icon in delphi

    Self.Font.Name := 'Arial';
  AutoSize := True;
  //  FRunOnce:=False;
  //  FActiveNow := False;

  FDirection := fldLeftRight;
  FFontWeight := fwDONTCARE;
  //  FSupressPaint := False;
  FUFontWeight := Word(fwDONTCARE);
  //  FNeedUpdateOnlyMainText:=False;
  FGradient.OnChanged := OnGradientChanged;
  FIllumination.OnChanged := OnIlluminationChanged;
  TextStyles.OnChanged := OnIlluminationChanged;
  Colors.OnChanged := OnIlluminationChanged;
  FOptions := [floActiveWhileControlFocused];
  FTargetCanvas := Canvas;
  FTransparent := True;
  Width := 100;
  Height := 16;
end;

destructor TJvgLabel.Destroy;
begin
  TextStyles.Free;
  Colors.Free;
  Gradient.Free;
  FIllumination.Free;
  FTexture.Free;
  FBackground.Free;
  FTextureMask.Free;
  FImg.Free;
  inherited Destroy;
  DeleteObject(FreeFont.Handle);
  FreeFont.Free;
end;

procedure TJvgLabel.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = BackgroundImage) and (Operation = opRemove) then
    BackgroundImage := nil
  else
  if (AComponent = TextureImage) and (Operation = opRemove) then
    TextureImage := nil;
end;

{$IFDEF USEJVCL}

procedure TJvgLabel.FontChanged;
begin
  inherited FontChanged;
  CreateLabelFont;
  Invalidate;
end;

procedure TJvgLabel.MouseEnter(Control: TControl);
begin
  if csDesigning in ComponentState then
    Exit;

  if not Enabled or (floIgnoreMouse in Options) or
     FShowAsActiveWhileControlFocused then
    Exit;
  //inherited;
  FActiveNow := True;
  with TextStyles, Colors do
    if (Passive <> Active) or
      ((Background <> BackgroundActive) and not Transparent) then
    begin
      if floBufferedDraw in Options then
        Repaint
      else
        InvalidateLabel(True);
    end
    else
    if (floDelineatedText in Options) and (DelineateActive <> Delineate) then
      Repaint
    else
    if TextActive <> Text then
    begin
      FNeedUpdateOnlyMainText := True;
      Repaint;
    end;
  inherited MouseEnter(Control);
end;

procedure TJvgLabel.MouseLeave(Control: TControl);
begin
  if csDesigning in ComponentState then
    Exit;
  if not Enabled or (floIgnoreMouse in Options) or
    FShowAsActiveWhileControlFocused then
    Exit;
  //inherited;
  FActiveNow := False;
  with TextStyles, Colors do
    if (Passive <> Active) or
      ((Background <> BackgroundActive) and not Transparent) then
    begin
      if floBufferedDraw in Options then
        Repaint
      else
        InvalidateLabel(True);
    end
    else
    if (floDelineatedText in Options) and (DelineateActive <> Delineate) then
      Repaint
    else
    if TextActive <> Text then
    begin
      FNeedUpdateOnlyMainText := True;
      Repaint;
    end;
  inherited MouseLeave(Control);
end;

{$ENDIF USEJVCL}

procedure TJvgLabel.Loaded;
begin
  inherited Loaded;
  if FTexture <> nil then
    FTextureBmp := FTexture
  else
  if Assigned(FTextureImage) then
    FTextureBmp := FTextureImage.Picture.Bitmap
  else
    FTextureBmp := nil;
  if Assigned(FBackground) then
    FBackgroundBmp := FBackground
  else
  if Assigned(FBackgroundImage) then
    FBackgroundBmp := FBackgroundImage.Picture.Bitmap
  else
    FBackgroundBmp := nil;
end;

procedure TJvgLabel.Paint;
var
  R: TRect;
  X, Y, X1, Y1, TX, TY: Integer;
  Size, TextSize: TSize;
  FontColor: TColor;
  CurrTextStyle: TglTextStyle;
  CurrDelinColor: TColor;
  OldGradientFActive, LUseBackgroundBmp, LUseTextureBmp, LBufferedDraw: Boolean;
begin
  inherited Paint;
  if FSupressPaint or (Length(Caption) = 0) then
    Exit;
  if floTransparentFont in Options then
    LBufferedDraw := True
  else
    LBufferedDraw := (floBufferedDraw in Options) and
      not (csDesigning in ComponentState);
  if LBufferedDraw then
    FTargetCanvas := FImg.Canvas
  else
  if Assigned(ExternalCanvas) then
    FTargetCanvas := ExternalCanvas
  else
    FTargetCanvas := Canvas;
  FNeedUpdateOnlyMainText := FNeedUpdateOnlyMainText and not LBufferedDraw and
    (not IsItAFilledBitmap(FBackgroundBmp));
  if not FRunOnce then
  begin
    FNeedUpdateOnlyMainText := False;
    FRunOnce := True;
  end;
  FTargetCanvas.Font := FreeFont;
  //...CALC POSITION
  GetTextExtentPoint32(FTargetCanvas.Handle, PChar(Caption), Length(Caption), Size);
  with TextStyles, Colors do
    if FActiveNow then
    begin
      CurrTextStyle := Active;
      CurrDelinColor := DelineateActive;
      FontColor := TextActive;
    end
    else
    if Enabled then
    begin
      CurrTextStyle := Passive;
      CurrDelinColor := Delineate;
      FontColor := Text;
    end
    else
    begin
      CurrTextStyle := Disabled;
      CurrDelinColor := Delineate;
      FontColor := TextDisabled;
    end;
  X := 0;
  Y := 0;
  Size.cx := Size.cx + 2 + Trunc(Size.cx * 0.01);
  //  Size.cy:=Size.cy+Trunc(Size.cy*0.1);
  Size.cy := Size.cy + 2;
  TextSize := Size;
  if (CurrTextStyle = fstShadow) or (CurrTextStyle = fstVolumetric) then
  begin
    Inc(Size.cy, Illumination.ShadowDepth);
    Inc(Size.cx, Illumination.ShadowDepth);
  end;
  if floDelineatedText in Options then
  begin
    Inc(Size.cy, 2);
    Inc(Size.cx, 2);
  end;

  if (Align = alNone) and AutoSize then
    case FDirection of
      fldLeftRight, fldRightLeft:
        begin
          Width := Size.cx;
          Height := Size.cy;
        end;
    else {fldDownUp,fldUpDown:}
      begin
        Width := Size.cy;
        Height := Size.cx;
      end;
    end;

  //  pt := CalcAlignedTextPosition( FTargetCanvas.Handle, Caption, Size );
  //  X := pt.X; Y := pt.Y;
  //CalcAlignedTextPosition( FTargetCanvas.Handle, Caption, Size );

  case FDirection of
    fldLeftRight:
      begin //if Align = alNone then begin Width:=Max(w,Size.cx);Height:=Max(h,Size.cy); end;
        case Alignment of
          taCenter:
            X := (Width - Size.cx) div 2;
          taRightJustify:
            X := Width - Size.cx;
        end;
      end;
    fldRightLeft:
      begin //if Align = alNone then begin Width:=Max(w,Size.cx);Height:=Max(h,Size.cy);X:=Width;Y:=Height; end;
        case Alignment of
          taCenter:
            X := (Width + Size.cx) div 2;
          taLeftJustify:
            X := Width - (Size.cx - TextSize.cx) - 2;
        else
          X := TextSize.cx;
        end;
        Y := TextSize.cy;
      end;
    fldDownUp:
      begin //if Align = alNone then begin Height:=Max(h,Size.cx);Width:=Max(w,Size.cy);Y:=Height-2; end;
        case Alignment of
          taCenter:
            Y := (Height + TextSize.cx - (Size.cy - TextSize.cy)) div 2;
          taRightJustify:
            Y := TextSize.cx - 4;
        else
          Y := Height - (Size.cy - TextSize.cy) - 2;
        end;
      end;
    fldUpDown:
      begin //if Align = alNone then begin Height:=Max(h,Size.cx);Width:=Max(w,Size.cy);X:=Width; end;
        case Alignment of
          taCenter:
            Y := (Height - Size.cx) div 2;
          taRightJustify:
            Y := Height - Size.cx;
        else
          Y := 1;
        end;
        X := TextSize.cy;
      end;
  end;

  //...CALC POSITION end

  R := GetClientRect;
  if FTargetCanvas = FImg.Canvas then
  begin
    FImg.Width := Width;
    FImg.Height := Height;
  end;

  SetBkMode(FTargetCanvas.Handle, Windows.TRANSPARENT);
  if not Transparent then
  begin
    FTargetCanvas.Brush.Style := bsSolid;
    if FActiveNow then
      FTargetCanvas.Brush.Color := Colors.BackgroundActive
    else
      FTargetCanvas.Brush.Color := Colors.Background;
    FTargetCanvas.FillRect(R);
  end;

  try
    LUseBackgroundBmp := IsItAFilledBitmap(FBackgroundBmp);
  except
    //  raise;
    LUseBackgroundBmp := False;
    FBackgroundBmp := nil;
    FBackgroundImage := nil;
  end;

  try
    LUseTextureBmp := IsItAFilledBitmap(FTextureBmp);
  except
    LUseTextureBmp := False;
    FTextureBmp := nil;
    FTextureImage := nil;
  end;

  //  ShadowColor_ := Colors.Shadow;
  //  HighlightColor_ := Colors.Highlight;
  if LUseBackgroundBmp then
  begin //...FillBackground
    TX := 0;
    TY := 0;
    while TX < Width do
    begin
      while TY < Height do
      begin
        BitBlt(FTargetCanvas.Handle, TX, TY,
          FBackgroundBmp.Width, FBackgroundBmp.Height,
          FBackgroundBmp.Canvas.Handle, 0, 0, SRCCOPY);
        Inc(TY, FBackgroundBmp.Height);
      end;
      Inc(TX, FBackgroundBmp.Width);
      TY := 0;
    end;
  end
  else
  if LBufferedDraw then
    with FTargetCanvas do
    begin
      if Transparent or (floTransparentFont in Options) then
      try
        Brush.Color := Parent.Brush.Color;
        Brush.Style := bsSolid;
        FillRect(R);
        Brush.Style := bsClear;
        GetParentImageRect(Self, Bounds(Left, Top, Width, Height),
          FTargetCanvas.Handle);
      except
      end;
    end;

  OldGradientFActive := Gradient.Active;
  //...Supress Gradient if needed
  with Colors do
    if (FActiveNow and (TextActive <> Text)) or not Enabled then
      Gradient.Active := False;
  if floDelineatedText in Options then
  begin
    X1 := 4;
    Y1 := 4;
  end
  else
  begin
    X1 := 2;
    Y1 := 2;
  end;

  if CurrTextStyle = fstNone then
  begin
    X1 := X1 div 2 - 1;
    Y1 := Y1 div 2 - 1;
  end;
  if CurrTextStyle = fstShadow then
  begin
    X1 := X1 div 2 - 1;
    Y1 := Y1 div 2 - 1;
  end;
  if {FNeedRemakeTextureMask and} LUseTextureBmp or
    (floTransparentFont in Options) then
  begin
    if not Assigned(FTextureMask) then
      FTextureMask := TBitmap.Create;
    with FTextureMask do
    begin
      Width := Self.Width;
      Height := Self.Height;
      Canvas.Brush.Color := clBlack;
      Canvas.Brush.Style := bsSolid;
      Canvas.FillRect(GetClientRect);
      Canvas.Font := FreeFont;
      Canvas.Font.Color := clWhite;
      if (CurrTextStyle = fstNone) or (CurrTextStyle = fstShadow) then
        Canvas.TextOut(X + X1, Y + Y1, Caption)
      else
        Canvas.TextOut(X + X1 div 2, Y + Y1 div 2, Caption);
      TX := 0;
      TY := 0;

      if not Self.Transparent then
      begin
        BitBlt(Canvas.Handle, TX, TY, Width, Height, FTargetCanvas.Handle, 0,
          0, SRCAND);
        if FActiveNow then
          ChangeBitmapColor(FTextureMask, clBlack, Colors.BackgroundActive)
        else
          ChangeBitmapColor(FTextureMask, clBlack, Colors.Background);
        BitBlt(Self.Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0,
          SRCCOPY);
        Exit;
      end;

      if floTransparentFont in Options then
        BitBlt(Canvas.Handle, TX, TY, Width, Height, FTargetCanvas.Handle, 0,
          0, SRCAND)
      else
      if LUseTextureBmp then //...fill mask with texture
        while TX < Width do
        begin
          while TY < Height do
          begin
            BitBlt(Canvas.Handle, TX, TY, FTextureBmp.Width,
              FTextureBmp.Height, FTextureBmp.Canvas.Handle, 0, 0, SRCAND);
            Inc(TY, FTextureBmp.Height);
          end;
          Inc(TX, FTextureBmp.Width);
          TY := 0;
        end;
    end;
  end;

  if IsItAFilledBitmap(FTextureBmp) then
    FontColor := 0;
  ExtTextOutExt(FTargetCanvas.Handle, X, Y, GetClientRect, Caption,
    CurrTextStyle, floDelineatedText in Options,
    FNeedUpdateOnlyMainText, FontColor, CurrDelinColor,
    Colors.Highlight, Colors.Shadow,
    Illumination, Gradient, FreeFont);

  //  SetBkMode( FTargetCanvas.Handle, iOldBkMode );
  FNeedUpdateOnlyMainText := False;
  Gradient.Active := OldGradientFActive;

  if (Assigned(FTextureBmp) or (floTransparentFont in Options)) and
    (CurrTextStyle <> fstPushed) then begin
      if Assigned(FTextureMask) then begin {fix access violation! WPostma.}
        BitBlt(FTargetCanvas.Handle, 0, 0, FTextureMask.Width, FTextureMask.Height,
      FTextureMask.Canvas.Handle, 0, 0, SRCPAINT);
      end;
    end;

  if FImg.Canvas = FTargetCanvas then
    BitBlt(Canvas.Handle, 0, 0, FImg.Width, FImg.Height,
      FTargetCanvas.Handle, 0, 0, SRCCOPY);

  //R:=Rect(Left,Top,Left+Width,Top+Height);
  //ValidateRect( Parent.Handle, @R );
end;

procedure TJvgLabel.CreateLabelFont;
begin
  if not FFirstCreate then
    DeleteObject(FreeFont.Handle);
  FreeFont.Handle := CreateRotatedFont(Font, RadianEscapments[FDirection]);
  FFirstCreate := False;
end;

procedure TJvgLabel.InvalidateLabel(UpdateBackgr: Boolean);
var
  R: TRect;
begin
  R := Bounds(Left, Top, Width, Height);
  if not (csDestroying in ComponentState) then
    InvalidateRect(Parent.Handle, @R, UpdateBackgr);
end;

procedure TJvgLabel.OnGradientChanged(Sender: TObject);
begin
  FNeedUpdateOnlyMainText := True;
  Repaint;
  //InvalidateLabel(False);
end;

procedure TJvgLabel.OnIlluminationChanged(Sender: TObject);
begin