igpfunctions.pas

iocopm3.04源码,一套很好的工控开发工具

{*******************************************************}
{                                                       }
{       iGPFunctions (General Purpose)                  }
{                                                       }
{       Copyright (c) 1997,2003 Iocomp Software         }
{                                                       }
{*******************************************************}
{$I iInclude.inc}

{$ifdef iVCL}unit  iGPFunctions;{$endif}
{$ifdef iCLX}unit QiGPFunctions;{$endif}

interface

uses
  {$I iIncludeUses.inc}
  {$IFDEF iVCL} iTypes,  iMath,  Printers;{$ENDIF}
  {$IFDEF iCLX}QiTypes, QiMath, QPrinters;{$ENDIF}

procedure GetAutoScaleValuesAdjustable(DesiredMin, DesiredMax: Double; DesiredTicks, MaxTicks: Integer;
                                       var NewMin: Double; var NewMax: Double; var NewTicks: Integer);

procedure GetAutoScaleValuesFixed     (DesiredMin, DesiredMax: Double; DesiredTicks, MaxTicks: Integer;
                                       var NewMin: Double; var NewMax: Double; var NewTicks: Integer);

function DimColor(Value: TColor; Divisor: Integer): TColor;

procedure LineBevel       (Canvas: TCanvas; X1, Y1, X2, Y2: Integer; Style: TiBevelStyle);
procedure Line            (Canvas: TCanvas; Left, Top, Right, Bottom: Integer);
procedure DrawRaisedBorder(Canvas: TCanvas; ARect : TRect);
procedure DrawSunkenBorder(Canvas: TCanvas; ARect : TRect);

procedure DrawGradient(ACanvas: TCanvas; BackColor, ShawdowColor: TColor; ARect: TRect; ReverseColors: Boolean);
procedure DrawGradientCircle(Canvas: TCanvas; const CenterPoint: TPoint; Radius: Integer; ReverseColors: Boolean);
procedure DrawGradientDirection(Canvas: TCanvas; ARect: TRect; Direction: TiFillDirection; ColorStart, ColorStop: TColor);

//Kylix TODO
{$ifndef iCLX}
function FillFontInfo(Font : TFont; Rotation : Integer) : TLogFont;
{$endif}
function GetDecimalPoints(Max, Min : Double; Precision: Integer; PrecisionStyle : TiPrecisionStyle): Integer;

function GetXYRadPoint(AngleDegrees : Double; Radius : Double; Offset : TPoint) : TPoint;
function GetXYRadPointDouble(AngleDegrees : Double; Radius : Double; Offset : TPointDouble) : TPointDouble;

function iFormatPrecisionStyle(Value, Span : Double; Precision : Integer; PrecisionStyle : TiPrecisionStyle) : String;

function PointOrientation(X, Y : Integer; Orientation : TiOrientation) : TPoint;
function RectOrientation(Left, Top, Right, Bottom : Integer; Orientation : TiOrientation) : TRect;

function iPointReverse(Reverse : Boolean; X, Y: Integer) : TPoint;

function TruncHalf(Value : Double) : Integer;
function PointDoubleToPoint(PointDouble : TPointDouble) : TPoint;

procedure ArcSegment(Canvas:TCanvas; StartDegrees, EndDegress : Double; Radius1, Radius2 : Integer; Offset : TPoint; AColor : TColor);

function  GetPropertyValueString(PropName : String; var PropString : String; AList: TStringList): Boolean;
procedure SeparateStrings(AText: String; Seperator : String; var LeftString: String; var RightString: String);
procedure SaveObjectToStringList  (Instance: TPersistent; Path: String; DataList: TStringList; IgnoreList: TStringList);
procedure LoadObjectFromStringList(Instance: TPersistent; Path: String; DataList: TStringList);
function GetObjectProperty(Instance: TPersistent; const PropName: string): TObject;
procedure AssignObject(Source, Destination: TPersistent);

procedure SetParentsToTopMost(AWinControl : TWinControl);
{$ifdef iVCL}procedure SetWindowToControlParent(Handle : THandle; Value : Boolean); {$endif}

function GetCustomFormOwner(AComponent: TComponent): TWinControl;

function  iDrawText       (Canvas: TCanvas; AText : String; var ARect : TRect; AFlags: TiTextFlags): Integer;
function  iDrawRotatedText(Canvas: TCanvas; AText : String; ARect : TRect; Angle: TiRotationAngle): TRect;
procedure iDrawFocusRect  (Canvas: TCanvas; ARect: TRect; BackgroundColor: TColor);
procedure iDrawFocusRect2 (Canvas: TCanvas; ARect: TRect);
procedure iDrawEdge       (Canvas: TCanvas; ARect: TRect; Style: TiDrawEdgeStyle);

procedure iDrawTriangle   (Canvas: TCanvas; ARect: TRect; Direction: TiDirection);

procedure iDrawButtonArrowUp  (Canvas: TCanvas; ARect: TRect; Down: Boolean);
procedure iDrawButtonArrowDown(Canvas: TCanvas; ARect: TRect; Down: Boolean);

function  iTextWidth           (Canvas: TCanvas; AText: String): Integer;
function  iTextHeight          (Canvas: TCanvas; AText: String): Integer;
function  iTextHeightFixedWidth(Canvas: TCanvas; AText: String; FixedWidth: Integer): Integer;

function  iRect(Left, Top, Right, Bottom: Integer): TRect;
function  iXYReverseRect (XYReverse: Boolean; XAxis1, YAxis1, XAxis2, YAxis2: Integer): TRect;
function  iXYReversePoint(XYReverse: Boolean; XAxisValue, YAxisValue: Integer): TPoint;

procedure iRectangle(Canvas: TCanvas; ARect: TRect);

procedure iDecodeDate(const DateTime: TDateTime; var Year, Month, Day: Integer);

function GetShiftDown: Boolean;
function GetCtrlDown : Boolean;
function GetAltDown  : Boolean;

procedure iSetDesigning(AComponent: TComponent);

procedure iAlignVCenterControl(RefControl, AlignControl : TControl);

function DateToMilliSeconds(Value: TDateTime) : Integer;
function DateToSeconds     (Value: TDateTime) : Integer;
function DateToMinutes     (Value: TDateTime) : Integer;
function DateToHours       (Value: TDateTime) : Integer;

procedure WriterWriteProperties(Writer: TWriter; Instance: TPersistent);

function iGetRValue(rgb: DWORD): Byte;
function iGetGValue(rgb: DWORD): Byte;
function iGetBValue(rgb: DWORD): Byte;

procedure SwapIntegers(var Integer1, Integer2 : Integer);

function GetClickRect(const Data: array of TPoint; MinSizePixels: Integer): TRect;

function PointDouble(X, Y: Double): TPointDouble;

function iStrToInt(Value: String): LongWord;
function iIntToStr(Value: LongWord; Format: TiIntegerFormatStyle; MaxLength: Integer; LeadingZeros: Boolean): String;

procedure iSetFocus(WinControl: TWinControl);

procedure SetActivePageIndex(PageControl: TPageControl; Index: Integer);
function GetActivePageIndex (PageControl: TPageControl): Integer;

function GetRectCenterPoint(ARect: TRect): TPoint;
function GetSign(Value: Double): Double;

function ChangeColorIntensity(Value: TColor; RGBOffset: Integer): TColor;

function MMToInches(MMValue: Double):Double;

procedure GetPaperTypePaperSize(PaperType: Smallint; var PaperWidthInches, PaperHeightInches: Double);
procedure GetPrinterPaperSize(var PaperWidthInches, PaperHeightInches: Double);

implementation

type
  TWriterAccess          = class(TWriter    )end;
  TReaderAccess          = class(TReader    )end;
  TPersistentAccess      = class(TPersistent)end;
  TComponentAccess       = class(TComponent )end;
  TCanvasAccess          = class(TCanvas    )end;
//****************************************************************************************************************************************************
function DimColor(Value: TColor; Divisor: Integer): TColor;
var
  Red,Green,Blue : Integer;
begin
  if Divisor > 0 then
    begin
      Red      := (Value  and     $FF)         div Divisor;
      Green    := ((Value and   $FF00) shr 8 ) div Divisor;
      Blue     := ((Value and $FF0000) shr 16) div Divisor;
    end
  else
    begin
      Red      :=  (Value and     $FF)         * -Divisor;
      Green    := ((Value and   $FF00) shr 8 ) * -Divisor;
      Blue     := ((Value and $FF0000) shr 16) * -Divisor;
    end;

  if Red   > 255 then Red   := 255;
  if Green > 255 then Green := 255;
  if Blue  > 255 then Blue  := 255;

  if Red   <   0 then Red   := 0;
  if Green <   0 then Green := 0;
  if Blue  <   0 then Blue  := 0;

  Result := Red + (Green shl 8) + (Blue shl 16);
end;
//*************************************************************************************************************************************
function GetTickCount(DesiredTicks, MaxTicks: Integer; Span: Double): Integer;
var
  x                 : Integer;
  MatchFound        : Boolean;
  NewTickMajorCount : Integer;
  ClosestCount      : Integer;
  Step              : Double;
  StepDivisor       : Double;
begin
  ClosestCount      := 99999;
  NewTickMajorCount := 0;

  for x := 2 to MaxTicks do
    begin
      MatchFound := False;

      Step        := Span/(x-1);
      StepDivisor := (Power(10, Trunc(Log10(Step))));

      if Round(Step/StepDivisor*1000) =  100 then MatchFound := True;
      if Round(Step/StepDivisor*1000) =  200 then MatchFound := True;
      if Round(Step/StepDivisor*1000) =  250 then MatchFound := True;
      if Round(Step/StepDivisor*1000) =  500 then MatchFound := True;
      if Round(Step/StepDivisor*1000) =  750 then MatchFound := True;
      if Round(Step/StepDivisor*1000) = 1000 then MatchFound := True;
      if Round(Step/StepDivisor*1000) = 2000 then MatchFound := True;
      if Round(Step/StepDivisor*1000) = 2500 then MatchFound := True;
      if Round(Step/StepDivisor*1000) = 5000 then MatchFound := True;
      if Round(Step/StepDivisor*1000) = 7500 then MatchFound := True;

      if MatchFound then
        if ABS(DesiredTicks - x) <= ClosestCount then
          begin
            ClosestCount      := ABS(DesiredTicks - x);
            NewTickMajorCount := x;
          end;

    end;

  if ClosestCount < 99999 then Result := NewTickMajorCount else Result := MaxTicks + 1;
end;
//*************************************************************************************************************************************
function GetNewMinMax(ActualTicks: Integer; DesiredMin, DesiredMax: Double; NewRange : Double; var NewMax, NewMin: Double): Boolean;
var
  StepValue  : Double;
  CenterZero : Boolean;
begin
  StepValue  := NewRange /(ActualTicks - 1);
  CenterZero := (DesiredMax > 0) and (DesiredMin < 0);

  if CenterZero then
    begin
      NewMin := NewRange;
      while NewMin > DesiredMin do
        NewMin := NewMin - StepValue;
      NewMax := NewMin + NewRange;
    end
  else
    begin
      if DesiredMax > 0 then
        begin
          NewMax := 0;

          while NewMax < DesiredMax do
            NewMax := NewMax + StepValue;

          NewMin := NewMax - NewRange;
          while (DesiredMin >= 0) and (NewMin < 0) do
            begin
              NewMax := NewMax + StepValue;
              NewMin := NewMin + StepValue;
            end;
        end
      else
        begin
          NewMin := 0;

          while NewMin > DesiredMin do
            NewMin := NewMin - StepValue;

          NewMax := NewMin + NewRange;

          if (DesiredMax <= 0) and (NewMax > 0) then
            begin
              NewMax := NewMax - StepValue;
              NewMin := NewMin - StepValue;
            end;
        end
    end;

  Result := (NewMax >= DesiredMax) and (NewMin <= DesiredMin);
end;
//*************************************************************************************************************************************
function GetNewMinMaxFixed(ActualTicks: Integer; DesiredMin, DesiredMax: Double; NewRange : Double; var NewMax, NewMin: Double): Boolean;
var
  StepValue  : Double;
  CenterZero : Boolean;
  Fail       : Boolean;
begin
  StepValue  := NewRange /(ActualTicks - 1);
  CenterZero := (DesiredMax > 0) and (DesiredMin < 0);

  if CenterZero then
    begin
      NewMin := NewRange;
      while (NewMin >= DesiredMin) do
        NewMin := NewMin - StepValue;
      NewMin := NewMin + StepValue;
      NewMax := NewMin + NewRange;
    end
  else
    begin
      if DesiredMin >= 0 then
        begin
          NewMin := 0;

          while NewMin < DesiredMin do
            NewMin := NewMin + StepValue;

          NewMax := NewMin + NewRange;
        end
      else
        begin
          NewMax := 0;

          while NewMax > DesiredMax do
            NewMax := NewMax - StepValue;

          NewMin := NewMax - NewRange;
        end
    end;

  Fail := False;
  if NewMax > DesiredMax then Fail := True;
  if NewMin < DesiredMin then Fail := True;
  if (NewMax + StepValue) <= DesiredMax then Fail := True;

  Result := not Fail;

  //Result := not((NewMax > DesiredMax) or (NewMin < DesiredMin));
end;
//****************************************************************************************************************************************************
procedure GetAutoScaleValuesAdjustable(DesiredMin, DesiredMax: Double; DesiredTicks, MaxTicks: Integer;