flexutils.pas

是一套创建矢量图形的VCL组件

   // Insert value in previous region
   FPool[Index-1] := pointer(Value)
  else begin
   // Create new region
   FPool.Insert(Index, pointer(Value));
   FPool.Insert(Index, pointer(Value));
  end;
  Result := true;
 end;
end;

function  TIdPool.Release(Value: cardinal): boolean;
var Index: integer;
begin
 Result := false;
 if Value <= 0 then exit;
 Index := ListScanLess(pointer(Value), FPool.List, FPool.Count);
 if Index = FPool.Count then exit; // Value not used
 // Value can be in use
 if cardinal(FPool[Index]) = Value then begin
  // Released value is start or end of used region
  if Index and 1 = 0 then begin
   // It is start of region
   if cardinal(FPool[Index+1]) = Value then begin
    // Delete region
    FPool.Delete(Index+1);
    FPool.Delete(Index);
   end else
    // Move start of region
    FPool[Index] := pointer(Value+1);
  end else begin
   // It is end of region
   if cardinal(FPool[Index-1]) = Value then begin
    // Delete region
    FPool.Delete(Index);
    FPool.Delete(Index-1);
   end else
    // Move end of region
    FPool[Index] := pointer(Value-1);
  end;
  Result := true;
 end else
 if Index and 1 <> 0 then begin
  // Break region
  FPool.Insert(Index, pointer(Value+1));
  FPool.Insert(Index, pointer(Value-1));
  Result := true;
 end;
end;

procedure TIdPool.Clear;
begin
 FPool.Clear;
end;

///////////////////////////////////////////////////////////////////////////////

procedure LoadFlexCursors;
begin
 Screen.Cursors[crShapeCursor] := LoadCursor(HInstance, 'SHAPE_CUR');
 if Screen.Cursors[crShapeCursor] = 0 then
  Screen.Cursors[crShapeCursor] := LoadCursor(HInstance, IDC_UPARROW);
 Screen.Cursors[crShapeAddCursor] := LoadCursor(HInstance, 'SHAPE_ADD_CUR');
 Screen.Cursors[crShapeDelCursor] := LoadCursor(HInstance, 'SHAPE_DEL_CUR');
 Screen.Cursors[crShapeCloseCursor] := LoadCursor(HInstance, 'SHAPE_CLOSE_CUR');
 Screen.Cursors[crShapeMoveCursor] := LoadCursor(HInstance, 'SHAPE_MOVE_CUR');
 Screen.Cursors[crCreateControlCursor] := LoadCursor(HInstance, 'CREATE_CTRL_CUR');
 Screen.Cursors[crCreateRectCursor] := LoadCursor(HInstance, 'CREATE_RECT_CUR');
 Screen.Cursors[crCreateEllipseCursor] := LoadCursor(HInstance, 'CREATE_ELLIPSE_CUR');
 Screen.Cursors[crCreateTextCursor] := LoadCursor(HInstance, 'CREATE_TEXT_CUR');
 Screen.Cursors[crCreatePicCursor] := LoadCursor(HInstance, 'CREATE_PIC_CUR');
 Screen.Cursors[crCreatePolyCursor] := LoadCursor(HInstance, 'CREATE_POLY_CUR');
 Screen.Cursors[crZoomInCursor] := LoadCursor(HInstance, 'ZOOM_IN_CUR');
 Screen.Cursors[crZoomOutCursor] := LoadCursor(HInstance, 'ZOOM_OUT_CUR');
 Screen.Cursors[crPanCursor] := LoadCursor(HInstance, 'PAN_CUR');
 Screen.Cursors[crPanningCursor] := LoadCursor(HInstance, 'PANNING_CUR');
end;

///////////////////////////////////////////////////////////////////////////////

function StrBeginsFrom(const S1, S2: string): boolean; assembler;
asm
        PUSH    ESI
        PUSH    EDI
        MOV     ESI,EAX
        MOV     EDI,EDX
        OR      EAX,EAX
        JE      @@1
        MOV     EAX,[EAX-4]
@@1:    OR      EDX,EDX
        JE      @@2
        MOV     EDX,[EDX-4]
@@2:    MOV     ECX,EAX
        CMP     ECX,EDX
        JBE     @@3
        MOV     ECX,EDX
@@3:    XOR     EAX,EAX
        CMP     ECX,ECX
        REPE    CMPSB
        JE      @@4
        DEC     EAX
@@4:    INC     EAX
        POP     EDI
        POP     ESI
end;

function ExtractWord(const s: string; NumWord: integer; Delimiter: char): string;
var i, WordBeg, WordEnd: integer;
    Len: integer;
begin
 Len := Length(s);
 if (NumWord < 1) or (Len = 0) then begin
  Result := '';
  exit;
 end;
 WordBeg := 1;
 WordEnd := Len;
 for i:=1 to Len do
  if s[i] = Delimiter then begin
   dec(NumWord);
   if NumWord = 1 then
    WordBeg := i+1
   else
   if NumWord = 0 then begin
    WordEnd := i-1;
    break;
   end;
  end;
 if NumWord <= 1
  then Result := copy(s, WordBeg, WordEnd - WordBeg + 1)
  else Result := '';
end;

const
  HexCodes: array[0..15+7] of byte = (
    0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0,0,10,11,12,13,14,15
  );

function HexCharsToByte(cw: word): byte; assembler;
asm
        push    ebx
        push    edi
        lea     edi, HexCodes
        movzx   eax, ax
        sub     eax, 00003030h
        movzx   ebx, al
        movzx   ebx, byte ptr [edi + ebx]
        shr     eax, 8
        movzx   eax, byte ptr [edi + eax]
        shl     eax, 4
        or      eax, ebx
        pop     edi
        pop     ebx
end;

const
  HexWords: array[0..255] of word = (
    $3030, $3130, $3230, $3330, $3430, $3530, $3630, $3730,
    $3830, $3930, $4130, $4230, $4330, $4430, $4530, $4630,
    $3031, $3131, $3231, $3331, $3431, $3531, $3631, $3731,
    $3831, $3931, $4131, $4231, $4331, $4431, $4531, $4631,
    $3032, $3132, $3232, $3332, $3432, $3532, $3632, $3732,
    $3832, $3932, $4132, $4232, $4332, $4432, $4532, $4632,
    $3033, $3133, $3233, $3333, $3433, $3533, $3633, $3733,
    $3833, $3933, $4133, $4233, $4333, $4433, $4533, $4633,
    $3034, $3134, $3234, $3334, $3434, $3534, $3634, $3734,
    $3834, $3934, $4134, $4234, $4334, $4434, $4534, $4634,
    $3035, $3135, $3235, $3335, $3435, $3535, $3635, $3735,
    $3835, $3935, $4135, $4235, $4335, $4435, $4535, $4635,
    $3036, $3136, $3236, $3336, $3436, $3536, $3636, $3736,
    $3836, $3936, $4136, $4236, $4336, $4436, $4536, $4636,
    $3037, $3137, $3237, $3337, $3437, $3537, $3637, $3737,
    $3837, $3937, $4137, $4237, $4337, $4437, $4537, $4637,
    $3038, $3138, $3238, $3338, $3438, $3538, $3638, $3738,
    $3838, $3938, $4138, $4238, $4338, $4438, $4538, $4638,
    $3039, $3139, $3239, $3339, $3439, $3539, $3639, $3739,
    $3839, $3939, $4139, $4239, $4339, $4439, $4539, $4639,
    $3041, $3141, $3241, $3341, $3441, $3541, $3641, $3741,
    $3841, $3941, $4141, $4241, $4341, $4441, $4541, $4641,
    $3042, $3142, $3242, $3342, $3442, $3542, $3642, $3742,
    $3842, $3942, $4142, $4242, $4342, $4442, $4542, $4642,
    $3043, $3143, $3243, $3343, $3443, $3543, $3643, $3743,
    $3843, $3943, $4143, $4243, $4343, $4443, $4543, $4643,
    $3044, $3144, $3244, $3344, $3444, $3544, $3644, $3744,
    $3844, $3944, $4144, $4244, $4344, $4444, $4544, $4644,
    $3045, $3145, $3245, $3345, $3445, $3545, $3645, $3745,
    $3845, $3945, $4145, $4245, $4345, $4445, $4545, $4645,
    $3046, $3146, $3246, $3346, $3446, $3546, $3646, $3746,
    $3846, $3946, $4146, $4246, $4346, $4446, $4546, $4646
  );

function ByteToHexChars(b: byte): word; assembler;
asm
        movzx   eax, al
        movzx   eax, word ptr [HexWords + eax*2]
end;

function RectWidth(const ARect: TRect): integer; assembler;
asm
        PUSH    [EAX].TRect.Left
        MOV     EAX, [EAX].TRect.Right
        SUB     EAX, [ESP]
        ADD     ESP, 4
end;

function RectHeight(const ARect: TRect): integer; assembler;
asm
        PUSH    [EAX].TRect.Top
        MOV     EAX, [EAX].TRect.Bottom
        SUB     EAX, [ESP]
        ADD     ESP, 4
end;

{ TDummyPicture }

type
  TDummyPicture = class(TPicture)
  public
   procedure CallFiler(Filer: TFiler);
  end;

procedure TDummyPicture.CallFiler(Filer: TFiler);
begin
 DefineProperties(Filer);
end;

{ TDummyFiler }

type
  TDummyFiler = class(TFiler)
  public
   ReadProc, WriteProc: TStreamProc;
   procedure DefineProperty(const Name: string;
     ReadData: TReaderProc; WriteData: TWriterProc;
     HasData: Boolean); override;
   procedure DefineBinaryProperty(const Name: string;
     ReadData, WriteData: TStreamProc;
     HasData: Boolean); override;
   procedure FlushBuffer; override;
  end;

procedure TDummyFiler.DefineBinaryProperty(const Name: string; ReadData,
  WriteData: TStreamProc; HasData: Boolean);
begin
 ReadProc := ReadData;
 WriteProc := WriteData;
end;

procedure TDummyFiler.FlushBuffer; begin end;
procedure TDummyFiler.DefineProperty(const Name: string;
  ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean); begin end;

procedure GetPicReadWrite(Picture: TPicture;
  out ReadProc, WriteProc: TStreamProc);
var Filer: TDummyFiler;
begin
 Filer := TDummyFiler.Create(Nil, 0);
 try
  TDummyPicture(Picture).CallFiler(Filer);
  ReadProc := Filer.ReadProc;
  WriteProc := Filer.WriteProc;
 finally
  Filer.Free;
 end;
end;

///////////////////////////////////////////////////////////////////////////////

function NormalizeRect(const R: TRect): TRect;
begin
 if R.Left > R.Right then begin
  Result.Left := R.Right;
  Result.Right := R.Left;
 end else begin
  Result.Left := R.Left;
  Result.Right := R.Right;
 end;
 if R.Top > R.Bottom then begin
  Result.Top := R.Bottom;
  Result.Bottom := R.Top;
 end else begin
  Result.Top := R.Top;
  Result.Bottom := R.Bottom;
 end;
end;

function PointInRect(const p: TPoint; const R: TRect): boolean;
begin
 Result := (p.X >= R.Left) and (p.X <= R.Right) and
           (p.Y >= R.Top) and (p.Y <= R.Bottom);
end;

///////////////////////////////////////////////////////////////////////////////

function IntersectClipRgn(ACanvas: TCanvas; ClipRgn: HRGN): HRGN;
begin
 Result := CreateRectRgn(0, 0, 1, 1);
 try
  if GetClipRgn(ACanvas.Handle, Result) <> 1 then begin
   DeleteObject(Result);
   Result := 0;
   SelectClipRgn(ACanvas.Handle, ClipRgn);
  end else
   ExtSelectClipRgn(ACanvas.Handle, ClipRgn, RGN_AND);
 except
  DeleteObject(Result);
  raise;
 end;
end;

function IntersectClipPath(DC: HDC): HRGN;
begin
 Result := CreateRectRgn(0, 0, 1, 1);
 try
  if GetClipRgn(DC, Result) <> 1 then begin
   DeleteObject(Result);
   Result := 0;
   if not SelectClipPath(DC, RGN_COPY) then begin
    // Path error. Mask all output
    Result := CreateRectRgn(0, 0, 0, 0);
    SelectClipRgn(DC, Result);
    DeleteObject(Result);
    Result := 0;
   end;
  end else
   SelectClipPath(DC, RGN_AND);
 except
  DeleteObject(Result);
  raise;
 end;
end;

procedure PaintGradient(ACanvas: TCanvas; ARect: TRect; Style: TGradientStyle;
  Color, EndColor: TColor; PenMode: TPenMode);
var i, W, H, x, y, MaxWH: integer;
    AColor: TColor;
    Start: TRect;
    DeltaR, DeltaG, DeltaB: integer;
    StartR, StartG, StartB: integer;
    MaxDelta: integer;
    OldPenMode: TPenMode;
begin
 if IsRectEmpty(ARect) then exit;
 W := ARect.Right - ARect.Left;
 H := ARect.Bottom - ARect.Top;
 if W > H
  then MaxWH := W
  else MaxWH := H;
 Color := ColorToRGB(Color);
 EndColor := ColorToRGB(EndColor);
 if Style in [gsTopLeft..gsBottomRight] then begin
  AColor := Color;
  Color := EndColor;
  EndColor := AColor;
 end;
 StartR := GetRValue(Color);
 StartG := GetGValue(Color);
 StartB := GetBValue(Color);
 DeltaR := GetRValue(EndColor) - StartR;
 DeltaG := GetGValue(EndColor) - StartG;
 DeltaB := GetBValue(EndColor) - StartB;
 if Abs(DeltaR) > Abs(DeltaG)
  then MaxDelta := Abs(DeltaR)
  else MaxDelta := Abs(DeltaG);
 if MaxDelta < Abs(DeltaB) then MaxDelta := Abs(DeltaB);
 if MaxDelta < 1 then MaxDelta := 1;
 case Style of
  gsHorizontal  : if MaxDelta > W then MaxDelta := W;
  gsVertical    : if MaxDelta > H then MaxDelta := H;
  gsSquare,
  gsElliptic    : if MaxDelta > MaxWH div 2 then MaxDelta := MaxWH div 2;
  gsTopLeft,
  gsTopRight,
  gsBottomLeft,
  gsBottomRight : if MaxDelta > MaxWH then MaxDelta := MaxWH;
 end;
 case Style of
  gsHorizontal,
  gsVertical    : Start := Rect(0, 0, W, H);
  gsSquare,
  gsElliptic    : Start := Rect(W div 2, H div 2, W div 2, H div 2);
  gsTopLeft     : Start := Rect(0, 0, 1, 1);
  gsTopRight    : Start := Rect(W, 1, W+1, 0);
  gsBottomLeft  : Start := Rect(1, H, 0, H+1);
  gsBottomRight : Start := Rect(W, H, W+1, H+1);
 end;
 OffsetRect(Start, ARect.Left, ARect.Top);
 with ACanvas do begin
  OldPenMode := Pen.Mode;
  Brush.Style := bsSolid;
  Pen.Style := psClear;
  Pen.Mode := PenMode;
  //dec(MaxDelta);
  for i := 0 to MaxDelta-1 do with Start do begin
   if MaxDelta > 1 then
    Brush.Color :=
      RGB( StartR + MulDiv(i, DeltaR, MaxDelta-1),
           StartG + MulDiv(i, DeltaG, MaxDelta-1),
           StartB + MulDiv(i, DeltaB, MaxDelta-1) )
   else
    Brush.Color := Color;
   case Style of
    gsHorizontal:
      begin
       Rectangle(
         Left + MulDiv(i, W, MaxDelta), Top,
         Left + MulDiv(i+1, W, MaxDelta) +1, Bottom +1 );
      end;
    gsVertical:
      begin
       Rectangle(
         Left, Top + MulDiv(i, H, MaxDelta),
         Right +1, Top + MulDiv(i+1, H, MaxDelta) +1 );
      end;
    gsSquare:
      begin
       x := MulDiv((MaxDelta-i), W, MaxDelta) div 2;
       y := MulDiv((MaxDelta-i), H, MaxDelta) div 2;
       Rectangle(Left - x, Top - y, Left + x +2, Top + y +2);
      end;
    gsElliptic:
      begin
       x := Round(MulDiv((MaxDelta-i), W, MaxDelta) / 1.4);
       y := Round(MulDiv((MaxDelta-i), H, MaxDelta) / 1.4);
       Ellipse(Left - x, Top - y, Left + x, Top + y);
      end;
    gsTopLeft..gsBottomRight:
      begin
       x := MulDiv((MaxDelta-i), W, MaxDelta);
       y := MulDiv((MaxDelta-i), H, MaxDelta);
       case Style of
        gsTopLeft     : Rectangle(Left, Top, Right + x, Bottom + y);
        gsTopRight    : Rectangle(Left - x, Top + y, Right, Bottom);
        gsBottomLeft  : Rectangle(Left + x, Top - y, Right, Bottom);
        gsBottomRight : Rectangle(Left - x, Top - y, Right, Bottom);
       end;
      end;
   end;
  end;
  Pen.Mode := OldPenMode;
 end;
end;

procedure PaintTailed(ACanvas: TCanvas; const PaintRect, RefreshRect: TRect;
  ABitmap: TBitmap);