igpfunctions.pas

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

//****************************************************************************************************************************************************
procedure SetParentsToTopMost(AWinControl : TWinControl);
var
  AControl : TWinControl;
begin
  AControl := AWinControl;
  while (AControl is TWinControl) do
    begin
      {$ifndef iCLX}
      //if not (AControl is TCustomPanel) then
      SetWindowLong(AControl.Handle, GWL_EXSTYLE, GetWindowLong(AControl.Handle, GWL_EXSTYLE) or WS_EX_CONTROLPARENT);
      {$endif}
      AControl := AControl.Parent;
    end;
end;
//****************************************************************************************************************************************************
{$ifdef iVCL}
procedure SetWindowToControlParent(Handle : THandle; Value : Boolean);
begin
  if Value = True then
    begin
      SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_CONTROLPARENT);
    end
  else
    begin
      SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) and (not WS_EX_CONTROLPARENT));
    end;
end;
{$endif}
//****************************************************************************************************************************************************
procedure ArcSegment(Canvas:TCanvas; StartDegrees, EndDegress : Double; Radius1, Radius2 : Integer; Offset : TPoint; AColor : TColor);
var
  Radius1Start      : TPoint;
  Radius1Stop       : TPoint;
  Radius2Start      : TPoint;
  Radius2Stop       : TPoint;
  Degree1           : Double;
  Degree2           : Double;
  PointArray        : array[0..804] of TPoint;
  IndexCount        : Integer;
  StepSize          : Double;
  x                 : Integer;
begin
  with Canvas do
    begin
      Pen.Color   := AColor;
      Brush.Color := AColor;
      IndexCount  := 0;

      if StartDegrees > EndDegress then
        begin
          Degree1 := EndDegress;
          Degree2 := StartDegrees;               
        end
      else
        begin
          Degree1 := StartDegrees;
          Degree2 := EndDegress;
        end;

      Radius1Start := GetXYRadPoint(Degree1, Radius1, Offset);
      Radius1Stop  := GetXYRadPoint(Degree2, Radius1, Offset);
      Radius2Start := GetXYRadPoint(Degree1, Radius2, Offset);
      Radius2Stop  := GetXYRadPoint(Degree2, Radius2, Offset);

      PointArray[IndexCount] := Radius1Start; inc(IndexCount);

      StepSize  := (Degree2 - Degree1)/400;

      for x := 1 to 399 do
        begin
          PointArray[IndexCount] := GetXYRadPoint(Degree1 + x*StepSize, Radius1, Offset);
          inc(IndexCount);
        end;                          

      PointArray[IndexCount] := Radius1Stop; inc(IndexCount);
      if Radius1 <> Radius2 then
        begin
          PointArray[IndexCount] := Radius2Stop; inc(IndexCount);

          for x := 399 downto 1 do
            begin
              PointArray[IndexCount] := GetXYRadPoint(Degree1 + x*StepSize, Radius2, Offset);
              inc(IndexCount);
            end;

          PointArray[IndexCount] := Radius2Start; inc(IndexCount);
          PointArray[IndexCount] := Radius1Start; inc(IndexCount);
                       
          Polygon(Slice(PointArray, IndexCount));
        end
      else Polyline(Slice(PointArray, IndexCount));

    end;
end;
//****************************************************************************************************************************************************
function TruncHalf(Value : Double): Integer;
begin
  Result := Trunc(Value + 0.5);
end;
//****************************************************************************************************************************************************
function PointDoubleToPoint(PointDouble: TPointDouble): TPoint;
begin
  Result := Point(Round(PointDouble.X), Round(PointDouble.Y));
end;
//****************************************************************************************************************************************************
procedure DrawRaisedBorder(Canvas:TCanvas; ARect: TRect);
begin
  with Canvas, ARect do
    begin
      Pen.Color := clBtnShadow;    PolyLine([Point(Left,Bottom-1  ), Point(Left   ,Top     ), Point(Right-1, Top  )]); //Outer
      Pen.Color := clBlack;        PolyLine([Point(Left,Bottom    ), Point(Right  ,Bottom  ), Point(Right  , Top  )]); //Outer

      Pen.Color := clBtnHighlight; PolyLine([Point(Left+1,Bottom-2), Point(Left+1 ,Top+1   ), Point(Right-2, Top+1)]); //Inner
      Pen.Color := clBtnShadow;    PolyLine([Point(Left+1,Bottom-1), Point(Right-1,Bottom-1), Point(Right-1, Top+1)]); //Inner
    end;
end;
//****************************************************************************************************************************************************
procedure DrawSunkenBorder(Canvas:TCanvas; ARect: TRect);
begin
  with Canvas, ARect do
    begin
      Pen.Color := clBtnShadow;    PolyLine([Point(Left,Bottom-1  ), Point(Left   ,Top     ), Point(Right-1, Top  )]); //Outer
      Pen.Color := clBtnHighlight; PolyLine([Point(Left,Bottom    ), Point(Right  ,Bottom  ), Point(Right  , Top  )]); //Outer

      Pen.Color := clBlack;        PolyLine([Point(Left+1,Bottom-2), Point(Left+1 ,Top+1   ), Point(Right-2, Top+1)]); //Inner
      Pen.Color := clBtnShadow;    PolyLine([Point(Left+1,Bottom-1), Point(Right-1,Bottom-1), Point(Right-1, Top+1)]); //Inner
    end;
end;
//****************************************************************************************************************************************************
function DateToMilliSeconds(Value: TDateTime) : Integer;
var
  Hour : Word;
  Min  : Word;
  Sec  : Word;
  MSec : Word;
begin
  DecodeTime(Value, Hour, Min, Sec, MSec);
  Result :=           Trunc(Value) * 24*60*60*1000;
  Result := Result +  Hour *60*60*1000;
  Result := Result +  Min     *60*1000;
  Result := Result +  Sec        *1000;
  Result := Result +  MSec;
  if Result < 0 then Result := High(Integer);
end;
//****************************************************************************************************************************************************
function DateToSeconds(Value: TDateTime) : Integer;
var
  Hour : Word;
  Min  : Word;
  Sec  : Word;
  MSec : Word;
begin
  DecodeTime(Value, Hour, Min, Sec, MSec);
  Result :=           Trunc(Value) * 24*60*60;
  Result := Result +  Hour *60*60;
  Result := Result +  Min     *60;
  Result := Result +  Sec;
  if Result < 0 then Result := High(Integer);
end;
//****************************************************************************************************************************************************
function DateToMinutes(Value: TDateTime) : Integer;
var
  Hour : Word;
  Min  : Word;
  Sec  : Word;
  MSec : Word;
begin
  DecodeTime(Value, Hour, Min, Sec, MSec);
  Result :=           Trunc(Value) * 24*60;
  Result := Result +  Hour *60;
  Result := Result +  Min;
  if Result < 0 then Result := 10000;
end;
//****************************************************************************************************************************************************
function DateToHours(Value: TDateTime) : Integer;
var
  Hour : Word;
  Min  : Word;
  Sec  : Word;           
  MSec : Word;
begin
  DecodeTime(Value, Hour, Min, Sec, MSec);
  Result :=           Trunc(Value) * 24;
  Result := Result +  Hour;
  if Result < 0 then Result := High(Integer);
end;
//****************************************************************************************************************************************************
procedure iDrawFocusRect(Canvas: TCanvas; ARect: TRect; BackgroundColor: TColor);
begin
  with Canvas do
    begin
      Pen.Color   := BackGroundColor;
      Brush.Color := BackGroundColor;
      iDrawFocusRect2(Canvas, ARect)
    end;
end;
//****************************************************************************************************************************************************
procedure iDrawFocusRect2(Canvas: TCanvas; ARect: TRect);
begin
  {$ifndef iCLX}
  Windows.DrawFocusRect(Canvas.Handle, ARect);
  {$else}
  Canvas.DrawFocusRect(ARect);
  {$endif}
end;
//****************************************************************************************************************************************************
procedure iDrawEdge(Canvas: TCanvas; ARect: TRect; Style: TiDrawEdgeStyle);
begin
  {$ifdef iVCL}
  case Style of
    idesSunken  : DrawEdge(Canvas.Handle, ARect, EDGE_SUNKEN, BF_TOPLEFT or BF_BOTTOMRIGHT);
    idesRaised  : DrawEdge(Canvas.Handle, ARect, EDGE_RAISED, BF_TOPLEFT or BF_BOTTOMRIGHT);
    idesFlat    : begin
                    Canvas.Pen.Color := clBtnShadow;
                    Canvas.Pen.Style := psSolid;
                    Canvas.Polygon([Point(ARect.Left, Arect.Top),
                                    Point(ARect.Right-1, ARect.Top),
                                    Point(ARect.Right-1, ARect.Bottom-1),
                                    Point(ARect.Left, ARect.Bottom-1)]);
                  end;
  end;
  {$else}
  case Style of
    idesRaised  : DrawEdge(Canvas,        ARect,  esRaised,  esRaised, [ebLeft, ebRight, ebTop, ebBottom]);
    idesSunken  : DrawEdge(Canvas,        ARect, esLowered, esLowered, [ebLeft, ebRight, ebTop, ebBottom]);
    idesFlat    : begin
                    Canvas.Pen.Color := clBtnShadow;
                    Canvas.Pen.Style := psSolid;
                    Canvas.Polygon([Point(ARect.Left, Arect.Top),
                                    Point(ARect.Right-1, ARect.Top),
                                    Point(ARect.Right-1, ARect.Bottom-1),
                                    Point(ARect.Left, ARect.Bottom-1)]);
                  end;
  end;
  {$endif}
end;
//****************************************************************************************************************************************************
procedure WriterWriteProperties(Writer: TWriter; Instance: TPersistent);
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
begin
  try
    Count := GetTypeData(Instance.ClassInfo)^.PropCount;
    if Count > 0 then
      begin
        GetMem(PropList, Count * SizeOf(Pointer));
        try
          GetPropInfos(Instance.ClassInfo, PropList);
          for I := 0 to Count - 1 do
          begin
            PropInfo := PropList^[I];
            if PropInfo = nil then Continue;
            if IsStoredProp(Instance, PropInfo) and Assigned(PropInfo^.SetProc) and Assigned(PropInfo^.GetProc) then
              TWriterAccess(Writer).WriteProperty(Instance, PropInfo);
          end;
        finally
          FreeMem(PropList, Count * SizeOf(Pointer));
        end;
      end;
    TPersistentAccess(Instance).DefineProperties(Writer);
  except
    on e: Exception do;// raise Exception.Create('WriterWriteProperties Error : ' + e.message);
  end;
end;
//****************************************************************************************************************************************************
procedure iSetDesigning(AComponent: TComponent);
begin
  {$ifdef COMPILER_4}
  TComponentAccess(AComponent).SetDesigning(True);
  {$else}
  TComponentAccess(AComponent).SetDesigning(True, False);
  {$endif}
end;
//****************************************************************************************************************************************************
function iGetRValue(rgb: DWORD): Byte;
begin
  Result := Byte(rgb);
end;
//****************************************************************************************************************************************************
function iGetGValue(rgb: DWORD): Byte;
begin
  Result := Byte(rgb shr 8);
end;
//****************************************************************************************************************************************************
function iGetBValue(rgb: DWORD): Byte;
begin
  Result := Byte(rgb shr 16);
end;
//****************************************************************************************************************************************************
function GetClickRect(const Data: array of TPoint; MinSizePixels: Integer): TRect;
var
  i      : Integer;
  MinX   : Integer;
  MaxX   : Integer;
  MinY   : Integer;
  MaxY   : Integer;
  Center : Integer;
begin
  MinX := High(Integer);
  MinY := High(Integer);
  MaxX := Low(Integer);
  MaxY := Low(Integer);

  for i := 0 to High(Data) do
    begin
      if Data[i].X < MinX then MinX := Data[i].X;
      if Data[i].X > MaxX then MaxX := Data[i].X;
      if Data[i].Y < MinY then MinY := Data[i].Y;
      if Data[i].Y > MaxY then MaxY := Data[i].Y;
    end;

  if (MaxX - MinX) > MinSizePixels then