VCL的TBitmap补丁

[日立奔腾浪潮微软松下联想]

初步实现了旋转（任意角度，顺时针/逆时针方向），固定角度旋转（90、180、270度，顺时针/逆时针方向），翻转，镜像等功能，转换速度还可以。
也可能存在某些BUGs，有时间的可以测试一下。

{ VCL TBitmap Helper                             }
{ Supplemental methods to TBitmap for supporting }
{ rotate, flip, mirror, etc.                     }
{ version 0.01                                   }
{ written by DG, 2020-03-14                      }

unit Vcl.Graphics.BitmapHelper;

interface

uses Vcl.Graphics;

type
  TDirection = (dir90, dir180, dir270);

  TBitmapHelper = class helper for Vcl.Graphics.TBitmap
    procedure Rotate(Rads: single; Clockwise: boolean = false;
      AdjustSize: boolean = true; BkColor: TColor = clWhite); overload;
    procedure Rotate(Direction: TDirection; Clockwise: boolean = false); overload;
    procedure Flip; inline;
    procedure Mirror; inline;
    procedure FlipAndMirror; inline;
  end;

implementation

uses System.Classes, WinApi.Windows;

// --------------------------------------------------------------------------
// TBitmapHelper

// the function TBitmapHelper.Rotate(Rads: single; ...) references to
// following STACKOVERFLOW thread:
// https://stackoverflow.com/questions/10633400/rotate-bitmap-by-real-angle
procedure TBitmapHelper.Rotate(Rads: single; Clockwise: boolean = false;
  AdjustSize: boolean = true; BkColor: TColor = clWhite);
var
  C: Single;
  S: Single;
  Tmp: Vcl.graphics.TBitmap;
  OffsetX: Single;
  OffsetY: Single;
  Points: array[0..2] of TPoint;
begin
  if not Clockwise then  // counterclockwise
  begin
    Rads := Frac(Rads / PI * PI);
    if Rads < 0 then
      Rads := PI * 2 + Rads
    else
      Rads := PI * 2 - Rads;
  end;

  C := Cos(Rads);
  S := Sin(Rads);
  Tmp := Vcl.Graphics.TBitmap.Create;
  try
    Tmp.TransparentColor := Self.TransparentColor;
    Tmp.TransparentMode := Self.TransparentMode;
    Tmp.Transparent := Self.Transparent;
    Tmp.Canvas.Brush.Color := BkColor;

    if AdjustSize then
    begin
      Tmp.Width := Round(Self.Width * Abs(C) + Self.Height * Abs(S));
      Tmp.Height := Round(Self.Width * Abs(S) + Self.Height * Abs(C));
      OffsetX := (Tmp.Width - Self.Width * C + Self.Height * S) / 2;
      OffsetY := (Tmp.Height - Self.Width * S - Self.Height * C) / 2;
    end
    else
    begin
      Tmp.Width := Self.Width;
      Tmp.Height := Self.Height;
      OffsetX := (Self.Width - Self.Width * C + Self.Height * S) / 2;
      OffsetY := (Self.Height - Self.Width * S - Self.Height * C) / 2;
    end;

    Points[0].X := Round(OffsetX);
    Points[0].Y := Round(OffsetY);
    Points[1].X := Round(OffsetX + Self.Width * C);
    Points[1].Y := Round(OffsetY + Self.Width * S);
    Points[2].X := Round(OffsetX - Self.Height * S);
    Points[2].Y := Round(OffsetY + Self.Height * C);
    PlgBlt(Tmp.Canvas.Handle, Points,
           Self.Canvas.Handle, 0, 0, Self.Width, Self.Height,
           0, 0, 0);
    Self.Assign(Tmp);
  finally
    Tmp.Free;
  end;
end;

{$POINTERMATH ON}
procedure __RotateBitmap90(var ABitmap: Vcl.Graphics.TBitmap; Clockwise: boolean = false);
type
  TPtrMultiplex = record
    case integer of
      1: (P1: PByte);
      2: (P2: PWord);
      3: (P3: PRGBTriple);
      4: (P4: PCardinal);
  end;
var
  Tmp: Vcl.Graphics.TBitmap;
  BMP: WinApi.Windows.BITMAP;
  PixelSize: integer;
  SrcLineSize, DestLineSize: integer;
  Src, Dest: pointer;
  PSrc, PDest: TPtrMultiplex;
  i, j: integer;
begin
  if not Assigned(ABitmap) or ABitmap.Empty then exit;

  Tmp := Vcl.Graphics.TBitmap.Create;
  Tmp.TransparentColor := ABitmap.TransparentColor;
  Tmp.TransparentMode := ABitmap.TransparentMode;
  Tmp.Transparent := ABitmap.Transparent;

  if ABitmap.PixelFormat in [pfDevice, pf1bit, pf4bit, pfCustom] then
  begin
    if ABitmap.PixelFormat = pfDevice then
      Tmp.PixelFormat := pf32bit
    else
      Tmp.PixelFormat := pf8bit;
    Tmp.SetSize(ABitmap.Width, ABitmap.Height);
    Tmp.Canvas.Draw(0, 0, ABitmap);
    ABitmap.Assign(Tmp);
  end
  else
    Tmp.PixelFormat := ABitmap.PixelFormat;
  Tmp.SetSize(ABitmap.Height, ABitmap.Width);

  if ABitmap.PixelFormat = pf8bit then
    SelectPalette(Tmp.Canvas.Handle, ABitmap.Palette, false);
  GetObject(ABitmap.Handle, sizeof(BMP), @BMP);
  if BMP.bmBitsPixel >= 8 then
  begin
    PixelSize := (BMP.bmBitsPixel + 7) div 8;
    SrcLineSize := BMP.bmWidthBytes;
    Src := BMP.bmBits;
    GetObject(Tmp.Handle, sizeof(BMP), @BMP);
    DestLineSize := BMP.bmWidthBytes;
    Dest := BMP.bmBits;

    case PixelSize of
      1:
        begin
          PSrc.P1 := Src;
          if Clockwise then
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P1 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P1[i] := PSrc.P1[ABitmap.Width - 1 - j];
                Inc(NativeInt(PDest.P1), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P1), SrcLineSize);
            end
          else
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P1 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P1[Tmp.Width - i - 1] := PSrc.P1[j];
                Inc(NativeInt(PDest.P1), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P1), SrcLineSize);
            end;
        end;
      2:
        begin
          PSrc.P2 := Src;
          if Clockwise then
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P2 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P2[i] := PSrc.P2[ABitmap.Width - 1 - j];
                Inc(NativeInt(PDest.P2), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P2), SrcLineSize);
            end
          else
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P2 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P2[Tmp.Width - i - 1] := PSrc.P2[j];
                Inc(NativeInt(PDest.P2), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P2), SrcLineSize);
            end;
        end;
      3:
        begin
          PSrc.P3 := Src;
          if Clockwise then
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P3 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P3[i] := PSrc.P3[ABitmap.Width - 1 - j];
                Inc(NativeInt(PDest.P3), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P3), SrcLineSize);
            end
          else
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P3 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P3[Tmp.Width - i - 1] := PSrc.P3[j];
                Inc(NativeInt(PDest.P3), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P3), SrcLineSize);
            end;
        end;
      4:
        begin
          PSrc.P4 := Src;
          if Clockwise then
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P4 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P4[i] := PSrc.P4[ABitmap.Width - 1 - j];
                Inc(NativeInt(PDest.P4), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P4), SrcLineSize);
            end
          else
            for i := 0 to ABitmap.Height - 1 do
            begin
              PDest.P4 := Dest;
              for j := 0 to ABitmap.Width - 1 do
              begin
                PDest.P4[Tmp.Width - i - 1] := PSrc.P4[j];
                Inc(NativeInt(PDest.P4), DestLineSize);
              end;
              Inc(nativeInt(PSrc.P4), SrcLineSize);
            end;
        end;
    end;
  end;

  ABitmap.Assign(Tmp);
  Tmp.Free;
end;

procedure TBitmapHelper.Rotate(Direction: TDirection; Clockwise: boolean = false);
begin
  case Direction of
    dir90:
      __RotateBitmap90(Self, Clockwise);
    dir180:
      Self.FlipAndMirror;
    dir270:
      __RotateBitmap90(Self, not Clockwise);
  end;
end;

procedure TBitmapHelper.Flip;
begin
  Self.Canvas.CopyRect(Rect(0, 0, Self.Width, Self.Height),
                       Self.Canvas,
                       Rect(0, Self.Height, Self.Width, 0));
end;

procedure TBitmapHelper.Mirror;
begin
  Self.Canvas.CopyRect(Rect(0, 0, Self.Width, Self.Height),
                       Self.Canvas,
                       Rect(Self.Width, 0, 0, Self.Height));
end;

procedure TBitmapHelper.FlipAndMirror;
begin
  Self.Canvas.CopyRect(Rect(0, 0, Self.Width, Self.Height),
                       Self.Canvas,
                       Rect(Self.Width, Self.Height, 0, 0));
end;

end.

[日立奔腾浪潮微软松下联想]

Delphi程序中，只要uses Vcl.Graphics.BitmapHelper; 就可以直接：
var
bmp: TBitmap;
// ...
bmp.Rotate(...);
这也是Class Helpers的强大之处，可以直接对已有的类打补丁，不需要修改类源码或者派生新类。

但是CB不支持Class Helpers，还需要一个接口单元：

unit CPPBitmapHelper;

interface

uses Vcl.Graphics, Vcl.Graphics.BitmapHelper;

type
  TDirection = Vcl.Graphics.BitmapHelper.TDirection;

procedure Rotate(ABitmap: TBitmap; Rads: single; Clockwise: boolean = false;
  AdjustSize: boolean = true; BkColor: TColor = clWhite); overload; inline;
procedure Rotate(ABitmap: TBitmap; Direction: TDirection;
  Clockwise: boolean = false); overload; inline;
procedure Flip(ABitmap: TBitmap); inline;
procedure Mirror(ABitmap: TBitmap); inline;
procedure FlipAndMirror(ABitmap: TBitmap); inline;

implementation

procedure Rotate(ABitmap: TBitmap; Rads: single; Clockwise: boolean = false;
  AdjustSize: boolean = true; BkColor: TColor = clWhite);
begin
  ABitmap.Rotate(Rads, Clockwise, AdjustSize, BkColor);
end;

procedure Rotate(ABitmap: TBitmap; Direction: TDirection; Clockwise: boolean = false);
begin
  ABitmap.Rotate(Direction, Clockwise);
end;

procedure Flip(ABitmap: TBitmap);
begin
  ABitmap.Flip;
end;

procedure Mirror(ABitmap: TBitmap);
begin
  ABitmap.Mirror;
end;

procedure FlipAndMirror(ABitmap: TBitmap);
begin
  ABitmap.FlipAndMirror;
end;

end.

在CB程序中，把上述两个.pas添加到工程中，然后#include <CPPBitmapHelper.hpp>就可以使用了，但是只能：
Rotate(bmp, ...);这种方式使用，不能作为TBitmap的成员函数使用。咯有遗憾，希望CB的后续版本能支持Helpers功能就好了。

[ooolinux]

出手不凡亚，你这个写得太通用了，有空我试一下。不过我看不太懂，可能就不用在我那个小项目中了。

[ooolinux]

不知道Lazarus支不支持Class Helpers功能？

[日立奔腾浪潮微软松下联想]

引用 6 楼 ooolinux 的回复:

[quote=引用 5 楼 早打大打打核战争 的回复:]
[quote=引用 3 楼 ooolinux 的回复:]
不知道Lazarus支不支持Class Helpers功能？

支持，还有扩展，Delphi的Helpers只有Class Helpers允许继承，对其他类型都不允许继承，FPC允许对任意类型的Helpers继承
[/quote]

看来Lazarus也不差，Delphi XE以后有一些新的语法，Lazarus也支持吗？[/quote]

语言的兼容性应该能达到99%+，主要的兼容性问题在框架，对VCL的兼容性已经很好了，差不多90%+，但是不支持FMX是很大的问题

[ooolinux]

对VCL的兼容性是什么意思，指能用的三方控件？三方控件也只能用于win平台了。 Lazarus也支持安卓、ios开发了，但是没有FMX那么炫。

[日立奔腾浪潮微软松下联想]

引用 8 楼 ooolinux 的回复:

对VCL的兼容性是什么意思，指能用的三方控件？三方控件也只能用于win平台了。
Lazarus也支持安卓、ios开发了，但是没有FMX那么炫。

指的是官方VCL的大部分功能在FCL/LCL中都有了，第三方的不好说，但是很多也支持FPC，比如indy

[ooolinux]

引用 9 楼 早打大打打核战争 的回复:

[quote=引用 8 楼 ooolinux 的回复:] 对VCL的兼容性是什么意思，指能用的三方控件？三方控件也只能用于win平台了。 Lazarus也支持安卓、ios开发了，但是没有FMX那么炫。

指的是官方VCL的大部分功能在FCL/LCL中都有了，第三方的不好说，但是很多也支持FPC，比如indy [/quote] 三方控件Lazarus能不能用，跟三方控件原本是不是跨平台有关吗？如果三方控件只有win平台，Lazarus在win平台下多数也能用上吧？

[日立奔腾浪潮微软松下联想]

引用 2 楼 ooolinux 的回复:

出手不凡亚，你这个写得太通用了，有空我试一下。不过我看不太懂，可能就不用在我那个小项目中了。

只＿是＿４＿０＿０＿分＿＋＿几＿小＿时＿时＿间，非法词组是什么鬼~~~

[日立奔腾浪潮微软松下联想]

引用 3 楼 ooolinux 的回复:

不知道Lazarus支不支持Class Helpers功能？

支持，还有扩展，Delphi的Helpers只有Class Helpers允许继承，对其他类型都不允许继承，FPC允许对任意类型的Helpers继承

[ooolinux]

引用 5 楼 早打大打打核战争 的回复:

[quote=引用 3 楼 ooolinux 的回复:] 不知道Lazarus支不支持Class Helpers功能？

支持，还有扩展，Delphi的Helpers只有Class Helpers允许继承，对其他类型都不允许继承，FPC允许对任意类型的Helpers继承 [/quote] 看来Lazarus也不差，Delphi XE以后有一些新的语法，Lazarus也支持吗？

[日立奔腾浪潮微软松下联想]

应该大部分可以，依据https://wiki.freepascal.org/Lazarus_For_Delphi_Users 上的说明：
Lazarus is a Rapid Application Development (RAD) tool like Delphi. That means it comes with a visual component library and an Integrated Development Environment (IDE). The Lazarus component library (LCL) is very similar to Delphi's Visual Component Library (VCL). Most Lazarus units, classes and properties have the same name and functionality as their equivalents in Delphi. This makes porting Delphi applications to Lazarus relatively easy. Even though Lazarus is in many respects an open source Delphi clone, the compatibility is not 100%.

[ooolinux]

引用 11 楼 早打大打打核战争 的回复:

应该大部分可以，依据https://wiki.freepascal.org/Lazarus_For_Delphi_Users 上的说明： Lazarus is a Rapid Application Development (RAD) tool like Delphi. That means it comes with a visual component library and an Integrated Development Environment (IDE). The Lazarus component library (LCL) is very similar to Delphi's Visual Component Library (VCL). Most Lazarus units, classes and properties have the same name and functionality as their equivalents in Delphi. This makes porting Delphi applications to Lazarus relatively easy. Even though Lazarus is in many respects an open source Delphi clone, the compatibility is not 100%.

这里没提到三方控件的兼容性。

[ooolinux]

帮我看看这个： 经过蓝牙连接后播放的歌曲，音质相对于直接播放会不会变差了？换句话说，蓝牙连接是否属于物理层加数据链路层，对上层传输的数据比如音频是透明无损的？ https://bbs.csdn.net/topics/396185110

[秋天之落叶]

哇塞，收藏了