simplegraph.pas

很不错的绘制矢量图的控件。还有一个使用控件的例子。delphi7以上才可安装

{ NOTE: Vertices are in clockwise order, and the first vertex is at 12 O'clock }
function IntersectLinePolygon(const LineAngle: Extended;
  const Vertices: array of TPoint; Backward: Boolean): TPoint;

  function IntersectEdge(const Center: TPoint;
    V1, V2: Integer; out Intersect: TPoint): Boolean;
  var
    EdgeAngle: Extended;
  begin
    EdgeAngle := LineSlopeAngle(Vertices[V1], Vertices[V2]);
    Result := IntersectLines(Center, LineAngle, Vertices[V1], EdgeAngle, Intersect)
      and IsBetween(Intersect.X, Vertices[V1].X, Vertices[V2].X)
      and IsBetween(Intersect.Y, Vertices[V1].Y, Vertices[V2].Y);
  end;

var
  I: Integer;
  Center: TPoint;
begin
  Center := CenterOfPoints(Vertices);
  if not Backward xor ((LineAngle >= -Pi / 2) and (LineAngle < Pi / 2)) then
  begin
    if IntersectEdge(Center, Low(Vertices), High(Vertices), Result) and
     ((Result.X <> Vertices[Low(Vertices)].X) or (Result.Y <> Vertices[Low(Vertices)].Y))
    then
      Exit;
    for I := High(Vertices) downto Low(Vertices) + 1 do
      if IntersectEdge(Center, I, I-1, Result) then
        Exit;
  end
  else
  begin
    for I := Low(Vertices) to High(Vertices) - 1 do
      if IntersectEdge(Center, I, I+1, Result) then
        Exit;
    if IntersectEdge(Center, High(Vertices), Low(Vertices), Result) then
      Exit;
  end;
  Result := Center;
end;

{ TMemoryHandleStream }

constructor TMemoryHandleStream.Create(MemHandle: THandle);
begin
  fHandle := MemHandle;
  if fHandle <> 0 then Size := GlobalSize(fHandle);
end;

destructor TMemoryHandleStream.Destroy;
begin
  if not fReleaseHandle and (fHandle <> 0) then
  begin
    GlobalUnlock(fHandle);
    if Capacity > Size then
      GlobalReAlloc(fHandle, Size, GMEM_MOVEABLE);
    fHandle := 0; 
  end;
  inherited Destroy;
end;

function TMemoryHandleStream.Realloc(var NewCapacity: Integer): Pointer;
const
  MemoryDelta = $2000; { Must be a power of 2 }
begin
  if (NewCapacity > 0) and (NewCapacity <> Size) then
    NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  Result := Memory;
  if NewCapacity <> Capacity then
  begin
    if NewCapacity = 0 then
    begin
      if fHandle <> 0 then
      begin
        GlobalUnlock(fHandle);
        GlobalFree(fHandle);
        fHandle := 0;
      end;
      Result := nil;
    end
    else
    begin
      if fHandle = 0 then
        fHandle := GlobalAlloc(GMEM_MOVEABLE, NewCapacity)
      else
      begin
        GlobalUnlock(fHandle);
        fHandle := GlobalReAlloc(fHandle, NewCapacity, GMEM_MOVEABLE);
      end;
      Result := GlobalLock(fHandle);
    end;
  end;
end;

{ TGraphScrollBar }

constructor TGraphScrollBar.Create(AOwner: TSimpleGraph; AKind: TScrollBarKind);
begin
  inherited Create;
  fOwner := AOwner;
  fKind := AKind;
  fPageIncrement := 80;
  fIncrement := fPageIncrement div 10;
  fVisible := True;
  fDelay := 10;
  fLineDiv := 4;
  fPageDiv := 12;
  fColor := clBtnHighlight;
  fParentColor := True;
  fUpdateNeeded := True;
  fStyle := ssRegular;
end;

function TGraphScrollBar.IsIncrementStored: Boolean;
begin
  Result := not Smooth;
end;

procedure TGraphScrollBar.Assign(Source: TPersistent);
begin
  if Source is TGraphScrollBar then
  begin
    Visible := TGraphScrollBar(Source).Visible;
    Position := TGraphScrollBar(Source).Position;
    Increment := TGraphScrollBar(Source).Increment;
    DoSetRange(TGraphScrollBar(Source).Range);
  end
  else
    inherited Assign(Source);
end;

procedure TGraphScrollBar.ChangeBiDiPosition;
begin
  if Kind = sbHorizontal then
    if IsScrollBarVisible then
      if not Owner.UseRightToLeftScrollBar then
        Position := 0
      else
        Position := Range;
end;

procedure TGraphScrollBar.CalcAutoRange;
var
  I: Integer;
  NewRange: Integer;
  GraphObject: TGraphObject;
begin
  if Kind = sbHorizontal then
  begin
    NewRange := Owner.SelectionRect.Right + 1;
    for I := Owner.Objects.Count - 1 downto 0 do
    begin
      GraphObject := Owner.Objects[I];
      if GraphObject.Showing and not GraphObject.IsLink then
        with TGraphNode(GraphObject) do
          NewRange := Max(NewRange, Left + Width);
    end;
  end
  else
  begin
    NewRange := Owner.SelectionRect.Bottom + 1;
    for I := Owner.Objects.Count - 1 downto 0 do
    begin
      GraphObject := Owner.Objects[I];
      if GraphObject.Showing and not GraphObject.IsLink then
        with TGraphNode(GraphObject) do
          NewRange := Max(NewRange, Top + Height);
    end;
  end;
  DoSetRange(NewRange + Margin);
end;

function TGraphScrollBar.IsScrollBarVisible: Boolean;
var
  Style: Longint;
begin
  Style := WS_HSCROLL;
  if Kind = sbVertical then Style := WS_VSCROLL;
  Result := (Visible) and
            (GetWindowLong(Owner.Handle, GWL_STYLE) and Style <> 0);
end;

function TGraphScrollBar.ControlSize(ControlSB, AssumeSB: Boolean): Integer;
var
  BorderAdjust: Integer;

  function ScrollBarVisible(Code: Word): Boolean;
  var
    Style: Longint;
  begin
    Style := WS_HSCROLL;
    if Code = SB_VERT then Style := WS_VSCROLL;
    Result := GetWindowLong(Owner.Handle, GWL_STYLE) and Style <> 0;
  end;

  function Adjustment(Code, Metric: Word): Integer;
  begin
    Result := 0;
    if not ControlSB then
      if AssumeSB and not ScrollBarVisible(Code) then
        Result := -(GetSystemMetrics(Metric) - BorderAdjust)
      else if not AssumeSB and ScrollBarVisible(Code) then
        Result := GetSystemMetrics(Metric) - BorderAdjust;
  end;

begin
  BorderAdjust := Integer(GetWindowLong(Owner.Handle, GWL_STYLE) and
    (WS_BORDER or WS_THICKFRAME) <> 0);
  if Kind = sbVertical then
    Result := Owner.ClientHeight + Adjustment(SB_HORZ, SM_CXHSCROLL) else
    Result := Owner.ClientWidth + Adjustment(SB_VERT, SM_CYVSCROLL);
end;

function TGraphScrollBar.GetScrollPos: Integer;
begin
  Result := 0;
  if Visible then Result := Position;
end;

function TGraphScrollBar.NeedsScrollBarVisible: Boolean;
begin
  Result := fRange > ControlSize(False, False);
end;

procedure TGraphScrollBar.ScrollMessage(var Msg: TWMScroll);
var
  Incr, FinalIncr, Count: Integer;
  CurrentTime, StartTime, ElapsedTime: Longint;

  function GetRealScrollPosition: Integer;
  var
    SI: TScrollInfo;
    Code: Integer;
  begin
    SI.cbSize := SizeOf(TScrollInfo);
    SI.fMask := SIF_TRACKPOS;
    Code := SB_HORZ;
    if fKind = sbVertical then Code := SB_VERT;
    Result := Msg.Pos;
    if FlatSB_GetScrollInfo(Owner.Handle, Code, SI) then
      Result := SI.nTrackPos;
  end;

begin
  with Msg do
  begin
    if fSmooth and (ScrollCode in [SB_LINEUP, SB_LINEDOWN, SB_PAGEUP, SB_PAGEDOWN]) then
    begin
      case ScrollCode of
        SB_LINEUP, SB_LINEDOWN:
          begin
            Incr := fIncrement div fLineDiv;
            FinalIncr := fIncrement mod fLineDiv;
            Count := fLineDiv;
          end;
        SB_PAGEUP, SB_PAGEDOWN:
          begin
            Incr := FPageIncrement;
            FinalIncr := Incr mod fPageDiv;
            Incr := Incr div fPageDiv;
            Count := fPageDiv;
          end;
      else
        Count := 0;
        Incr := 0;
        FinalIncr := 0;
      end;
      CurrentTime := 0;
      while Count > 0 do
      begin
        StartTime := GetTickCount;
        ElapsedTime := StartTime - CurrentTime;
        if ElapsedTime < fDelay then Sleep(fDelay - ElapsedTime);
        CurrentTime := StartTime;
        case ScrollCode of
          SB_LINEUP: SetPosition(fPosition - Incr);
          SB_LINEDOWN: SetPosition(fPosition + Incr);
          SB_PAGEUP: SetPosition(fPosition - Incr);
          SB_PAGEDOWN: SetPosition(fPosition + Incr);
        end;
        Owner.Update;
        Dec(Count);
      end;
      if FinalIncr > 0 then
      begin
        case ScrollCode of
          SB_LINEUP: SetPosition(fPosition - FinalIncr);
          SB_LINEDOWN: SetPosition(fPosition + FinalIncr);
          SB_PAGEUP: SetPosition(fPosition - FinalIncr);
          SB_PAGEDOWN: SetPosition(fPosition + FinalIncr);
        end;
      end;
    end
    else
      case ScrollCode of
        SB_LINEUP: SetPosition(fPosition - fIncrement);
        SB_LINEDOWN: SetPosition(fPosition + fIncrement);
        SB_PAGEUP: SetPosition(fPosition - ControlSize(True, False));
        SB_PAGEDOWN: SetPosition(fPosition + ControlSize(True, False));
        SB_THUMBPOSITION:
            if fCalcRange > 32767 then
              SetPosition(GetRealScrollPosition) else
              SetPosition(Pos);
        SB_THUMBTRACK:
          if Tracking then
            if fCalcRange > 32767 then
              SetPosition(GetRealScrollPosition) else
              SetPosition(Pos);
        SB_TOP: SetPosition(0);
        SB_BOTTOM: SetPosition(fCalcRange);
        SB_ENDSCROLL: begin end;
      end;
  end;
end;

procedure TGraphScrollBar.SetButtonSize(Value: Integer);
const
  SysConsts: array[TScrollBarKind] of Integer = (SM_CXHSCROLL, SM_CXVSCROLL);
var
  NewValue: Integer;
begin
  if Value <> ButtonSize then
  begin
    NewValue := Value;
    if NewValue = 0 then
      Value := GetSystemMetrics(SysConsts[Kind]);
    fButtonSize := Value;
    fUpdateNeeded := True;
    Owner.UpdateScrollBars;
    if NewValue = 0 then
      fButtonSize := 0;
  end;
end;

procedure TGraphScrollBar.SetColor(Value: TColor);
begin
  if Value <> Color then
  begin
    fColor := Value;
    fParentColor := False;
    fUpdateNeeded := True;
    Owner.UpdateScrollBars;
  end;
end;

procedure TGraphScrollBar.SetParentColor(Value: Boolean);
begin
  if ParentColor <> Value then
  begin
    fParentColor := Value;
    if Value then Color := clBtnHighlight;
  end;
end;

procedure TGraphScrollBar.SetPosition(Value: Integer);
var
  Code: Word;
  Form: TCustomForm;
  OldPos: Integer;
begin
  if csReading in Owner.ComponentState then
    fPosition := Value
  else
  begin
    if Value > fCalcRange then
      Value := fCalcRange
    else if Value < 0 then
      Value := 0;
    if Kind = sbHorizontal then
      Code := SB_HORZ
    else
      Code := SB_VERT;
    if Value <> FPosition then
    begin
      OldPos := FPosition;
      fPosition := Value;
      if Kind = sbHorizontal then
        Owner.ScrollBy(OldPos - Value, 0)
      else
        Owner.ScrollBy(0, OldPos - Value);
      if csDesigning in Owner.ComponentState then
      begin
        Form := GetParentForm(Owner);
        if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
      end;
    end;
    if FlatSB_GetScrollPos(Owner.Handle, Code) <> fPosition then
      FlatSB_SetScrollPos(Owner.Handle, Code, fPosition, True);
    Owner.CalcVisibleBounds;
  end;
end;

procedure TGraphScrollBar.SetSize(Value: Integer);
const
  SysConsts: array[TScrollBarKind] of Integer = (SM_CYHSCROLL, SM_CYVSCROLL);
var