simplegraph.pas

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

  NewValue: Integer;
begin
  if Value <> Size then
  begin
    NewValue := Value;
    if NewValue = 0 then
      Value := GetSystemMetrics(SysConsts[Kind]);
    fSize := Value;
    fUpdateNeeded := True;
    Owner.UpdateScrollBars;
    if NewValue = 0 then
      fSize := 0;
  end;
end;

procedure TGraphScrollBar.SetStyle(Value: TScrollBarStyle);
begin
  if Style <> Value then
  begin
    fStyle := Value;
    fUpdateNeeded := True;
    Owner.UpdateScrollBars;
  end;
end;

procedure TGraphScrollBar.SetThumbSize(Value: Integer);
begin
  if ThumbSize <> Value then
  begin
    fThumbSize := Value;
    fUpdateNeeded := True;
    Owner.UpdateScrollBars;
  end;
end;

procedure TGraphScrollBar.DoSetRange(Value: Integer);
var
  NewRange: Integer;
begin
  if Value <= 0 then
    NewRange := 0
  else
    NewRange := MulDiv(Value, Owner.Zoom, 100);
  if fRange <> NewRange then
  begin
    fRange := NewRange;
    Owner.UpdateScrollBars;
  end;
end;

procedure TGraphScrollBar.SetVisible(Value: Boolean);
begin
  if fVisible <> Value then
  begin
    fVisible := Value;
    Owner.UpdateScrollBars;
  end;
end;

procedure TGraphScrollBar.Update(ControlSB, AssumeSB: Boolean);
type
  TPropKind = (pkStyle, pkButtonSize, pkThumbSize, pkSize, pkBkColor);
const
  Kinds: array[TScrollBarKind] of Integer = (WSB_PROP_HSTYLE, WSB_PROP_VSTYLE);
  Styles: array[TScrollBarStyle] of Integer = (FSB_REGULAR_MODE,
    FSB_ENCARTA_MODE, FSB_FLAT_MODE);
  Props: array[TScrollBarKind, TPropKind] of Integer = (
    { Horizontal }
    (WSB_PROP_HSTYLE, WSB_PROP_CXHSCROLL, WSB_PROP_CXHTHUMB, WSB_PROP_CYHSCROLL,
     WSB_PROP_HBKGCOLOR),
    { Vertical }
    (WSB_PROP_VSTYLE, WSB_PROP_CYVSCROLL, WSB_PROP_CYVTHUMB, WSB_PROP_CXVSCROLL,
     WSB_PROP_VBKGCOLOR));
var
  Code: Word;
  ScrollInfo: TScrollInfo;

  procedure UpdateScrollProperties(Redraw: Boolean);
  begin
    FlatSB_SetScrollProp(Owner.Handle, Props[Kind, pkStyle], Styles[Style], Redraw);
    if ButtonSize > 0 then
      FlatSB_SetScrollProp(Owner.Handle, Props[Kind, pkButtonSize], ButtonSize, False);
    if ThumbSize > 0 then
      FlatSB_SetScrollProp(Owner.Handle, Props[Kind, pkThumbSize], ThumbSize, False);
    if Size > 0 then
      FlatSB_SetScrollProp(Owner.Handle, Props[Kind, pkSize], Size, False);
    FlatSB_SetScrollProp(Owner.Handle, Props[Kind, pkBkColor],
      ColorToRGB(Color), False);
  end;

begin
  fCalcRange := 0;
  Code := SB_HORZ;
  if Kind = sbVertical then Code := SB_VERT;
  if Visible then
  begin
    fCalcRange := Range - ControlSize(ControlSB, AssumeSB);
    if fCalcRange < 0 then fCalcRange := 0;
  end;
  ScrollInfo.cbSize := SizeOf(ScrollInfo);
  ScrollInfo.fMask := SIF_ALL;
  ScrollInfo.nMin := 0;
  if fCalcRange > 0 then
    ScrollInfo.nMax := Range else
    ScrollInfo.nMax := 0;
  ScrollInfo.nPage := ControlSize(ControlSB, AssumeSB) + 1;
  ScrollInfo.nPos := fPosition;
  ScrollInfo.nTrackPos := fPosition;
  UpdateScrollProperties(fUpdateNeeded);
  fUpdateNeeded := False;
  FlatSB_SetScrollInfo(Owner.Handle, Code, ScrollInfo, True);
  SetPosition(fPosition);
  fPageIncrement := (ControlSize(True, False) * 9) div 10;
  if Smooth then fIncrement := fPageIncrement div 10;
end;

{ TGraphObject }

constructor TGraphObject.Create(AOwner: TSimpleGraph);
begin
  fState := osCreating; // Owner should reset the state
  fIsLink := (Self is TGraphLink);
  fID := AOwner.GetUniqueID(1);
  inherited Create;
  fOwner := AOwner;
  fFont := TFont.Create;
  fFont.OnChange := StyleChanged;
  fBrush := TBrush.Create;
  fBrush.OnChange := StyleChanged;
  fPen := TPen.Create;
  fPen.OnChange := StyleChanged;
  fVisible := True;
  SyncFontToParent;
end;

destructor TGraphObject.Destroy;
begin
  State := osDestroying;
  fPen.Free;
  fBrush.Free;
  fFont.Free;
  inherited Destroy;
end;

procedure TGraphObject.InitializeInstance;
begin
  // Nothing to do
end;

procedure TGraphObject.LocateLinkedObjects(StartIndex: Integer);
begin
  // Nothing to do
end;

procedure TGraphObject.CalculateTextParameters;
begin
  // Nothing to do
end;

function TGraphObject.VerifyLinkedObjects: Boolean;
begin
  Result := True;
end;

function TGraphObject.ChangeLinkedObject(OldObject, NewObject: TGraphObject): Boolean;
begin
  Result := True;
end;

procedure TGraphObject.Changed(DataModified: Boolean);
begin
  if State = osNone then
    Owner.ObjectChanged(Self, DataModified);
end;

function TGraphObject.IsFontStored: Boolean;
begin
  Result := not ParentFont;
end;

procedure TGraphObject.SetFont(Value: TFont);
begin
  Font.Assign(Value);
end;

procedure TGraphObject.SetParentFont(Value: Boolean);
begin
  if ParentFont <> Value then
  begin
    fParentFont := Value;
    if ParentFont then
      SyncFontToParent;
    Changed(True);
  end;
end;

procedure TGraphObject.SetBrush(Value: TBrush);
begin
  Brush.Assign(Value);
end;

procedure TGraphObject.SetPen(Value: TPen);
begin
  Pen.Assign(Value);
end;

procedure TGraphObject.SetText(const Value: String);
begin
  if Text <> Value then
  begin
    fText := Value;
    CalculateTextParameters(True, 0, 0);
    Changed(True);
  end;
end;

procedure TGraphObject.SetDragging(Value: Boolean);
begin
  if Dragging <> Value then
  begin
    fDragging := Value;
    Changed(False);
  end;
end;

function TGraphObject.GetZOrder: Integer;
begin
  Result := Owner.Objects.IndexOf(Self);
end;

procedure TGraphObject.SetZOrder(Value: Integer);
begin
  if (Value < 0) or (Value >= Owner.Objects.Count) then
    Value := Owner.Objects.Count - 1;
  Owner.Objects.Move(ZOrder, Value);
end;

procedure TGraphObject.SetState(Value: TGraphObjectState);
var
  OldState: TGraphObjectState;
begin
  if State <> Value then
  begin
    if State = osCreating then
      Owner.Objects.Add(Self);
    OldState := State;
    fState := Value;
    if State = osDestroying then
      Owner.Objects.Remove(Self)
    else if (State = osNone) and (OldState in [osCreating, osReading]) then
      InitializeInstance;
  end;
end;

procedure TGraphObject.SetSelected(Value: Boolean);
begin
  if Selected <> Value then
  begin
    fSelected := Value;
    if Selected then
      Owner.SelectedObjects.Add(Self)
    else
      Owner.SelectedObjects.Remove(Self)
  end;
end;

procedure TGraphObject.SetVisible(Value: Boolean);
begin
  if Visible <> Value then
  begin
    fVisible := Value;
    Changed(True);
  end;
end;

procedure TGraphObject.StyleChanged(Sender: TObject);
begin
  if Sender <> Font then
    Changed(True)
  else
  begin
    CalculateTextParameters(True, 0, 0);
    if not InSyncFont then
    begin
      fParentFont := False;
      Changed(True);
    end
    else
      fParentFont := True;
  end;
end;

function TGraphObject.GetShowing: Boolean;
begin
  Result := (State = osNone) and (Visible or Owner.ShowHiddenObjects);
end;

function TGraphObject.IsVisibleOn(Canvas: TCanvas): Boolean;
var
  Rect: TRect;
  Grow: Integer;
begin
  if Showing then
    if Canvas = Owner.Canvas then
    begin
      Rect := BoundsRect;
      Grow := Pen.Width;
      if Selected then
        Inc(Grow, Owner.MarkerSize);
      InflateRect(Rect, Grow, Grow);
      Result := IntersectRect(Rect, Rect, Owner.VisibleBounds);
    end
    else
      Result := True
  else
    Result := False;
end;

procedure TGraphObject.SyncFontToParent;
begin
  InSyncFont := True;
  try
    Font.Assign(Owner.Font);
  finally
    InSyncFont := False;
  end;
end;

procedure TGraphObject.BringToFront;
begin
  ZOrder := MaxInt;
end;

procedure TGraphObject.SendToBack;
begin
  ZOrder := 0;
end;

procedure TGraphObject.Assign(Source: TPersistent);
begin
  if Source is TGraphObject then
  begin
    Owner.BeginUpdate;
    try
      Text := TGraphObject(Source).Text;
      Brush := TGraphObject(Source).Brush;
      Pen := TGraphObject(Source).Pen;
      Font := TGraphObject(Source).Font;
      ParentFont := TGraphObject(Source).ParentFont;
      Visible := TGraphObject(Source).Visible;
      Tag := TGraphObject(Source).Tag;
    finally
      Owner.EndUpdate;
    end;
  end
  else
    inherited Assign(Source);
end;

procedure TGraphObject.Draw(Canvas: TCanvas);
begin
  if IsVisibleOn(Canvas) then
  begin
    Canvas.Brush := Brush;
    Canvas.Pen := Pen;
    DrawBody(Canvas);
    if Text <> '' then
    begin
      Canvas.Brush.Style := bsClear;
      Canvas.Font := Font;
      DrawText(Canvas);
    end;
  end;
end;

function TGraphObject.ConvertTo(AnotherClass: TGraphObjectClass): Boolean;
begin
  Result := False;
  if (AnotherClass <> nil) and (ClassType <> AnotherClass) then
    Result := Owner.ChangeObjectClass(Self, AnotherClass);
end;

procedure TGraphObject.LoadFromStream(Stream: TStream);
var
  Streamable: TGraphStreamableObject;
begin
  State := osReading;
  try
    Streamable := TGraphStreamableObject.Create(nil);
    try
      Streamable.G := Self;
      Stream.ReadComponent(Streamable);
      Self.OldID := Streamable.ID;
      Self.ID := Owner.GetUniqueID(Streamable.ID);
    finally