fccommon.pas

一套及时通讯的原码

unit fcCommon;
{$T-}  { Disable Typed@ Operator}
{
//
// Components : Common routines
//
// Copyright (c) 1995, 1996, 1997 by Woll2Woll Software
//
// 3/10/99 - PYW - Changed TStringList to TStrings.
// 6/28/99 - Support any TCustomGrid for future support in IP 5
// 3/30/2001 - PYW - Made StripPreceding accessible.
// 3/1/2002-PYW-Modified to support E notation in fcstrtofloat2
}
interface

{$i fcIfDef.pas}

uses Classes, SysUtils, Dialogs, Forms, Controls, Printers, Buttons,
  Windows, Graphics, Menus, StdCtrls, TypInfo, Math, Messages, ExtCtrls,{ JPEG,}
  {$ifdef fcDelphi4Up}
  ImgList,
  {$endif}
  Registry, CommCtrl, fcBitmap, ComCtrls;

const
  clNullColor = $0FFFFFFF;

type
  TfcPointSet = (psGlyph, psText, psOffset);
  TfcPointSets = set of TfcPointSet;

  TfcProcMeth = procedure of object;
  TfcBoolFunc = function: Boolean of object;
  TfcSetBoundsProc = procedure(Control: TWinControl; Rect: TRect) of object;

  TfcLayout = (loVertical, loHorizontal);

  TfcFontType = (ftPrinter, ftTrueType, ftOther);
  PfcFontType = ^TfcFontType;

  PfcPolyGonPoints = ^TFCPolyGonPoints;
  TfcPolyGonPoints = array[0..20] of TPoint;

  TwwDBGridOption = (dgEditing, dgAlwaysShowEditor, dgTitles, dgIndicator,
    dgColumnResize, dgColLines, dgRowLines, dgRowFixedLines, dgTabs, dgRowSelect,
    dgAlwaysShowSelection, dgConfirmDelete, dgCancelOnExit,
    dgWordWrap, dgPerfectRowFit, dgMultiSelect);

  TwwDBGridOptions = set of TwwDBGridOption;

  TwwListSortCompare = function (Item1, Item2: String): Integer;
  TwwGetCompareString = function (SList:TStrings; Index: Integer): String;

  TfcOrientation = (fcTopLeft, fcTopRight, fcBottomLeft, fcBottomRight,
    fcTop, fcRight, fcLeft, fcBottom);

  TfcDiagonals = fcTopLeft..fcBottomRight;
  TfcStraights = fcTop..fcBottom;
  TfcGetWordOption = (fcgwSkipLeadingBlanks, fcgwQuotesAsWords, fcgwStripQuotes,
                      fcgwSpacesInWords);
  TfcGetWordOptions = set of TfcGetWordOption;
  fcstrCharSet = Set of char;

//const
//  OFFSETCOORD: array[TfcOrientation] of TPoint = (
//    (x: 1; y: 1) {TopLeft}, (x: -1; y: 1) {TopRight},
//    (x: 1; y: -1) {BottomLeft}, (x: -1; y: -1) {BottomRight},
//    (x: 0; y: 1) {Top}, (x: -1; y: 0) {Right},
//    (x: 1; y: 0) {Left}, (x: 0; y: -1) {Bottom}
//  );
//}
procedure fcHelp(Handle: HWND; HelpTopic: PChar);
procedure fcCalcButtonLayout(TopLeft: TPoint; TextRect, GlyphRect: PRect;
  TextSize, GlyphSize: TSize; Layout: TButtonLayout;
  Spacing: Integer);
function fcGetComCtlVersion: Integer;
procedure fcStripWhiteSpace(var s: string);
procedure fcStripTrailing(var s: string);
procedure fcStripPreceding(var s: string); // 3/30/2001 - PYW - Made StripPreceding accessible.
function fcComponentFromString(Root: TComponent; Value: string): TComponent;
function fcStringFromComponent(Root: TComponent; Value: TComponent): string;
function fcGetRegionData(Rgn: HRGN): string;

// Color related functions
procedure fcColorToByteValues(AColor: TColor; var Reserved, Blue, Green, Red: Byte);
function fcRGBToHexString(R,G,B: Byte): string;
function fcColorToRGBString(AColor: TColor): string;
function fcGetColorFromList(AList: TStrings; Index: Integer): TColor;
function fcSetColorDialogCustomColors(AList: TStrings): TStrings;
function fcModifyColor(Color: TColor; Amount: Integer; Percent: Boolean): TColor;
function fcRGBToBGR(Color: TColor): TColor;
function fcHighestRGBVal(Color: TColor): BYTE;

// Stringlist related functions
function fcGetValuesFromStringList(AList: TStrings; Index: Integer): string;
function fcGetNamesFromStringList(AList: TStrings; Index: Integer): string;
function fcGetItemsFromStringList(SList:TStrings;Index:integer): String;
function fcValueInList(Value: string; List: TStrings): integer;
function fcNameInList(Name: string; List: TStrings): integer;

// Runtime Type Info Functions (RTTI)
function fcGetPropInfo(Component: TPersistent; PropName: string): PPropInfo;
function fcIsClass(ClassType: TClass; const Name: string): Boolean;
function fcGetStrProp(Component: TPersistent; PropName: string): string;
function fcGetOrdProp(Component: TPersistent; PropName: string): Integer;
procedure fcSetStrProp(Component: TPersistent; PropName: string; Value: string);
procedure fcSetOrdProp(Component: TPersistent; PropName: string; Value: Integer);
procedure fcGetBooleanProps(Component: TPersistent; List: TStrings);

// InfoPower Grid Functions
function fcIsInwwGrid(AControl:TControl):boolean;
{$ifdef fcDelphi4Up}
function fcIsInwwObjectView(control: TWinControl):boolean;
function fcIsInwwObjectViewPaint(control: TWinControl):boolean;
function fcIsInwwGridPaint(control: TWinControl):boolean;
{$endif}
function fcGetGridOptions(AControl:TControl): TwwDBGridOptions;
function fcParentGridFocused(AControl:TControl): boolean;

// Miscellaneous
function fcStrToFloat(str:string; DisplayFormat: string = ''):extended;
function fcStrToFloat2(const S: string; var FloatValue: Extended; DisplayFormat: string): boolean;

//function fcStrToFloat(str:string):extended;
function fcStrToRealDef(const S: string; Default: Extended): Real;
procedure fcPatternFill(Pattern: Pointer; SizeOfPat: Integer; Dst: Pointer; SizeOfDst: Integer);
function fcGetShiftState:TShiftState;
procedure fcParentInvalidate(Control: TControl; Erase: Boolean);
procedure fcPlayKeystroke(Handle: HWND; VKChar: word; VKShift: Word);
procedure fcQuickSort(SList: TStrings; L, R: Integer;
  SCompare: TwwListSortCompare; SGetString:TwwGetCompareString);
function fcGetHintWindow: THintWindow;
function fcGenerateName(Component: TComponent; const Base: string): string;
procedure fcAdjustFlag(Condition: Boolean; var Flag: UINT; FlagVal: UINT);
function fcGetCursorPos: TPoint;
function fcCombineRect(r1, r2: TRect): TRect;
procedure fcShowHint(Hint: string; Coord: TPoint);
procedure fcInvalidateChildren(Control: HWND);
procedure fcInvalidateOverlappedWindows(ParentHwnd: HWND; FirstChild: HWND);
function fcProportionalRect(OrigRect: TRect; Width, Height: Integer): TRect;
function fcProportionalCenterRect(OrigRect: TRect; Width, Height: Integer): TRect;
function fcRectEmpty(r: TRect): Boolean;
function fcLineHeight(Canvas: TCanvas; Flags: Integer; MaxWidth: Integer; Line: string): Integer;
function fcUnionRect(R1, R2: TRect): TRect;

function fcUpdatedComCtlVersion: boolean;
procedure fcMakePagesResourceFriendly(PageControl: TPageControl);
function fcRegionFromBitmap(ABitmap: TfcBitmap; TransColor: TColor): HRgn;
procedure fcDrawEllipsis(Canvas: TCanvas; R: TRect; State: TButtonState;
    Enabled: Boolean;
    Transparent: boolean;
    FlatButtonTransparent: boolean;
    ControlState: TControlState);
procedure fcDrawDropDownArrow(Canvas: TCanvas; R: TRect;
    State: TButtonState; Enabled: Boolean; ControlState: TControlState);
function fcExecuteColorDialog(AColor: TColor): TColor;
procedure fcGetChildRegions(Control: TWinControl; Transparent: Boolean; Rgn: HRGN; Offset: TPoint; Flags: Integer);

function fcFindGlobalComponent(const Name: string): TComponent;
function fcIsDesigning(control: TControl): boolean;
procedure fcDisableParentClipping(Parent: TWinControl);
function fcIsInGrid(dtp:TWinControl):boolean;
Function fcstrRemoveChar(str: string; removeChar: char): string;
Function fcGetWord(s: string; var APos: integer; Options: TfcGetWordOptions;
                   DelimSet: fcstrCharSet): string;
Function fcMessageCodeToChar( code: Word ): Char;
function fcUseThemes(Control: TControl): boolean;
Function fcGetControlList(Controller: TComponent): TList;
procedure fcUpdateController(
   var FController: TComponent;
   Value: TComponent;
   Control: TControl);

type
  TfcInteger = record
    Value: Integer;
  end;
  function fcWithInteger(Value: Integer): TfcInteger;

// Animation
type
  TfcAnimateListItem = class
    Control: TWinControl;
    Bitmap: TBitmap;
    OrigRect: TRect;
    CurRect: TRect;
    FinalRect: TRect;
  end;

  TfcGroupAnimateItem = class
    MainItem: TfcAnimateListItem;
    SecondItem: TfcAnimateListItem;
  end;

procedure fcAnimateControls(Control: TWinControl; ControlCanvas: TCanvas; AnimateList: TList; Interval: Integer; Steps: Integer; SetBoundsProc: TfcSetBoundsProc);
procedure fcBufferredAnimation(ControlCanvas: TCanvas; AnimateList: TList; Interval: Integer; Steps: Integer);

//Graphic Functions...
procedure fcTileDraw(Source: TGraphic; Dest: TCanvas; DstRect: TRect);
procedure fcDrawMask(Canvas: TCanvas; ARect: TRect; Bitmap, Mask: TBitmap; Buffer: Boolean);
procedure fcPaintTo(Control: TWinControl; Canvas: TCanvas; X, Y: Integer);
function fcBytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
Function fcIsTrueColorBitmap(Bitmap: TBitmap): boolean;
function fcCreateRegionFromBitmap(ABitmap:TBitmap;TransColor: TColor) : HRgn;
function fcGetDIBBitsFromBitmap(aBitmap: TBITMAP; var BitmapInfo:TBitmapInfo; var pixbuf:Pointer; var bytespscanline:Integer; var Hb:HBitmap): Boolean;
procedure fcSetDitherBitmap(DitherBitmap: TBitmap;
  Color1, Color2: TColor);
procedure fcDither(ACanvas: TCanvas; Rect: TRect; Color1, Color2: TColor);
procedure fcOffsetBitmap(Bitmap: TfcBitmap; Transparent: TColor; Offset: TPoint);
procedure fcDottedLine(Canvas: TCanvas; p1, p2: TPoint);
procedure fcTransparentDraw(Canvas: TCanvas; ARect: TRect; Bitmap: TfcBitmap; TransparentColor: TColor);
procedure fcImageListDraw(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas;
  X, Y: Integer; Style: Cardinal; Enabled: Boolean);
procedure fcImageListDrawFixBug(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas;
  X, Y: Integer; Style: Cardinal; Enabled: Boolean);
procedure fcPaintRegion(Rgn: HRGN; DoOffset: Boolean; ShowModal: Boolean);
procedure fcPaintCanvas(ACanvas: TCanvas; Modal: Boolean);
procedure fcPaintGraphic(AGraphic: TGraphic; Modal: Boolean);
procedure fcPaintDC(DC: HDC; Modal: Boolean);
procedure fcClipBitmapToRegion(Bitmap: TfcBitmap; Rgn: HRGN);
function fcGetDitherBrush: HBRUSH;

// Value Functions
function fcMinFloat(Int1, Int2: Double): Double; overload;
function fcMin(Int1, Int2: Integer): Integer; overload;
function fcMax(Int1, Int2: Integer): Integer; overload;
function fcMaxFloat(Int1, Int2: Double): Double; overload;
function fcLimit(Val: integer; Int1, Int2: Integer): integer;
function fcThisThat(const Clause: Boolean; TrueVal, FalseVal: Integer): Integer;

// Windows Structure Functions
function fcRectWidth(Rect: TRect): Integer;
function fcRectHeight(Rect: TRect): Integer;
function fcSize(cx, cy: Integer): TSize;
function fcSizeEqual(Size1, Size2: TSize): Boolean;
procedure fcIncSize(var Size: TSize; Amount: Integer);
function fcMessage(Msg: Cardinal; wParam: WPARAM; lParam: LPARAM; MsgRslt: Cardinal): TMessage;

// String Functions
function fcSubstring(s: string; Start, Stop: integer): string;
function fcReplace(s, Find, Replace: string): string;
function fcIndexOf(Substr, s: string; Index: integer): integer;
function fcLastIndexOf(Substr, s: string; Index: integer): integer;
function fcNthIndexOf(Substr, s: string; Index: integer): integer;
function fcCountTokens(s, Delimiter: string): integer;
function fcGetToken(s, Delimiter: string; Index: integer): string;
function fcSetToken(s, Delimiter, Token: string; Index: integer): string;
function fcFindToken(s, Delimiter, Token: string): Integer;
function fcMultiLineTextSize(Canvas: TCanvas; Text: string; LineSpacing: Integer;
  MaxWidth: Integer; DrawFlags: Integer): TSize;
function fcStripAmpersands(Value: string): string;

// Integer Functions
function fcSign(Value: Extended): Integer;
procedure fcCreateDisabledBitmap(SrcBm, DstBm: TBitmap);

// Font Functions
function fcGetFontIcon(FaceName: string): TfcFontType;
function fcGetFontType(AFontType: Integer): TfcFontType;
function fcLogFont: TLogFont;

var fcVersion1stClass: string;

{$r-}

const
  BitMask: array[0..7] of byte = (128, 64, 32, 16, 8, 4, 2, 1);
  fcComCtlVersionIE3 = $00040046;
  fcComCtlVersionIE4 = $00040047;
  fcComCtlVersionIE401 = $00040048;
  fcComCtlDllName = 'comctl32.dll';

implementation

     {$ifdef fcDelphi7Up}
     uses Themes;
     {$endif}
     {$ifdef ThemeManager}
     uses thememgr, themesrv, uxtheme;
     {$endif}

var fcComCtlVersion: Integer;

{$r fcBrushes.res}
{$r fcCmbBtn.res}

function fcGetComCtlVersion: Integer;
var
  FileName: string;
  InfoSize, Wnd: DWORD;
  VerBuf: Pointer;
  FI: PVSFixedFileInfo;
  VerSize: DWORD;
begin
  if fcComCtlVersion = 0 then
  begin
    FileName := fcComCtlDllName;
    InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
    if InfoSize <> 0 then
    begin
      GetMem(VerBuf, InfoSize);
      try
        if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
          if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
            fcComCtlVersion := FI.dwFileVersionMS;
      finally
        FreeMem(VerBuf);
      end;
    end;
  end;
  Result := fcComCtlVersion;
end;

// Function for determining the current shiftstate

function fcGetShiftState: TShiftState;
begin
  Result := [];
  if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
  if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
  if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
end;

// 3/1/2002-PYW-Modified to support E notation.
function fcStrToFloat2(const S: string; var FloatValue: Extended; DisplayFormat: string): boolean;
//var Buffer: array[0..63] of char;
//    Temp: Extended;
var  i, startpos: integer;
    FloatString, TempText: string;
    Negative: boolean;
    ValidSet: fcStrCharSet;
begin
   result:= True;
   FloatString:= '';
   if length(s)=0 then exit;

   //StripLeading non digits
   for i:= 1 to length(s) do
      if s[i] in ['-', '0'..'9', DecimalSeparator, '('] then break;

   startpos:= i;
   Negative:= (s[i]='-');

   //StripLeading non digits again if found negative.
   if Negative then
   begin
     for i:= startpos to length(s) do
        if s[i] in ['0'..'9', DecimalSeparator, '('] then break;
      startpos:= i;
   end;

   //Remove commas and decimal point
   for i:= startpos to length(s) do begin
      if (i>startpos) then
      begin
         // 3/1/2002-PYW-Modified to support E notation.
         ValidSet:= ['0'..'9', '(', ')', DecimalSeparator, ThousandSeparator, 'E'];
         if length(CurrencyString)>0 then ValidSet:= ValidSet + [CurrencyString[1]];
         if not (s[i] in ValidSet) then continue;  // 8/15/2001 - Keep scanning for other digits.
      end;

      if s[i]='(' then FloatString:= FloatString + '-';
      if (s[i] in ['0'..'9', DecimalSeparator, 'E']) then
      begin
          // 3/1/2002-PYW-Modified to support E notation.
         if (s[i]= 'E') then
         begin
           if (i>1) and (s[i-1] in ['0'..'9']) and
              (i<length(s)) and (s[i+1] in ['+','-', '0'..'9']) then
              FloatString:= FloatString + s[i]
         end
         else
           FloatString:= FloatString + s[i]
      end
   end;

   if Negative then FloatString:= '-' + FloatString;

   result:= TextToFloat(pchar(FloatString), FloatValue, fvExtended);

   if result and (FloatValue>0) and (DisplayFormat<>'') then begin
     TempText:=  FormatFloat(DisplayFormat, FloatValue);
     if (TempText<>s) then
     begin
        TempText:=  FormatFloat(DisplayFormat, -FloatValue);
        if TempText=s then FloatValue:=-FloatValue;
     end
   end;

end;

function fcStrToFloat(str:string; DisplayFormat: string = ''):extended;
   function Stripcomma(s:string):String;
   var i:integer;
       c:char;
   begin
     i:=1;
     result :='';
     while i<=length(s) do begin
        c:=s[i];
        if c <> thousandseparator then
           result := result + Copy(s,i,1);
        inc(i);
     end;