zoomer.pas

一个比较完整的读写dxf文件的DELPHI程序

    ClientArea.Canvas.Brush.Style := bsclear;
    ClientArea.Canvas.Rectangle(Ini_Point.X,Ini_Point.Y,Old_Point.X,Old_Point.Y);
    restore_canvas_stuff;
    // Look if the rectangle is big enough...
    if (abs(Ini_Point.X-Old_Point.X) > MIN_RECT) and
       (abs(Ini_Point.Y-Old_Point.Y) > MIN_RECT) then {If Zoom is too small-> No_Zoom}
    begin
      // Look for the correct rectangle!!!!
      if (Ini_Point.X > Old_Point.X) then begin lr.x:=Ini_Point.X; ul.x:=Old_Point.X; end
      else begin lr.x:=Old_Point.X; ul.x:=Ini_Point.X; end;
      if (Ini_Point.Y > Old_Point.Y) then begin lr.Y:=Ini_Point.Y; ul.Y:=Old_Point.Y; end
      else begin lr.Y:=Old_Point.Y; ul.Y:=Ini_Point.Y; end;
      uln:=Screen_To_Real(ul);
      lrn:=Screen_To_Real(lr);
      ReSet_Parameters(uln.x, lrn.x, lrn.y, uln.y);
      ClientArea.Refresh;
    end;
  end;
  if Assigned(FOnMouseUp) then FOnMouseUp(Sender,Button,Shift,X,Y);
end;

procedure Zoom_panel.Mouse_Move(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var s1,s2 : string;
    ul,lr : Point2D;
begin
  if not initialized then exit;
  if Zooming_rect Then begin
    save_canvas_stuff;
    ClientArea.canvas.pen.style   := psDashDotDot;
    ClientArea.canvas.pen.mode    := pmNotXor;
    ClientArea.canvas.pen.width   := 1;
    ClientArea.canvas.pen.color   := clRed;
    ClientArea.Canvas.Brush.Style := bsclear;
    // Erase old rectangle
    ClientArea.canvas.rectangle(Ini_Point.X, Ini_Point.Y, Old_Point.X, Old_Point.y);
    // Draw New Rect
    ClientArea.canvas.rectangle(Ini_Point.X, Ini_Point.Y, X, Y);
    restore_canvas_stuff;
    // Update values
    Old_Point.X := X;
    Old_Point.y := y;
  end;
  // Update position label
  ul := screen_to_real(Point(x,y));
  s1 := FloatTostrF(ul.x,ffFixed,8,3);
  s2 := FloatTostrF(ul.y,ffFixed,8,3);
  Coords.Caption := 'X= '+s1+'   Y= '+s2;
  If Assigned(FOnMouseMove) then FOnMouseMove(Sender,Shift,X,Y);
end;

procedure Zoom_panel.Zoom_Prev;
 Begin
  Current_Params:=Previous_Params;
  Reset_ScrollParams;
  Refresh;
end;

procedure Zoom_panel.DblClick(Sender:TObject);
Begin
  recentre(Ini_Point.x,Ini_Point.Y);
  inherited DblClick;
End;
///////////////////////////////////////////////////////////////////////////////
// Scrolling and recentring
///////////////////////////////////////////////////////////////////////////////
procedure Zoom_panel.ScrollBars_Scroll(Sender:TObject; ScrollCode:TScrollCode; var ScrollPos:Integer);
var cx,cy,moved : Double;
begin
  if scrollpos<>(Sender as TScrollbar).position then with current_params do begin
    if sender=scrollbar_lr then begin
      cx   := xmid;
      moved := ScrollPos - scrollbar_lr.position;
      if (Abs(moved)=Scrollbar_lr.largeChange) then begin
        moved := (moved*(Original_Params.xmax - Original_Params.xmin))/ MAX_SCROLL;
        xmid := xmid + round((moved - (moved/SCROLL_OVERLAPPING)));
      end
      else Xmid:=xmid + moved;
      xmin := xmin - (cx-xmid);
      xmax := xmax - (cx-xmid);
    end;
    if sender=scrollbar_ud then begin
      cy   := ymid;
      moved := ScrollPos - scrollbar_ud.position;
      if (Abs(moved)=Scrollbar_ud.largeChange) then begin
        moved := -(moved*(Original_Params.ymax - Original_Params.ymin))/ MAX_SCROLL;
        ymid := ymid + round((moved - (moved/SCROLL_OVERLAPPING)));
      end
      else Ymid:=ymid - moved;
      ymin := ymin - (cy-ymid);
      ymax := ymax - (cy-ymid);
    end;
    Reset_ScrollParams;
    Refresh;
  end;
end;

procedure Zoom_panel.ReCentre(mx,my:integer); // screen coords (mouse)
var mid   : Point2D;
    xt,yt : double;
begin
  if not initialized then exit;
  mid := screen_to_real(Point(mx,my));
  Previous_Params := Current_Params;
  with current_params do begin
    xmid   := mid.x;
    ymid   := mid.y;
    xt     := (xmax-xmin)*xscale;
    yt     := (ymax-ymin)*yscale;
    xmax   := xmid + (xt/xscale)/2;
    xmin   := xmid - (xt/xscale)/2;
    ymax   := ymid + (yt/yscale)/2;
    ymin   := ymid - (yt/yscale)/2;
  end;
  Reset_ScrollParams;
  ClientArea.Refresh;
end;
///////////////////////////////////////////////////////////////////////////////
// Section dealing with Zooming in/out
///////////////////////////////////////////////////////////////////////////////
procedure Zoom_panel.Zoom(factor:double);
var xmid,ymid,xt,yt,t1,t2 : double;
begin
  if not initialized then exit;
  Previous_params := Current_params;
  with current_params do begin
    xmid   := (xmin+xmax) / 2;
    ymid   := (ymin+ymax) / 2;
    xt     := (xmax-xmin)*xscale;
    yt     := (ymax-ymin)*yscale;
    xscale := xscale / factor;
    yscale := yscale / factor;
    xmax   := xmid + (xt/xscale)/2;
    xmin   := xmid - (xt/xscale)/2;
    ymax   := ymid + (yt/yscale)/2;
    ymin   := ymid - (yt/yscale)/2;
    t1     := xscale/original_params.xscale;
    if t1<0.999 then begin
      t1 := 1;
      t2 := original_params.xscale/xscale;
    end else t2:=1;
    Zoomtext.Caption :=   FloatToStrF(t1, ffGeneral, 3 ,2 )+' : '
                        + FloatToStrF(t2, ffGeneral, 3 ,2 );
  end;
  Reset_ScrollParams;
  ClientArea.Refresh;
end;

procedure Zoom_panel.Zoom_in_out(Sender:TObject);
var temp : params;
begin
  if not initialized then exit;
  if Sender=zoom_out_button then begin
    zoom(zoom_factor);
    If Assigned(FOnZoomout) then FOnZoomout(self);
  end
  else if Sender=zoom_in_button then begin
    zoom(1/zoom_factor);
    If Assigned(FOnZoomin) then FOnZoomin(self);
  end
  else if Sender=zoomresetbutton then begin
    temp := Current_params;
    current_params := original_params;
    Zoom(1);
    Previous_params := temp;
    If Assigned(FOnZoomreset) then FOnZoomreset(self);
  end;
end;

procedure Zoom_panel.Zoom_last(Sender:TObject);
begin
  Zoom_prev;
end;

procedure Zoom_panel.Zoom_mousedown(Sender:TObject; Button:TMouseButton; Shift:TShiftState; X,Y:Integer);
begin
  if Sender=zoom_in_button then begin
    zooming_in := true; zooming_out := false;
    zoomtimer.enabled := true;
    zoomtimer.Interval := 500;   // initial pause of 0.5 seconds
    Zoom_in_out(zoom_in_button);
  end
  else if Sender=zoom_out_button then begin
    zooming_out := true; zooming_in := false;
    zoomtimer.enabled := true;
    zoomtimer.Interval := 500;   // initial pause of 0.5 seconds
    Zoom_in_out(zoom_out_button);
  end;
end;

procedure Zoom_panel.Zoom_mouseup(Sender:TObject; Button:TMouseButton; Shift:TShiftState; X,Y:Integer);
begin
  zooming_in        := false;
  zooming_out       := false;
  zoomtimer.enabled := false;
end;

procedure Zoom_panel.Zoom_timer_event(Sender:TObject);
begin
  zoomtimer.Interval := 25;   // now go for speedy zooming
  if zooming_in then Zoom_in_out(zoom_in_button)
  else if zooming_out then Zoom_in_out(zoom_out_button);
end;
///////////////////////////////////////////////////////////////////////////////
// Initialization of window, scaling etc.
///////////////////////////////////////////////////////////////////////////////
procedure Zoom_panel.set_parameters(xmn,xmx,ymn,ymx:double; xm,ym:integer);
var tempx,tempy : integer;
begin
  with original_params do begin
    tempx := ClientArea.Width  -2*xm;
    tempy := ClientArea.Height -2*ym;
    if tempx<tempy then begin
      if (xmx-xmn)<>0 then xscale := tempx/(xmx-xmn)
      else xscale := 1;
      if (ymx-ymn)<>0 then yscale := tempx/(ymx-ymn)
      else yscale := 1;
    end else begin
      if (xmx-xmn)<>0 then xscale := tempy/(xmx-xmn)
      else xscale := 1;
      if (ymx-ymn)<>0 then yscale := tempy/(ymx-ymn)
      else yscale := 1;
    end;
    if xscale<yscale then yscale:=xscale else xscale:=yscale;
    xmid := (xmx+xmn)/2;
    ymid := (ymx+ymn)/2;
    xmin := xmid - (ClientArea.Width/2)/xscale;
    xmax := xmid + (ClientArea.Width/2)/xscale;
    ymin := ymid - (ClientArea.Height/2)/yscale;
    ymax := ymid + (ClientArea.Height/2)/yscale;
  end;
  current_params := original_params;
  initialized    := true;
end;

// Used when zooming by rectangle.
Procedure Zoom_panel.ReSet_Parameters(xmn, xmx, ymn, ymx:Double);
var tempx,tempy : integer;
    t1,t2       : double;
begin
  Previous_Params:=Current_Params;
  with current_params do begin
    tempx := ClientArea.Width;
    tempy := ClientArea.Height;
    if tempx<tempy then begin
      if (xmx-xmn)<>0 then xscale := tempx/(xmx-xmn)
      else xscale := 1;
      if (ymx-ymn)<>0 then yscale := tempx/(ymx-ymn)
      else yscale := 1;
    end else begin
      if (xmx-xmn)<>0 then xscale := tempy/(xmx-xmn)
      else xscale := 1;
      if (ymx-ymn)<>0 then yscale := tempy/(ymx-ymn)
      else yscale := 1;
    end;
      if xscale<yscale then yscale:=xscale else xscale:=yscale;
    xmid := (xmx+xmn) / 2;
    ymid := (ymx+ymn) / 2;
    xmin := xmid - (ClientArea.Width/2)/xscale;
    xmax := xmid + (ClientArea.Width/2)/xscale;
    ymin := ymid - (ClientArea.Height/2)/yscale;
    ymax := ymid + (ClientArea.Height/2)/yscale;
    t1     := xscale/original_params.xscale;
    if t1<0.999 then begin
      t1 := 1;
      t2 := original_params.xscale/xscale;
    end else t2:=1;
    Zoomtext.Caption :=   FloatToStrF(t1, ffGeneral, 3 ,2 )+' : '
                        + FloatToStrF(t2, ffGeneral, 3 ,2 );
  end;
  Reset_ScrollParams;
end;

Procedure Zoom_panel.Calc_Rect(Var xmn, xmx, ymn, ymx:Double); //!!! Not used yet
var tempx,tempy,xmid,ymid : Double;
    Xscale,YScale:Single;
begin
  tempx := ClientArea.Width;
  tempy := ClientArea.Height;
  if (xmx <> xmn) then xscale:= tempx/abs(xmx-xmn)
  else xscale :=1;
  if (ymx <>ymn) then yscale:= tempy/abs(ymx-ymn)
  else Yscale:=1;
  // look for the most similar value of ClientArea size
  if (xscale < yscale) then // Xscale is the good one
    if ymn > ymx Then ymx:=round(ymn-tempy/xscale)
    else ymx:=round(ymn+tempy/xscale)
  else
    if xmn > xmx then xmx:=round(xmn-tempx/yscale)
    else xmx:=round(xmn+tempx/yscale);
end;

procedure Zoom_panel.ReSet_ScrollParams;
begin
  with Current_Params do begin
    ScrollBar_lr.LargeChange:=round(
     Max_Scroll*(XMax-XMin)/(Original_Params.XMax-Original_Params.XMin));

    ScrollBar_lr.Position:=round(
     ((XMid-Original_params.Xmin)/(Original_Params.Xmax-Original_Params.XMin))* MAX_SCROLL );

    ScrollBar_ud.LargeChange:=round(
     Max_Scroll*(YMax-YMin)/(Original_Params.YMax-Original_Params.YMin));

    ScrollBar_ud.Position:=MAX_SCROLL-round(
    ((YMid-Original_params.Ymin)/(Original_Params.Ymax-Original_Params.YMin))* MAX_SCROLL );
  end;
end;
///////////////////////////////////////////////////////////////////////////////
// save/restore canvas properties
///////////////////////////////////////////////////////////////////////////////
procedure Zoom_panel.save_canvas_stuff;
begin
  Old_PenStyle   := ClientArea.Canvas.Pen.Style;
  Old_PenMode    := ClientArea.Canvas.Pen.Mode;
  Old_PenWidth   := ClientArea.Canvas.Pen.Width;
  Old_PenColor   := ClientArea.Canvas.Pen.Color;
  Old_BrushStyle := ClientArea.Canvas.Brush.Style;
end;

procedure Zoom_panel.restore_canvas_stuff;
begin
  ClientArea.Canvas.pen.mode    := Old_PenMode;
  ClientArea.Canvas.pen.style   := Old_PenStyle;
  ClientArea.Canvas.pen.Width   := Old_PenWidth;
  ClientArea.Canvas.Pen.Color   := Old_PenColor;
  ClientArea.Canvas.Brush.Style := Old_BrushStyle;
end;
///////////////////////////////////////////////////////////////////////////////
// Coordinate transformations
///////////////////////////////////////////////////////////////////////////////
function Zoom_panel.real_to_screen(P:Point3D; OCS:pMatrix) : TPoint;
var tc : Point3D;
begin
 try
  with current_params do begin
    if OCS=nil then begin
      result.x := round(( P.x - xmin )*xscale);
      result.y := round(( ymax - P.y )*yscale);
    end
    else begin
      tc := TransformPoint(OCS^,P);
      result.x := round(( tc.x - xmin )*xscale);
      result.y := round(( ymax - tc.y )*yscale);
    end;
  end;
  except
   On Exception Do Zoom_Prev;
 end;
end;

function Zoom_panel.screen_to_real(P1:TPoint) : Point2D;
begin
  with current_params do begin
    result.x := P1.x/xscale + xmin;
    result.y := ymax -P1.y/yscale;
  end;
end;

end.