igpfunctions.pas

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

                                       var NewMin: Double; var NewMax: Double; var NewTicks: Integer);
var
  DesiredRange : Extended;
  NewRange     : Double;
  RangeBase    : Double;
  x            : Integer;
begin
  if DesiredMin <> DesiredMax then
    begin
      DesiredRange := ABS(DesiredMax - DesiredMin);

      NewTicks     := DesiredTicks;

      RangeBase := Power(10, Trunc(Log10(DesiredRange)));
      if DesiredRange < 1 then RangeBase := RangeBase/10;

      for x := 2 to 40 do
        begin
          NewRange := RangeBase*0.5*x;
          if (NewRange >= DesiredRange) then
            begin
              NewTicks := GetTickCount(DesiredTicks, MaxTicks, NewRange);
              if (NewTicks <= MaxTicks) then
                if GetNewMinMax(NewTicks, DesiredMin, DesiredMax, NewRange, NewMax, NewMin) then Break;
            end;
        end;
    end
  else
    begin
      NewMin   := DesiredMin;
      NewMax   := DesiredMax;
      NewTicks := 2;
    end;
end;
//****************************************************************************************************************************************************
procedure GetAutoScaleValuesFixed(DesiredMin, DesiredMax: Double; DesiredTicks, MaxTicks: Integer;
                                  var NewMin: Double; var NewMax: Double; var NewTicks: Integer);
var
  DesiredRange : Extended;
  NewRange     : Double;
  RangeBase    : Double;
  x, Y         : Integer;
  Found        : Boolean;

begin
  if DesiredMin <> DesiredMax then
    begin
      DesiredRange := ABS(DesiredMax - DesiredMin);

      NewTicks     := DesiredTicks;
      Found := False;

      RangeBase := Power(10, Trunc(Log10(DesiredRange)));
      if DesiredRange < 1 then RangeBase := RangeBase/10;

      for x := 100 downto 2 do
        begin
          NewRange := RangeBase*0.1*x;
          if (NewRange <= DesiredRange) then
            begin
              for y := MaxTicks downto 2 do
                begin
                  NewTicks := GetTickCount(DesiredTicks, y, NewRange);

                  if (NewTicks <= y) then
                    if GetNewMinMaxFixed(NewTicks, DesiredMin, DesiredMax, NewRange, NewMax, NewMin) then
                      Found := True;
                  if Found then Break;
                end;          
            end;
          if Found then Break;
        end;
    end
  else
    begin
      NewMin   := DesiredMin;
      NewMax   := DesiredMax;
      NewTicks := 2;
    end;
end;
//****************************************************************************************************************************************************
procedure LineBevel(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; Style: TiBevelStyle);
var
  TempInt : Integer;
begin
  with Canvas do
    begin
      if X1 = X2 then
        begin
          if Y1 > Y2 then
            begin
              TempInt := Y1;
              Y1 := Y2;
              Y2 := TempInt;
            end;
          case Style of
            ibsNone    : begin
                           Polyline([Point(X1, Y1),Point(X2, Y2)]);
                         end;
            ibsRaised  : begin
                           Pen.Color := clWhite; Polyline([Point(X1-1, Y1),Point(X2-1, Y2)]);
                           Pen.Color := clWhite; Polyline([Point(X1,   Y1),Point(X2,   Y2)]);
                           Pen.Color := clBlack; Polyline([Point(X1+1, Y1),Point(X2+1, Y2)]);
                         end;
            ibsLowered : begin
                           Pen.Color := clBlack; Polyline([Point(X1-1, Y1),Point(X2-1, Y2)]);
                           Pen.Color := clWhite; Polyline([Point(X1,   Y1),Point(X2,   Y2)]);
                           Pen.Color := clWhite; Polyline([Point(X1+1, Y1),Point(X2+1, Y2)]);
                          end;
          end;
        end
      else
        begin
          if X1 > X2 then
            begin
              TempInt := X1;
              X1 := X2;
              X2 := TempInt;
            end;
          case Style of
            ibsNone    : begin
                           Polyline([Point(X1, Y1),Point(X2, Y2)]);
                         end;
            ibsRaised  : begin
                           Pen.Color := clWhite; Polyline([Point(X1, Y1  ),Point(X2, Y2  )]);
                           Pen.Color := clBlack; Polyline([Point(X1, Y1+1),Point(X2, Y2+1)]);
                         end;
            ibsLowered : begin
                           Pen.Color := clBlack; Polyline([Point(X1, Y1  ),Point(X2, Y2  )]);
                           Pen.Color := clWhite; Polyline([Point(X1, Y1+1),Point(X2, Y2+1)]);
                         end;
          end;
        end;
    end;
end;
//****************************************************************************************************************************************************
procedure Line(Canvas: TCanvas; Left, Top, Right, Bottom: Integer);
begin
  with Canvas do
    begin
      Polyline([Point(Left, Top), Point(Right, Bottom)]);
    end;
end;
//****************************************************************************************************************************************************
function GetDecimalPoints(Max, Min : Double; Precision: Integer; PrecisionStyle : TiPrecisionStyle): Integer;
var
  Span : Double;
begin
  Result := 0;
  case PrecisionStyle of
    ipsSignificantDigits : if Precision > 0 then
                             begin
                               Span := ABS(Max - Min);                                     
                               if Span  <> 0 then Result := Precision - (Trunc(Log10(Span))+1) else Result := 0;
                               if Span   < 1 then Result := Result + 1;
                               if Result < 0 then Result := 0;
                             end;
    ipsFixedDecimalPoints : Result := Precision;
  end;
end;
//****************************************************************************************************************************************************
//Kylix TODO
{$ifndef iCLX}
function FillFontInfo(Font : TFont; Rotation : Integer) : TLogFont;
begin
   with Result do
     begin
       lfHeight         := Font.Height;
       lfWidth          := FW_DONTCARE;
       lfEscapement     := Rotation;
       lfOrientation    := Rotation;
       lfItalic         := Byte(fsItalic    in Font.Style);
       lfUnderline      := Byte(fsUnderline in Font.Style);
       lfStrikeOut      := Byte(fsStrikeOut in Font.Style);
       lfCharSet        := DEFAULT_CHARSET;
       lfPitchAndFamily := VARIABLE_PITCH;
       lfQuality        := DEFAULT_QUALITY;
       lfOutPrecision   := OUT_DEFAULT_PRECIS;
       lfClipPrecision  := CLIP_DEFAULT_PRECIS;
       if fsBold in Font.Style then lfWeight := FW_BOLD else lfWeight := FW_NORMAL;
       StrPCopy(lfFaceName, Font.Name);
     end;
end;
{$endif}
//****************************************************************************************************************************************************
function GetXYRadPoint(AngleDegrees, Radius: Double; Offset : TPoint) : TPoint;
begin
  Result := Point(Offset.x + Round(Cos(DegToRad(AngleDegrees))*Radius),Offset.y - Round(Sin(DegToRad(AngleDegrees))*Radius));
end;
//****************************************************************************************************************************************************
function GetXYRadPointDouble(AngleDegrees : Double; Radius : Double; Offset : TPointDouble) : TPointDouble;
begin
  Result.X := Offset.X + Cos(DegToRad(AngleDegrees))*Radius;
  Result.Y := Offset.Y - Sin(DegToRad(AngleDegrees))*Radius;
end;
//****************************************************************************************************************************************************
function iFormatPrecisionStyle(Value, Span : Double; Precision : Integer; PrecisionStyle : TiPrecisionStyle) : String;
var
  PrecisionString : String;
  PrecisionCount  : Integer;
  x               : Integer;
begin
  PrecisionCount  := GetDecimalPoints(Span, 0, Precision, PrecisionStyle);

  PrecisionString := '';
  for x := 1 to PrecisionCount do
    PrecisionString := PrecisionString + '0';

  Result := Trim(FormatFloat('0.' + PrecisionString, Value));

end;
//****************************************************************************************************************************************************
function PointOrientation(X, Y : Integer; Orientation : TiOrientation) : TPoint;
var
  TempX : Integer;
  TempY : Integer;
begin
  case Orientation of
    ioVertical : begin
                   TempX := X;
                   TempY := Y;
                 end;
    else         begin
                   TempX := Y;
                   TempY := X;
                 end;
  end;
  Result := Point(TempX, TempY);
end;
//****************************************************************************************************************************************************
function RectOrientation(Left, Top, Right, Bottom : Integer; Orientation : TiOrientation) : TRect;
var
  TempLeft   : Integer;
  TempTop    : Integer;
  TempRight  : Integer;
  TempBottom : Integer;
begin
  case Orientation of
    ioVertical : begin
                   TempLeft   := Left;
                   TempTop    := Top;
                   TempRight  := Right;
                   TempBottom := Bottom;
                 end;
    else         begin
                   TempLeft   := Top;
                   TempTop    := Right;
                   TempRight  := Bottom;
                   TempBottom := Left;
                 end;
  end;
  Result := Rect(TempLeft, TempTop, TempRight, TempBottom);
end;
//****************************************************************************************************************************************************
function iDrawText(Canvas: TCanvas; AText : String; var ARect : TRect; AFlags: TiTextFlags): Integer;
var
               TextFlags    : UINT;
  {$ifdef iCLX}AWideString  : WideString;{$endif}
  {$ifdef iCLX}BoundingRect : TRect;{$endif}
begin
  {$ifdef iVCL}
  TextFlags := 0;
  if not (itfShowPrefix   in AFlags) then TextFlags := TextFlags + DT_NOPREFIX;
  if      itfHLeft        in AFlags  then TextFlags := TextFlags + DT_LEFT;
  if      itfHCenter      in AFlags  then TextFlags := TextFlags + DT_CENTER;
  if      itfHRight       in AFlags  then TextFlags := TextFlags + DT_RIGHT;
  if      itfVTop         in AFlags  then TextFlags := TextFlags + DT_TOP;
  if      itfVCenter      in AFlags  then TextFlags := TextFlags + DT_VCENTER;
  if      itfVBottom      in AFlags  then TextFlags := TextFlags + DT_BOTTOM;
  if      itfWordBreak    in AFlags  then TextFlags := TextFlags + DT_WORDBREAK;
  if      itfSingleLine   in AFlags  then TextFlags := TextFlags + DT_SINGLELINE;
  if      itfExpandTabs   in AFlags  then TextFlags := TextFlags + DT_EXPANDTABS;
  if      itfNoClip       in AFlags  then TextFlags := TextFlags + DT_NOCLIP;
  if      itfCalcRect     in AFlags  then TextFlags := TextFlags + DT_CALCRECT;
  if      itfEndEllipsis  in AFlags  then TextFlags := TextFlags + DT_END_ELLIPSIS;
  if      itfPathEllipsis in AFlags  then TextFlags := TextFlags + DT_PATH_ELLIPSIS;
  if      itfWordEllipsis in AFlags  then TextFlags := TextFlags + DT_WORD_ELLIPSIS;
  if      itfModifyString in AFlags  then TextFlags := TextFlags + DT_MODIFYSTRING;

  Result := DrawText(Canvas.Handle, PChar(AText), Length(AText), ARect, TextFlags);
  {$endif}

  {$ifdef iCLX}
  TextFlags := 0;
  if itfHLeft      in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_AlignLeft);
  if itfHCenter    in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_AlignHCenter);
  if itfHRight     in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_AlignRight);
  if itfVTop       in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_AlignTop);
  if itfVCenter    in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_AlignVCenter);
  if itfVBottom    in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_AlignBottom);
  if itfWordBreak  in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_WordBreak);
  if itfSingleLine in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_SingleLine);
  if itfExpandTabs in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_ExpandTabs);
  if itfNoClip     in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_DontClip);
  if itfShowPrefix in AFlags then TextFlags := TextFlags + UINT(AlignmentFlags_ShowPrefix);

  Result := 0;
  AWideString := AText;
  Canvas.Start;
  TCanvasAccess(Canvas).RequiredState([csHandleValid, csFontValid]);
  if itfCalcRect in AFlags then
    begin
      QPainter_boundingRect(Canvas.Handle, @BoundingRect, @ARect, TextFlags, PWideString(@AWideString), -1, nil);
      Result := BoundingRect.Bottom - BoundingRect.Top;
    end
  else
    begin
      QPainter_drawText(Canvas.Handle, @ARect, TextFlags, PWideString(@AWideString), -1, nil, nil);
    end;
  Canvas.Stop;
  {$endif}
end;
//****************************************************************************************************************************************************
function iDrawRotatedText(Canvas: TCanvas; AText : String; ARect : TRect; Angle: TiRotationAngle): TRect;
  var