aquihelpers.pas

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

    with AImage do
    begin
      case AOrientation of
        orBottom:
          begin
            GetMem(PBuffer, Width * 4);
            PDestStart := ScanLine[Height - 1];
            PDest := PDestStart;
            Integer(PSource) := Integer(PDest) + Height * Width * 4;
            for y := 0 to Height div 2 - 1 do
            begin
              Move(PDest^, PBuffer^, Width * 4);
              for x := 0 to Width - 1 do
              begin
                Dec(PSource);
                PDest^ := PSource^;
                Inc(PDest);
              end;

              PDest := Pointer(PSource);
              Integer(PSource) := Integer(PBuffer) + Width * 4;
              for x := 0 to Width - 1 do
              begin
                Dec(PSource);
                PDest^ := PSource^;
                Inc(PDest);
              end;

              Integer(PSource) := Integer(PDest) - Width * 4;
              Inc(PDestStart, Width);
              PDest := PDestStart;
            end;
            if Height mod 2 <> 0 then
              for x := 0 to Width div 2 - 1 do
              begin
                Dec(PSource);
                PDest^ := PSource^;
                Inc(PDest);
              end;

            Width := Width + 1;
            Width := Width - 1;
            FreeMem(PBuffer);
          end;
        orLeft, orRight:
          begin
            GetMem(PBuffer, Width * Height * 4);

            PDestStart := PBuffer;
            if AOrientation = orRight then
            begin
              Inc(PDestStart, Height * (Width - 1));
              LineCopyingDirection := 1;
            end
            else
            begin
              Inc(PDestStart, Height - 1);
              LineCopyingDirection := -1;
            end;

            PSource := ScanLine[0];
            for y := 0 to Height - 1 do
            begin
              PDest := PDestStart;
              for x := 0 to Width - 1 do
              begin
                PDest^ := PSource^;
                Dec(PDest, Height * LineCopyingDirection);
                Inc(PSource);
              end;
              Inc(PDestStart, LineCopyingDirection);
              Dec(PSource, Width * 2);
            end;

            temp := Width;
            Width := Height;
            Height := temp;
            if Width = Height then
            begin
              Width := Width + 1;
              Width := Width - 1;
            end;

            PSource := PBuffer;
            PDest := ScanLine[0];
            for y := 0 to Height - 1 do
            begin
              Move(PSource^, PDest^, Width * 4);
              Inc(PSource, Width);
              Dec(PDest, Width);
            end;

            FreeMem(PBuffer);
          end;
      end;
    end;
    ACanvas.Draw(ARect.Left, ARect.Top, AImage);
  end;

begin
  case AOrientation of
    orTop:
      begin
        if Region <> aqNullHandle then
          SelectClipRgn(ACanvas.Handle, Region);
        ACanvas.Draw(ARect.Left, ARect.Top, AImage);
        if Region <> aqNullHandle then
          SelectClipRgn(ACanvas.Handle, 0);
      end;
  else
    if not TryWorldTransform then
      DoPixelTransform;
  end;
end;

procedure aqProcessPaintMessages;
var
  Msg                                                       : TMsg;
begin
  while PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_NOREMOVE) do
  begin
    case Integer(GetMessage(Msg, 0, WM_PAINT, WM_PAINT)) of
      -1: Break;
      0:
        begin
          PostQuitMessage(Msg.wParam);
          Break;
        end;
    end;
    DispatchMessage(Msg);
  end;
end;

{ TGradient }

procedure TGradient.Assign(Source: TPersistent);
begin
  if Source is TGradient then
  begin
    BeginUpdate;
    with TGradient(Source) do
    try
      Self.EndColor := EndColor;
      Self.StartColor := StartColor;
      Self.FillType := FillType;
      Self.Bands := Bands;
    finally
      Self.EndUpdate;
    end;
  end
  else
    inherited;
end;

procedure TGradient.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TGradient.Change;
begin
  if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGradient.Clear;
begin
  FType := gtSolid;
  FStart := clBtnFace;
  FEnd := clWindow;
  FSteps := High(TBands);
end;

constructor TGradient.Create;
begin
  inherited;
  Clear;
end;

procedure TGradient.EndUpdate;
begin
  Dec(FUpdateCount);
  Assert(FUpdateCount >= 0);
  if FUpdateCount = 0 then Change;
end;

procedure TGradient.Fill(ACanvas: TCanvas; const ARect, AClip: TRect;
  ASwapColors: Boolean = False);
var
  I, j, RSize, RSize1, Steps, Steps1, Bound1, Bound2        : Integer;
  CBrush                                                    : array[0..2] of Byte;
  Band, Band1                                               : TRect;
  R                                                         : TRect;
begin
  SetColors(ASwapColors);
  ACanvas.Brush.Style := bsSolid;
  case FType of
    gtSolid:
      begin
        ACanvas.Brush.Color := rgb(FCStart[0], FCStart[1], FCStart[2]);
        IntersectRect(R, ARect, AClip);
        ACanvas.FillRect(R);
      end;
    gtHorizontal:
      begin
        Band.Top := Max(ARect.Top, AClip.Top);
        Band.Bottom := Min(ARect.Bottom, AClip.Bottom);
        Band.Left := ARect.Left;
        Band.Right := ARect.Left;
        Bound1 := Max(ARect.Left, AClip.Left);
        Bound2 := Min(ARect.Right, AClip.Right);
        RSize := ARect.Right - ARect.Left;
        if RSize > FSteps then
          Steps := FSteps
        else
          Steps := RSize;
        Steps1 := Steps - 1;
        for j := 0 to Steps1 do
        begin
          for I := 0 to 2 do
            CBrush[I] := FCStart[I] + MulDiv(j, FCDiff[I], Steps1);
          Band.Right := ARect.Left + MulDiv(RSize, j + 1, Steps);
          ACanvas.Brush.Color := rgb(CBrush[0], CBrush[1], CBrush[2]);
          if (Band.Right >= Bound1) and (Band.Left <= Bound2) then
            {$IFDEF VCL}
            PatBlt(ACanvas.Handle, Band.Left, Band.Top,
              Band.Right - Band.Left, Band.Bottom - Band.Top, PATCOPY);
          {$ELSE}
            ACanvas.FillRect(Band);
          {$ENDIF}
          Band.Left := Band.Right;
        end;
      end;
    gtHorzSplit:
      begin
        Band.Top := Max(ARect.Top, AClip.Top);
        Band.Bottom := Min(ARect.Bottom, AClip.Bottom);
        Band.Left := ARect.Left;
        Band.Right := ARect.Left;
        Band1.Top := Band.Top;
        Band1.Bottom := Band.Bottom;
        Band1.Left := ARect.Right;
        Band1.Right := ARect.Right;
        Bound1 := Max(ARect.Left, AClip.Left);
        Bound2 := Min(ARect.Right, AClip.Right);
        RSize := ARect.Right - ARect.Left;
        if RSize > FSteps then
          Steps := FSteps
        else
          Steps := RSize;
        RSize1 := RSize - (RSize div 2);
        RSize := RSize div 2;
        Steps1 := Steps - 1;
        for j := 0 to Steps1 do
        begin
          for I := 0 to 2 do
            CBrush[I] := FCStart[I] + MulDiv(j, FCDiff[I], Steps1);
          Band.Right := ARect.Left + MulDiv(RSize, j + 1, Steps);
          Band1.Left := ARect.Right - MulDiv(RSize1, j + 1, Steps);
          ACanvas.Brush.Color := rgb(CBrush[0], CBrush[1], CBrush[2]);
          if (Band.Right >= Bound1) and (Band.Left <= Bound2) then
            {$IFDEF VCL}
            PatBlt(ACanvas.Handle, Band.Left, Band.Top, Band.Right - Band.Left, Band.Bottom - Band.Top, PATCOPY);
          {$ELSE}
            ACanvas.FillRect(Band);
          {$ENDIF}
          if (Band1.Right >= Bound1) and (Band1.Left <= Bound2) then
            {$IFDEF VCL}
            PatBlt(ACanvas.Handle, Band1.Left, Band1.Top, Band1.Right - Band1.Left, Band1.Bottom - Band1.Top, PATCOPY);
          {$ELSE}
            ACanvas.FillRect(Band1);
          {$ENDIF}
          Band.Left := Band.Right;
          Band1.Right := Band1.Left;
        end;
      end;
    gtVertical:
      begin
        Band.Top := ARect.Top;
        Band.Bottom := ARect.Top;
        Band.Left := Max(ARect.Left, AClip.Left);
        Band.Right := Min(ARect.Right, AClip.Right);
        Bound1 := Max(ARect.Top, AClip.Top);
        Bound2 := Min(ARect.Bottom, AClip.Bottom);
        RSize := ARect.Bottom - ARect.Top;
        if RSize > FSteps then
          Steps := FSteps
        else
          Steps := RSize;
        Steps1 := Steps - 1;
        for j := 0 to Steps1 do
        begin
          for I := 0 to 2 do
            CBrush[I] := FCStart[I] + MulDiv(j, FCDiff[I], Steps1);
          Band.Bottom := ARect.Top + MulDiv(RSize, j + 1, Steps);
          ACanvas.Brush.Color := rgb(CBrush[0], CBrush[1], CBrush[2]);
          if (Band.Bottom >= Bound1) and (Band.Top <= Bound2) then
            {$IFDEF VCL}
            PatBlt(ACanvas.Handle, Band.Left, Band.Top, Band.Right - Band.Left,
              Band.Bottom - Band.Top, PATCOPY);
          {$ELSE}
            ACanvas.FillRect(Band);
          {$ENDIF}
          Band.Top := Band.Bottom;
        end;
      end;
    gtVertSplit:
      begin
        Band.Top := ARect.Top;
        Band.Bottom := ARect.Top;
        Band.Left := Max(ARect.Left, AClip.Left);
        Band.Right := Min(ARect.Right, AClip.Right);
        Band1.Top := ARect.Bottom;
        Band1.Bottom := ARect.Bottom;
        Band1.Left := Band.Left;
        Band1.Right := Band.Right;
        Bound1 := Max(ARect.Top, AClip.Top);
        Bound2 := Min(ARect.Bottom, AClip.Bottom);
        RSize := ARect.Bottom - ARect.Top;
        if RSize > FSteps then
          Steps := FSteps
        else
          Steps := RSize;
        RSize1 := RSize - (RSize div 2);
        RSize := RSize div 2;
        Steps1 := Steps - 1;
        for j := 0 to Steps1 do
        begin
          for I := 0 to 2 do
            CBrush[I] := FCStart[I] + MulDiv(j, FCDiff[I], Steps1);
          Band.Bottom := ARect.Top + MulDiv(RSize, j + 1, Steps);
          Band1.Top := ARect.Bottom - MulDiv(RSize1, j + 1, Steps);
          ACanvas.Brush.Color := rgb(CBrush[0], CBrush[1], CBrush[2]);
          if (Band.Bottom >= Bound1) and (Band.Top <= Bound2) then
            {$IFDEF VCL}
            PatBlt(ACanvas.Handle, Band.Left, Band.Top,
              Band.Right - Band.Left, Band.Bottom - Band.Top, PATCOPY);
          {$ELSE}
            ACanvas.FillRect(Band);
          {$ENDIF}
          if (Band1.Bottom >= Bound1) and (Band1.Top <= Bound2) then
            {$IFDEF VCL}
            PatBlt(ACanvas.Handle, Band1.Left, Band1.Top,
              Band1.Right - Band1.Left, Band1.Bottom - Band1.Top, PATCOPY);
          {$ELSE}
            ACanvas.FillRect(Band1);
          {$ENDIF}
          Band.Top := Band.Bottom;
          Band1.Bottom := Band1.Top;
        end;
      end;
  end;
end;

procedure TGradient.SetColors;
var
  I                                                         : Integer;
  ARGB                                                      : Cardinal;
  CEnd                                                      : array[0..2] of Byte;
begin
  if SwapColors then
    ARGB := Cardinal(ColorToRGB(FEnd))
  else
    ARGB := Cardinal(ColorToRGB(FStart));
  FCStart[0] := GetRValue(ARGB);
  FCStart[1] := GetGValue(ARGB);
  FCStart[2] := GetBValue(ARGB);
  if SwapColors then
    ARGB := Cardinal(ColorToRGB(FStart))
  else
    ARGB := Cardinal(ColorToRGB(FEnd));
  CEnd[0] := GetRValue(ARGB);
  CEnd[1] := GetGValue(ARGB);
  CEnd[2] := GetBValue(ARGB);
  for I := 0 to 2 do
    FCDiff[I] := CEnd[I] - FCStart[I];
end;

procedure TGradient.SetEnd(Value: TColor);
begin
  if FEnd <> Value then
  begin
    FEnd := Value;
    if FType <> gtSolid then Change;
  end;
end;

procedure TGradient.SetStart(Value: TColor);
begin
  if FStart <> Value then
  begin
    FStart := Value;
    Change;
  end;
end;

procedure TGradient.SetSteps(Value: TBands);
begin
  if FSteps <> Value then
  begin
    FSteps := Value;
    if FType <> gtSolid then Change;
  end;
end;

procedure TGradient.SetType(Value: TGradientType);
begin
  if FType <> Value then
  begin
    FType := Value;
    Change;
  end;
end;

{$IFDEF VCL}
{ TaqThemeNotifier }

constructor TaqThemeNotifier.Create;
begin
  inherited;
  FHandle := Classes.AllocateHWnd(MainWndProc);
end;

destructor TaqThemeNotifier.Destroy;
begin
  Classes.DeallocateHWnd(FHandle);
  inherited;
end;

procedure TaqThemeNotifier.DoThemeChange;
begin
  if Assigned(FOnThemeChange) then FOnThemeChange(Self);
end;

procedure TaqThemeNotifier.MainWndProc(var Message: TMessage);
begin
  try
    WndProc(Message);
  except
    Application.HandleException(Self);
  end;
end;

procedure TaqThemeNotifier.WndProc(var Msg: TMessage);
begin
  case Msg.Msg of
    WM_THEMECHANGED: DoThemeChange;
  else
    with Msg do
      Result := DefWindowProc(FHandle, Msg, wParam, LParam);
  end;
end;
{$ENDIF}

var
  GDI32Handle                                               : THandle;

initialization
  Classes.GroupDescendentsWith(TGradient, TControl);
  Classes.RegisterClass(TGradient);

  GDI32Handle := LoadLibrary(gdi32);
  if GDI32Handle > 32 then
  begin
    GetWorldTransform := GetProcAddress(GDI32Handle, 'GetWorldTransform');
    SetWorldTransform := GetProcAddress(GDI32Handle, 'SetWorldTransform');
  end
  else
    GDI32Handle := 0;
finalization
  if GDI32Handle <> 0 then
  begin
    GetWorldTransform := nil;
    SetWorldTransform := nil;
    FreeLibrary(GDI32Handle);
  end;
end.