flexutils.pas

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

var W, H: integer;
    Pos, RSize, BSize: TPoint;
    R: TRect;
    MemDC, CanvasDC{, BmpDC}: HDC;
    MemBmp, MemSavedBmp: HBitmap;
    MaskDC: HDC;
    MaskBmp, MaskSavedBmp: HBitmap;
    IsMasked: boolean;
    MaskedColor: TColor;
begin
 IntersectRect(R, PaintRect, RefreshRect);
 if not Assigned(ABitmap) or IsRectEmpty(R) then exit;
 RSize.X := RectWidth(R);
 RSize.Y := RectHeight(R);
 W := ABitmap.Width;
 H := ABitmap.Height;
 BSize.X := RSize.X - RSize.X mod W +2*W;
 BSize.Y := RSize.Y - RSize.Y mod H +2*H;
 Pos.X := (R.Left - PaintRect.Left) mod W;
 Pos.Y := (R.Top - PaintRect.Top) mod H;
 IsMasked := ABitmap.Transparent;
 MaskedColor := ColorToRGB(ABitmap.TransparentColor);
 CanvasDC := ACanvas.Handle;
 MemDC := 0;
 MemBmp := 0;
 MemSavedBmp := 0;
 try
  MemDC := CreateCompatibleDC(CanvasDC);
  MemBmp := CreateCompatibleBitmap(CanvasDC, BSize.X, BSize.Y);
  MemSavedBmp := SelectObject(MemDC, MemBmp);
  BitBlt(MemDC, 0, 0, W, H, ABitmap.Canvas.Handle, 0, 0, SRCCOPY);
  while H < BSize.Y do begin
   BitBlt(MemDC, 0, H, W, H, MemDC, 0, 0, SRCCOPY);
   inc(H, H);
  end;
  while W < BSize.X do begin
   BitBlt(MemDC, W, 0, W, BSize.Y, MemDC, 0, 0, SRCCOPY);
   inc(W, W);
  end;
  if IsMasked then begin
   MaskDC := 0;
   MaskBmp := 0;
   MaskSavedBmp := 0;
   try
    MaskDC := CreateCompatibleDC(0);
    MaskBmp := CreateBitmap(RSize.X, RSize.Y, 1, 1, Nil);
    MaskSavedBmp := SelectObject(MaskDC, MaskBmp);
    SelectObject(MaskDC, MaskBmp);
    SetTextColor(MemDC, clWhite);
    SetBkColor(MemDC, MaskedColor);
    BitBlt(MaskDC, 0, 0, RSize.X, RSize.Y, MemDC, Pos.X, Pos.Y, SRCCOPY);
  { with ABitmap do begin
     MaskBmp := CreateBitmap(Width, Height, 1, 1, Nil);
     MaskSavedBmp := SelectObject(MaskDC, MaskBmp);
     BmpDC := Canvas.Handle;
     SetTextColor(BmpDC, clWhite);
     SetBkColor(BmpDC, MaskedColor);
     BitBlt(MaskDC, 0, 0, Width, Height, BmpDC, 0, 0, SRCCOPY);
    end; }
    TransparentStretchBlt(CanvasDC, R.Left, R.Top, RSize.X, RSize.Y,
      MemDC, Pos.X, Pos.Y, RSize.X, RSize.Y, MaskDC, 0, 0);
   finally
    SelectObject(MaskDC, MaskSavedBmp);
    DeleteObject(MaskDC);
    { ///// DEBUG /////
    with TBitmap.Create do begin
     Handle := MaskBmp;
     SaveToFile('d:\testmask.bmp');
     free;
    end;
    { ///////////////// }
    DeleteObject(MaskBmp);
   end;
  end else
   BitBlt(CanvasDC, R.Left, R.Top, RSize.X, RSize.Y,
     MemDC, Pos.X, Pos.Y, SRCCOPY);
 finally
  SelectObject(MemDC, MemSavedBmp);
  DeleteDC(MemDC);
  DeleteObject(MemBmp);
 end;
end;
                                                        (*
function TransparentColorBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer;
  TransparentColor: TColorRef): Boolean;
// BASED ON Graphics.CopyBitmapAsMask
var
  Handle: THandle;
  DIB: TDIBSection;
  ScreenDC, BitmapDC, MonoDC: HDC;
  BkColor: TColorRef;
  Remove: Boolean;
  SaveBitmap, SaveMono, MonoBmp: HBITMAP;
begin
 Result := false;
 Handle := GetCurrentObject(SrcDC, OBJ_BITMAP);
 if (Handle = 0) or (GetObject(Handle, SizeOf(DIB), @DIB) = 0) then exit;
 //DeselectBitmap(Handle);
 ScreenDC := 0;
 MonoDC := 0;
 try
  ScreenDC := GetDC(0);
  MonoDC := CreateCompatibleDC(ScreenDC);
  if (ScreenDC = 0) or (MonoDC = 0) then exit;
  with DIB, dsBm do begin
  MonoBmp := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
  if MonoBmp = 0 then exit;
  SaveMono := SelectObject(MonoDC, MonoBmp);
  if TransparentColor = TColorRef(clNone) then
   PatBlt(MonoDC, 0, 0, bmWidth, bmHeight, Blackness)
  else begin
   BitmapDC := CreateCompatibleDC(ScreenDC);
   if BitmapDC = 0 then exit;
   try
    { Convert DIB to DDB }
    if bmBits <> nil then begin
     Remove := True;
     DIB.dsbmih.biSize := 0;
     CopyImage(Handle,
     Handle := CopyBitmap(Handle, Palette, Palette, DIB, nil);
    end else
     Remove := False;
    SaveBitmap := SelectObject(BitmapDC, Handle);
    if Palette <> 0 then
    begin
      SelectPalette(BitmapDC, Palette, False);
      RealizePalette(BitmapDC);
      SelectPalette(MonoDC, Palette, False);
      RealizePalette(MonoDC);
    end;
    BkColor := SetBkColor(BitmapDC, TransparentColor);
    BitBlt(MonoDC, 0, 0, bmWidth, bmHeight, BitmapDC, 0, 0, SrcCopy);
    SetBkColor(BitmapDC, BkColor);
    if SaveBitmap <> 0 then SelectObject(BitmapDC, SaveBitmap);
    if Remove then DeleteObject(Handle);
   finally
     DeleteDC(BitmapDC);
   end;
    end;
    if SaveMono <> 0 then SelectObject(MonoDC, SaveMono);
  end;
end;
finally
if MonoDC <> 0 then DeleteDC(MonoDC);
if ScreenDC <> 0 then ReleaseDC(0, ScreenDC);
end;
  end;

end;
                                                          *)
// Scaling routines ///////////////////////////////////////////////////////////

function ScaleValue(Value, Scale: integer): integer;
begin
 Result := MulDiv(Value, Scale, 100 * PixelScaleFactor);
end;

function UnScaleValue(Value, Scale: integer): integer;
begin
 Result := MulDiv(Value, 100 * PixelScaleFactor, Scale);
end;

function ScalePixels(Value: integer): integer;
begin
 Result := Value * PixelScaleFactor;
end;

function UnScalePixels(Value: integer): integer;
begin
 Result := Value div PixelScaleFactor;
end;

// List scan routines /////////////////////////////////////////////////////////

function ListScan(Value, List: Pointer; Count: integer): integer; assembler;
asm
        PUSH    EDI
        MOV     EDI,EDX
        OR      EDI,EDI
        JE      @@2
        REPNE   SCASD
        JE      @@1
        MOV     EDI,EDX
@@1:    SUB     EDI,EDX
        SHR     EDI,2
@@2:    MOV     EAX,EDI
        DEC     EAX
        POP     EDI
end;

function ListScanEx(Value, List: Pointer; Index, Count: integer): integer;
begin
 if Index >= Count then
  Result := -1
 else begin
  List := PChar(List) + Index * SizeOf(integer);
  dec(Count, Index);
  Result := ListScan(Value, List, Count);
 end;
end;

function ListScanLess(Value, List: Pointer; Count: integer): integer; assembler;
asm
        PUSH    EDI
        MOV     EDI,EDX
        OR      EDI,EDI
        JE      @@2
        OR      ECX,ECX
        JLE     @@2
@@1:    SCASD
        JLE     @@3
        LOOP    @@1
@@2:    ADD     EDI,4
@@3:    SUB     EDI,EDX
        SHR     EDI,2
        MOV     EAX,EDI
        DEC     EAX
        POP     EDI
end;

{$IFNDEF FG_D5} ///////////////////////////////////////////////////////////////

procedure FreeAndNil(var Obj);
var
  P: TObject;
begin
  P := TObject(Obj);
  TObject(Obj) := nil;  // clear the reference before destroying the object
  P.Free;
end;

type
  { Set access to an integer }
  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;

  EPropertyError = class(Exception);
  EPropertyConvertError = class(Exception);

function GetSetProp(Instance: TObject; PropInfo: PPropInfo;
  Brackets: Boolean): string;
var
  S: TIntegerSet;
  TypeInfo: PTypeInfo;
  I: Integer;
begin
  Integer(S) := GetOrdProp(Instance, PropInfo);
  TypeInfo := GetTypeData(PropInfo^.PropType^)^.CompType^;
  for I := 0 to SizeOf(Integer) * 8 - 1 do
    if I in S then
    begin
      if Result <> '' then
        Result := Result + ',';
      Result := Result + GetEnumName(TypeInfo, I);
    end;
  if Brackets then
    Result := '[' + Result + ']';
end;

procedure SetSetProp(Instance: TObject; PropInfo: PPropInfo;
  const Value: string);
var
  Left, EnumName: string;
  Data, EnumValue: Longint;
  EnumInfo: PTypeInfo;

  // grab the next enum name
  function NextWord: string;
  begin
    Result := '';

    // while we are still dealing with non-whitespace
    while not (Left[1] in [',', ' ']) do
    begin
      Result := Result + Left[1];
      Delete(Left, 1, 1);
      if Left = '' then
        Exit;
    end;

    // skip any whitespace
    while Left[1] in [',', ' '] do
      Delete(Left, 1, 1);
  end;
begin
  // bracket reduction
  Left := Value;
  if Left[1] = '[' then
    Delete(Left, 1, 1);
  if Left[Length(Left)] = ']' then
    Delete(Left, Length(Left), 1);

  // loop it dude!
  EnumInfo := GetTypeData(PropInfo^.PropType^)^.CompType^;
  Data := 0;
  while Left <> '' do
  begin
    EnumName := NextWord;
    if EnumName = '' then
      Break;
    EnumValue := GetEnumValue(EnumInfo, EnumName);
    if EnumValue < 0 then
      raise EPropertyConvertError.CreateFmt('Invalid property element: %s', [EnumName]);
    Include(TIntegerSet(Data), EnumValue);
  end;
  SetOrdProp(Instance, PropInfo, Data);
end;


procedure SetEnumProp(Instance: TObject; PropInfo: PPropInfo;
  const Value: string);
var
  Data: Longint;
begin
  Data := GetEnumValue(PropInfo^.PropType^, Value);
  if Data < 0 then
    raise EPropertyConvertError.CreateFmt('Invalid property element: %s', [Value]);
  SetOrdProp(Instance, PropInfo, Data);
end;

function GetPropValue(Instance: TObject; const PropName: string;
  PreferStrings: Boolean): Variant;
var
  PropInfo: PPropInfo;
  TypeData: PTypeData;
begin
  // assume failure
  Result := Null;

  // get the prop info
  PropInfo := GetPropInfo(PTypeInfo(Instance.ClassType.ClassInfo), PropName);
  if PropInfo <> nil then
  begin
    TypeData := GetTypeData(PropInfo^.PropType^);

    // return the right type
    case PropInfo^.PropType^^.Kind of
      tkInteger, tkChar, tkWChar, tkClass:
        Result := GetOrdProp(Instance, PropInfo);
      tkEnumeration:
        if PreferStrings then
          Result := GetEnumName(PropInfo^.PropType^, GetOrdProp(Instance, PropInfo))
        else if TypeData^.BaseType^ = TypeInfo(Boolean) then
          Result := Boolean(GetOrdProp(Instance, PropInfo))
        else
          Result := GetOrdProp(Instance, PropInfo);
      tkSet:
        if PreferStrings then
          Result := GetSetProp(Instance, PropInfo, False)
        else
          Result := GetOrdProp(Instance, PropInfo);
      tkFloat:
        {begin}
          Result := GetFloatProp(Instance, PropInfo);
          {if not SimpleConvert and
             (TypeData^.BaseType^ = TypeInfo(TDateTime)) then
            Result := VarAsType(Result, varDate);
        end;}
      tkMethod:
        Result := PropInfo^.PropType^.Name;
      tkString, tkLString, tkWString:
        Result := GetStrProp(Instance, PropInfo);
      tkVariant:
        Result := GetVariantProp(Instance, PropInfo);
      tkInt64:
        Result := GetInt64Prop(Instance, PropInfo) + 0.0;
    else
      raise EPropertyConvertError.CreateFmt('Invalid property type: %s',
                                            [PropInfo.PropType^^.Name]);
    end;
  end;
end;

procedure SetPropValue(Instance: TObject; const PropName: string;
  const Value: Variant);

 function RangedValue(const AMin, AMax: Int64): Int64;
 begin
   Result := Trunc(Value);
   if Result < AMin then
     Result := AMin;
   if Result > AMax then
     Result := AMax;
 end;

var
  PropInfo: PPropInfo;
  TypeData: PTypeData;
begin
  // get the prop info
  PropInfo := GetPropInfo(PTypeInfo(Instance.ClassType.ClassInfo), PropName);
  if PropInfo <> nil then
  begin
    TypeData := GetTypeData(PropInfo^.PropType^);

    // set the right type
    case PropInfo.PropType^^.Kind of
      tkInteger, tkChar, tkWChar:
        SetOrdProp(Instance, PropInfo, RangedValue(TypeData^.MinValue,
                                                   TypeData^.MaxValue));
      tkEnumeration:
        if VarType(Value) = varString then
          SetEnumProp(Instance, PropInfo, VarToStr(Value))
        else
          SetOrdProp(Instance, PropInfo, RangedValue(TypeData^.MinValue,
                                                     TypeData^.MaxValue));
      tkSet:
        if VarType(Value) = varInteger then
          SetOrdProp(Instance, PropInfo, Value)
        else
          SetSetProp(Instance, PropInfo, VarToStr(Value));
      tkFloat:
        SetFloatProp(Instance, PropInfo, Value);
      tkString, tkLString, tkWString:
        SetStrProp(Instance, PropInfo, VarToStr(Value));
      tkVariant:
        SetVariantProp(Instance, PropInfo, Value);
      tkInt64:
        SetInt64Prop(Instance, PropInfo, RangedValue(TypeData^.MinInt64Value,
                                                     TypeData^.MaxInt64Value));
    else
      raise EPropertyConvertError.CreateFmt('Invalid property type: %s',
                                            [PropInfo.PropType^^.Name]);
    end;
  end;
end;

function PropType(AClass: TClass; const PropName: string): TTypeKind;
var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(AClass.ClassInfo, PropName);
  if PropInfo = nil then
    raise EPropertyError.Create('Property does not exist');
  Result := PropInfo^.PropType^^.Kind;
end;

{$ENDIF} //////////////////////////////////////////////////////////////////////

initialization
  CF_FLEXDOC := RegisterClipboardFormat('FlexGraphics controls');

end.