aquihelpers.pas

AutomatedDocking Library 控件源代码修改 适合Delphi 2009 和C++ Builder 20009 使用。 修正汉字不能正确显示问题

end;

function DarkDarkColor(AColor: TColor): TColorRef;
begin
  Result := DarkColorBy(AColor, 20);
end;

function NETBackColor(AColor: TColor): TColorRef;
const
  D                                                         = $23;
var
  R, G, B, M                                                : Integer;
begin
  Result := ColorToRGB(AColor);
  R := GetRValue(Result);
  G := GetGValue(Result);
  B := GetBValue(Result);
  M := Min((255 - (Max(Max(R, G), B) + D)), 0) + D;
  Result := rgb(R + M, G + M, B + M);
end;

function GetComplexColor(AColor1, AColor2, AColor3: TColor; APercentage1,
  APercentage2, APercentage3: Integer): TColorRef;

  function CalcValue(AValue1, AValue2, AValue3: Byte): Integer;
  begin
    Result :=
      MulDiv(AValue1, APercentage1, 100) +
      MulDiv(AValue2, APercentage2, 100) +
      MulDiv(AValue3, APercentage3, 100);
    if Result < 0 then Result := 0;
    if Result > 255 then Result := 255;
  end;

var
  FirstColor, SecondColor, ThirdColor                       : TColorRef;
begin
  FirstColor := ColorToRGB(AColor1);
  SecondColor := ColorToRGB(AColor2);
  ThirdColor := ColorToRGB(AColor3);
  Result := rgb(CalcValue(GetRValue(FirstColor), GetRValue(SecondColor), GetRValue(ThirdColor)),
    CalcValue(GetGValue(FirstColor), GetGValue(SecondColor), GetGValue(ThirdColor)),
    CalcValue(GetBValue(FirstColor), GetBValue(SecondColor), GetBValue(ThirdColor)));
end;

function GetComplexColor(AColor1, AColor2: TColor; APercentage: Integer): TColorRef;

  function CalcValue(AValue1, AValue2: Byte): Integer;
  begin
    Result := AValue1 + MulDiv(AValue2 - AValue1, APercentage, 100);
    if Result < 0 then Result := 0;
    if Result > 255 then Result := 255;
  end;

var
  FirstColor, SecondColor                                   : TColorRef;
begin
  FirstColor := ColorToRGB(AColor1);
  SecondColor := ColorToRGB(AColor2);
  Result := rgb(CalcValue(GetRValue(FirstColor), GetRValue(SecondColor)),
    CalcValue(GetGValue(FirstColor), GetGValue(SecondColor)),
    CalcValue(GetBValue(FirstColor), GetBValue(SecondColor)));
end;

{$IFDEF VCL}

function SubtractRect(out ARect: TRect; const R1, R2: TRect): Boolean;
begin
  Result := Windows.SubtractRect(ARect, R1, R2);
end;
{$ELSE}

function SubtractRect(out ARect: TRect; const R1, R2: TRect): Boolean;
var
  ret                                                       : TRect;
begin
  Result := True;
  if (R2.Left <= R1.Left) and (R1.Right <= R2.Right) and (R2.Top <= R1.Top)
    and (R1.Bottom <= R2.Bottom) then
  begin
    ARect := Types.Rect(0, 0, 0, 0);
    Exit;
  end;

  ret := R1;

  if (R2.Top <= ret.Top) and (ret.Bottom <= R2.Bottom) then
  begin
    if (R2.Right < ret.Left) or (ret.Right < R2.Left) then
    begin
      ARect := ret;
      Exit;
    end;

    if (ret.Left < R2.Left) and (R2.Right < ret.Right) then
    begin
      ARect := ret;
      Exit;
    end;

    if (R2.Right < ret.Right) then
      ret.Left := R2.Right;

    if (ret.Left < R2.Left) then
      ret.Right := R2.Left;

  end
  else
    if (R2.Left <= ret.Left) and (ret.Right <= R2.Right) then
    begin
      if (R2.Bottom < ret.Top) or (ret.Bottom < R2.Top) then
      begin
        ARect := ret;
        Exit;
      end;

      if (ret.Top < R2.Top) and (R2.Bottom < ret.Bottom) then
      begin
        ARect := ret;
        Exit;
      end;

      if (R2.Bottom < ret.Bottom) then
        ret.Top := R2.Bottom;

      if (ret.Top < R2.Top) then
        ret.Bottom := R2.Top;
    end;
  ARect := ret;
end;
{$ENDIF}

{$IFDEF VCL}

procedure OutTextRect(ACanvas: TCanvas; ARect: TRect; AIndentX, AIndentY: Integer;
  const AText: string; AVertAlign: TTextLayout; AHorAlign: TAlignment;
  ARotate, AWordWrap: Boolean; AShowAccelChar: TaqShowAccelChar);

  procedure DoDrawText(Handle: TaqHandle; ARect: TRect);
  const
    Alignments                                              : array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);
    WordWraps                                               : array[Boolean] of Cardinal = (0, DT_WORDBREAK);
    ShowAccelFlags                                          : array[TaqShowAccelChar] of Cardinal = (0, DT_NOPREFIX, DT_HIDEPREFIX);
  var
    DrawStyle                                               : Cardinal;
    CalcRect                                                : TRect;
  begin
    DrawStyle := Alignments[AHorAlign] or WordWraps[AWordWrap] or
      ShowAccelFlags[AShowAccelChar] or DT_EXPANDTABS;

    if AVertAlign <> tlTop then
    begin
      CalcRect := Rect(0, 0, ARect.Right - ARect.Left, 0);
      DrawText(Handle, PChar(AText), Length(AText), CalcRect, DrawStyle or DT_CALCRECT);
      if AVertAlign = tlBottom then
        OffsetRect(ARect, 0, ARect.Bottom - ARect.Top - CalcRect.Bottom)
      else
        OffsetRect(ARect, 0, (ARect.Bottom - ARect.Top - CalcRect.Bottom) div 2);
    end;
    DrawText(Handle, PChar(AText), Length(AText), ARect, DrawStyle);
  end;

  function TryWorldTransform: Boolean;
  var
    OldMode                                                 : Integer;
    XForm, OldXForm                                         : TXForm;
  begin
    Result := False;
    OldMode := SetGraphicsMode(ACanvas.Handle, GM_ADVANCED);
    if OldMode <> 0 then
    begin
      FillChar(XForm, SizeOf(XForm), 0);
      if (@aqUIHelpers.GetWorldTransform <> nil)
        and aqUIHelpers.GetWorldTransform(ACanvas.Handle, OldXForm) then
      begin
        XForm.eM11 := 0;
        XForm.eM12 := 1;
        XForm.eM21 := -1;
        XForm.eM22 := 0;
        XForm.eDx := ARect.Top + ARect.Right;
        XForm.eDy := ARect.Top - ARect.Left;
        if aqUIHelpers.SetWorldTransform(ACanvas.Handle, XForm) then
        begin
          DoDrawText(ACanvas.Handle,
            Rect(ARect.Left, ARect.Top, ARect.Left + ARect.Bottom - ARect.Top, ARect.Top + ARect.Right - ARect.Left));

          aqUIHelpers.SetWorldTransform(ACanvas.Handle, OldXForm);
          SetGraphicsMode(ACanvas.Handle, OldMode);
          Result := True;
        end;
      end;
    end;
  end;

  procedure DoPixelTransform;
  var
    Bmp                                                     : TBitmap;
    R                                                       : TRect;
  begin
    Bmp := Graphics.TBitmap.Create;
    Bmp.Width := ARect.Bottom - ARect.Top;
    Bmp.Height := ARect.Right - ARect.Left;
    R := Rect(0, 0, Bmp.Width, Bmp.Height);
    Bmp.Canvas.Brush.Style := bsSolid;
    Bmp.Canvas.Brush.Color := clFuchsia;
    Bmp.Canvas.FillRect(R);
    Bmp.Canvas.Brush.Assign(ACanvas.Brush);
    Bmp.Canvas.Pen.Assign(ACanvas.Pen);
    DoDrawText(Bmp.Canvas.Handle, R);
    Bmp.TransparentColor := clFuchsia;
    Bmp.Transparent := True;
    DrawImageEx(Bmp, ACanvas, ARect, orLeft, aqNullHandle);
    Bmp.Free;
  end;

begin
  Inc(ARect.Right);
  Inc(ARect.Bottom);
  case AVertAlign of
    tlTop: Inc(ARect.Top, AIndentY);
    tlBottom: Dec(ARect.Bottom, AIndentY);
  end;
  case AHorAlign of
    taLeftJustify: Inc(ARect.Left, AIndentX);
    taRightJustify: Dec(ARect.Right, AIndentX);
  end;

  if ARotate then
  begin
    if not TryWorldTransform then
      DoPixelTransform;
  end
  else
    DoDrawText(ACanvas.Handle, ARect);
end;
{$ELSE}

procedure OutTextRect(ACanvas: TCanvas; ARect: TRect; AIndentX, AIndentY: Integer;
  const AText: string; AVertAlign: TTextLayout; AHorAlign: TAlignment;
  ARotate, AWordWrap: Boolean; AShowAccelChar: TaqShowAccelChar);
var
  x, y                                                      : Integer;
begin
  // TODO: ARotate, AShowAccelChar
  x := 0;
  y := 0;
  with ARect do
  begin
    case AVertAlign of
      tlTop: y := Top + AIndentY;
      tlCenter: y := Top + (Bottom - Top + 1 - ACanvas.TextHeight(AText)) div 2;
      tlBottom: y := Bottom - AIndentY - ACanvas.TextHeight(AText);
    end;
    case AHorAlign of
      taLeftJustify: x := Left + AIndentX;
      taCenter: x := Left + (Right - Left + 1 - ACanvas.TextWidth(AText)) div 2;
      taRightJustify: x := Right - AIndentX - ACanvas.TextWidth(AText);
    end;
  end;
  ACanvas.TextRect(ARect, x, y, AText);
end;
{$ENDIF}

function MinimizeText(const AText: string; ACanvas: TCanvas;
  AMaxWidth: Integer; AShowAccelChar: TaqShowAccelChar; out ADest: string): Boolean;
// Returns true if AText was not changed to fit the MaxWidth size.
const
  CEndEllipsis                                              = '...';
var
  I, L                                                      : Integer;
  s                                                         : string;
begin
  ADest := AText;
  if AShowAccelChar <> sacFalse then
    s := StripHotKey(AText);
  I := 1;
  L := Length(AText);
  while (I < L - 1) and (ACanvas.TextWidth(s) > AMaxWidth) do
  begin
    Inc(I);
    ADest := Copy(AText, 1, L - I) + CEndEllipsis;
    if AShowAccelChar <> sacFalse then
      s := StripHotKey(ADest);
  end;
  Result := I = 1;
  if s = CEndEllipsis then
    ADest := s;
end;

{$IFDEF VCL}

function TextMetrics(AFont: TFont; const AText: string): TPoint;
var
  Size                                                      : TSize;
  Handle                                                    : THandle;
  SaveFont                                                  : THandle;
begin
  Result := Point(0, 0);
  Handle := CreateCompatibleDc(0);
  SaveFont := SelectObject(Handle, AFont.Handle);
  Windows.GetTextExtentPoint32(Handle, PChar(AText), Length(AText), Size);
  Result.x := Size.cx;
  Result.y := Size.cy;
  SelectObject(Handle, SaveFont);
  DeleteDC(Handle);
end;
{$ELSE}

function TextMetrics(AFont: TFont; const AText: string): TPoint;
var
  Canvas                                                    : TCanvas;
  Bmp                                                       : TBitmap;
  Size                                                      : TSize;
begin
  Result := Point(0, 0);
  Bmp := TBitmap.Create;
  Bmp.Width := 1;
  Bmp.Height := 1;
  Canvas := TBitmapCanvas.Create(Bmp);
  try
    Canvas.Font := AFont;
    Size := Canvas.TextExtent(AText);
    Result.x := Size.cx;
    Result.y := Size.cy;
  finally
    Canvas.Free;
    Bmp.Free;
  end;
end;
{$ENDIF}

{$IFNDEF VCL}

function rgb(Red, Green, Blue: Byte): TColorRef;
begin
  Result := (Red and $FF) or ((Green and $FF) shl 8) or ((Blue and $FF) shl 16);
end;

function GetRValue(rgb: Cardinal): Byte;
begin
  Result := Byte(rgb and $FF);
end;

function GetGValue(rgb: Cardinal): Byte;
begin
  Result := Byte((rgb shr 8) and $FF);
end;

function GetBValue(rgb: Cardinal): Byte;
begin
  Result := Byte((rgb shr 16) and $FF);
end;
{$ENDIF}

procedure DrawImage(AImages: TCustomImageList; AImageIndex: Integer;
  ACanvas: TCanvas; ARect: TRect; AEnabled: Boolean = True;
  AStyle: TaqImageDrawStyle = idsStretch);
var
  Bmp                                                       : TBitmap;
  {$IFDEF VCL}
  Mask                                                      : TBitmap;
  {$ELSE}
  Mask                                                      : QBitmapH;
  {$ENDIF}
begin
  if AStyle = idsStretch then
  begin
    Bmp := TBitmap.Create;
    Bmp.Width := AImages.Width;
    Bmp.Height := AImages.Height;
    Bmp.Canvas.Refresh;
    {$IFDEF VCL}
    Bmp.Transparent := True;
    Mask := TBitmap.Create;

    AImages.ImageType := itMask;
    AImages.GetBitmap(AImageIndex, Mask);
    AImages.ImageType := itImage;

    AImages.Draw(Bmp.Canvas, 0, 0, AImageIndex, dsNormal, itImage, AEnabled);

    Bmp.MaskHandle := Mask.Handle;
    {$ELSE}
    Mask := AImages.GetMask(AImageIndex);

    AImages.Draw(Bmp.Canvas, 0, 0, AImageIndex, itImage, AEnabled);

    QPixmap_setMask(Bmp.Handle, Mask);
    {$ENDIF}
    ACanvas.StretchDraw(ARect, Bmp);
    {$IFDEF VCL}
    Mask.Free;
    {$ENDIF}
    Bmp.Free;
  end
  else
  begin
    if AStyle = idsCenter then
      OffsetRect(ARect, ((ARect.Right - ARect.Left) - AImages.Width) div 2,
        ((ARect.Bottom - ARect.Top) - AImages.Height) div 2);

    AImages.Draw(ACanvas, ARect.Left, ARect.Top, AImageIndex,
      {$IFDEF VCL}AImages.DrawingStyle, {$ENDIF}
      itImage, AEnabled)
  end;
end;

procedure DrawImageEx(AImage: Graphics.TBitmap; ACanvas: TCanvas;
  ARect: TRect; AOrientation: TaqOrientation; Region: TaqHandle);

  function TransformRegion(XForm: PXForm; Region: TaqHandle): TaqHandle;
  var
    Count                                                   : Cardinal;
    Data                                                    : PRgnData;
  begin
    Result := Region;
    Count := GetRegionData(Region, 0, nil);
    GetMem(Data, SizeOf(TRgnData) * Count);
    if GetRegionData(Region, Count, Data) = Count then
      Result := ExtCreateRegion(XForm, Count, Data^);
    FreeMem(Data);
  end;

  function TryWorldTransform: Boolean;
  var
    OldMode                                                 : Integer;
    XForm, OldXForm                                         : TXForm;
    NewRegion                                               : TaqHandle;
  begin
    Result := False;
    if AOrientation = orBottom then
    begin
      OldMode := SetGraphicsMode(ACanvas.Handle, GM_ADVANCED);
      if OldMode <> 0 then
      begin
        FillChar(XForm, SizeOf(XForm), 0);
        if (@aqUIHelpers.GetWorldTransform <> nil)
          and aqUIHelpers.GetWorldTransform(ACanvas.Handle, OldXForm) then
        begin
          XForm.eM11 := 1;
          XForm.eM22 := -1;
          XForm.eDy := ARect.Top + ARect.Bottom;
          if aqUIHelpers.SetWorldTransform(ACanvas.Handle, XForm) then
          begin
            if Region <> aqNullHandle then
            begin
              NewRegion := TransformRegion(@XForm, Region);
              OffsetRgn(NewRegion, 0, 1);
              SelectClipRgn(ACanvas.Handle, NewRegion);
            end
            else
              NewRegion := aqNullHandle;
            ACanvas.Draw(ARect.Left, ARect.Top, AImage);

            aqUIHelpers.SetWorldTransform(ACanvas.Handle, OldXForm);
            SetGraphicsMode(ACanvas.Handle, OldMode);
            if Region <> aqNullHandle then
            begin
              SelectClipRgn(ACanvas.Handle, 0);
              if Region <> NewRegion then
                DeleteObject(NewRegion);
            end;
            Result := True;
          end;
        end;
      end;
    end;
  end;

  procedure DoPixelTransform;
  var
    PDest, PDestStart                                       : ^DWord;
    PSource                                                 : ^DWord;
    PBuffer                                                 : Pointer;
    x, y, temp                                              : Integer;
    LineCopyingDirection                                    : Integer;
  begin
    AImage.PixelFormat := pf32bit;