print_lens.pas

精确套打与机械图纸生成, 包含了所有源码, 可供朋友们打印方面的参考

      NewFont := CreateFontIndirect(LogRec);
      OldFont := SelectObject(Canvas.Handle,NewFont);
      Canvas.TextOut(O_Tmp.X,round(O_Tmp.Y-0.5*mm_H),copy(C,2,k-2));
      Canvas.TextOut(O_Tmp.X,round(O_Tmp.Y+2*mm_H),copy(C,k+1,length(c)-k));
    end;
    O_Tmp:=Printer.Canvas.PenPos;
  end;
 end
 else
//------------------------------------------------------------------------------
if N=0 then begin
  with printer do
  begin
    if (C='C') or (C='c') then      //输出直径符号
    begin
      GetObject(Canvas.Font.Handle, SizeOf(LogRec), @LogRec);
      LogRec.lfEscapement:=900;
      LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
      LogRec.lfFaceName :='Txt';
      LogRec.lfWeight:=900;
      LogRec.lfHeight:=round(4*mm_V);
      NewFont := CreateFontIndirect(LogRec);
      OldFont := SelectObject(Canvas.Handle,NewFont);
      Canvas.TextOut(round(O_Tmp.X-0.5*mm_H),round(O_Tmp.Y),'o');
      Canvas.TextOut(O_Tmp.X,O_Tmp.Y,'/');
    end;

    if C='@' then      //输出正负号
    begin
      GetObject(Canvas.Font.Handle, SizeOf(LogRec), @LogRec);
      LogRec.lfEscapement:=900;
      LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
      LogRec.lfFaceName :='Txt';
      LogRec.lfWeight:=900;
      LogRec.lfHeight:=round(4*mm_V);
      NewFont := CreateFontIndirect(LogRec);
      OldFont := SelectObject(Canvas.Handle,NewFont);
//      Canvas.TextOut(round(O_Tmp.X-0.5*mm_V),round(O_Tmp.Y-1*mm_V),'+');
//      Canvas.TextOut(round(O_Tmp.X-0.5*mm_V),round(O_Tmp.Y-1*mm_V),'_');
      Canvas.TextOut(round(O_Tmp.X-0.5*mm_V),O_Tmp.Y,'+');
      Canvas.TextOut(round(O_Tmp.X-0.5*mm_V),O_Tmp.Y,'_');

    end;

    if copy(C,1,1)='$'  then      //输出主尺寸
    begin
      GetObject(Canvas.Font.Handle, SizeOf(LogRec), @LogRec);
      LogRec.lfEscapement:=900;
      LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
      LogRec.lfFaceName :='Txt';
      LogRec.lfWeight:=900;
      LogRec.lfHeight:=round(4*mm_V);
      NewFont := CreateFontIndirect(LogRec);
      OldFont := SelectObject(Canvas.Handle,NewFont);
      Canvas.TextOut(O_Tmp.X,O_Tmp.Y,copy(C,2,length(c)-1));
    end;

    if (copy(C,1,1)='&') then      //输出上下公差之---上公差
    begin
      for k:=1 to length(c)-1 do
      begin
        if copy(c,k,1)='^' then break;
      end;
      GetObject(Canvas.Font.Handle, SizeOf(LogRec), @LogRec);
      LogRec.lfEscapement:=900;
      LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
      LogRec.lfFaceName :='Txt';
      LogRec.lfWeight:=900;
      LogRec.lfHeight:=round(2.5*mm_V);
      NewFont := CreateFontIndirect(LogRec);
      OldFont := SelectObject(Canvas.Handle,NewFont);
      Canvas.TextOut(round(O_Tmp.X-0.5*mm_V),O_Tmp.Y,copy(C,2,k-2));
      Canvas.TextOut(round(O_Tmp.X+2*mm_V),O_Tmp.Y,copy(C,k+1,length(c)-k));
    end;
  end;
  O_Tmp.Y:=O_Tmp.Y-(Printer.Canvas.PenPos.X-O_Tmp.X);
 end;
 result:=O_Tmp;
end;

//--------------------输出标注尺寸--------------------
procedure _OutSize(O_Tmp:TPoint;Txt:String;K:integer);
Var
  j,i:Integer;
  c,c1:String;
  size:array[1..5] of string;
begin
  c:='';
   for i:=1 to length(txt) do
  begin
    c1:=copy(txt,i,1);
    for j:=1 to 3 do
    begin
    if c1=copy('@$&',j,1) then
    begin
      if i>1 then
      O_Tmp:=_Symbol(O_Tmp,C,K);
      c:='';
    end;
    end;

   if (copy(C,1,3)='%%c') or (copy(c,1,3)='%%C') then
    begin
      C:='C'+copy(c,4,length(c)-3);
      O_Tmp:=_Symbol(O_Tmp,C,K);
      //Form1.Memo1.Text:=Form1.Memo1.Text+C+#13#10;
      c:='$';
    end; //-----------end ------- %%c---------}
    c:=c+c1;
  end;
  O_Tmp:=_Symbol(O_Tmp,C,K);
end;
//--------------------尺寸输出结束--------------------------------

procedure _dimension(O1,O2:TPoint;K:Integer;N,M:Real;Txt:String);
var
  s1,s2,s3,s4:Real;
  h1,h2,h3,h4:integer;
  O3,O4,O_Tmp:TPoint;
begin
 s1:=10;
 s2:=1.25;
 s3:=0.63;
 s4:=18; //标注尺寸下面的线长
 // K---------------方向控制因了
 if O1.X=O2.X then  //y轴坐标处于同一水平线时，用横线+箭头进行标注
 begin
    h1:=k*Round(s3*mm_H);          //标注引线起点到图形的距离
    h2:=k*Round((s1+s2)*mm_H)+k*round(N);   //标注引线长度
    h3:=k*Round(s1*mm_H)+k*round(N);        //标注尺寸位置到图形的距离
    h4:=k*Round(s4*mm_H);

    if O1.Y>O2.Y then
    begin
      O_Tmp:=O1;
      O1:=O2;
      O2:=O_Tmp;
    end;

    With Printer do
    begin
      Canvas.Pen.Width:=round(0.09*mm_H);

      Canvas.MoveTo(O1.X-h1,O1.Y);     //第一引线
      Canvas.LineTo(O1.x-h2,O1.Y);

      Canvas.MoveTo(O2.X-h1,O2.Y);     //第二引线
      Canvas.LineTo(O2.x-h2,O2.Y);

      Canvas.MoveTo(O1.x-h3,O1.y);     //标注线3
      Canvas.LineTo(O1.x-h3,O2.y);     //标注线3
      O_Tmp.X:=O2.x-h3;
      O_Tmp.Y:=O1.y;
      _arrow(O_tmp,-1,M);

      O_Tmp.X:=O2.x-h3;
      O_Tmp.Y:=O2.y;
      _arrow(O_tmp,1,M);

      O3.X:=O1.X-h3;//-round(3*mm_V);     //标注线中点
      O3.Y:=(O2.Y+O1.Y) div 2;

      O4.X:=O1.X-h3+round(k*4*mm_H);
      O4.Y:=O3.Y+round(7*mm_V);//-round(*mm_V);
      _outSize(O4,Txt,0);
    end;
 end;

 if O1.Y=O2.Y then  //x轴坐标处于同一垂直线时，用竖线+箭头进行标注
 begin
    h1:=k*Round(s3*mm_V);          //标注引线起点到图形的距离
    h2:=k*Round((s1+s2)*mm_V)+k*round(N);   //标注引线长度
    h3:=k*Round(s1*mm_V)+k*round(N);        //标注尺寸位置到图形的距离
    h4:=Round(s4*mm_H);
    if O1.X>O2.X then
    begin
      O_Tmp:=O1;
      O1:=O2;
      O2:=O_Tmp;
    end;

    With Printer do
    begin
      Canvas.Pen.Width:=round(0.09*mm_H);

      Canvas.MoveTo(O1.X,O1.Y-h1);     //第一引线
      Canvas.LineTo(O1.x,O1.Y-h2);

      Canvas.MoveTo(O2.X,O2.Y-h1);     //第二引线
      Canvas.LineTo(O2.x,O2.Y-h2);

      Canvas.MoveTo(O1.x-h4,O1.y-h3);     //标注线3
      Canvas.LineTo(O2.x,O2.y-h3);     //标注线3

      O_Tmp.X:=O1.x;
      O_Tmp.Y:=O1.y-h3;
      _arrow(O_tmp,-2,M);

      O_Tmp.X:=O2.x;
      O_Tmp.Y:=O2.y-h3;
      _arrow(O_tmp,2,M);

      O3.X:=(O2.X+O1.X) div 2;     //标注线中点
      O3.Y:=O1.y-h3-round(3*mm_V);

      O4.X:=O1.X-h4;
      O4.Y:=O3.Y;//-round(*mm_V);
      _outSize(O4,Txt,1);
    end;
 end;
end;

function _Point(r,t,d,w,h:Real;K,N:Integer):Tpoint;
var
  O_tmp:TPoint;
  O:Array [1..5] of TPoint;
  M:Integer;
begin
  if r<>0 then
    M:=round(r/abs(r))
  else
    M:=1;

  O_Tmp.X:=round(w/2+r+k/abs(k)*(1/2*t));
  O_Tmp.Y:=Round(H/2);

  O[1].X:=O_Tmp.X-abs(Round(r));     //---left
  O[1].Y:=O_Tmp.Y-abs(Round(r));     //---top
  O[2].X:=O_Tmp.X+abs(Round(r));     //---right
  O[2].Y:=O_Tmp.Y+abs(Round(r));     //---bottom

  if r<>0 then
    O[3].X:=O_Tmp.X-round(M*sqrt(abs(r*r-(d/2)*(d/2))))  //---start-x
  else
    O[3].X:=round(w/2+K*(1/2)*t);

  O[3].Y:=O_Tmp.Y-Round(M*d/2);                    //---start-y
  O[4].X:=O[3].X;                                     //---end-x
  O[4].Y:=O_Tmp.Y+Round(M*d/2);                    //---end-y

  O[5].X:=round(w/2+k/abs(k)*(1/2*t));        //R中心象限点坐标
  O[5].Y:=O_Tmp.Y;

  result:=O[N]; //返回数组O
end;

//-----------------------------------绘中心线--------------------------
procedure _CenterLine(O:TPoint;L:real);  // -.-.-.-.-.-.-.-.-.-.
var
 i:Integer;
 j,k,m,n:Real;
begin
  j:=L+10*mm_H;
  k:=j/(6.3*mm_H);   //求出总段数
  K:=K-1+2/3;  //调整段数，确保结尾处不留空白；
  m:=j/k;     //调整后的每段长度
  K:=j/m;     //调整后的总段数
  n:=5*mm_H;
  Printer.Canvas.Pen.Width:=round(0.13*mm_V);

  for i:=0 to round(k-1) do
  begin
    Printer.Canvas.MoveTo(O.x-round(n-(i+0  )*m),O.y);
    Printer.Canvas.LineTo(O.x-round(n-(i+6/9)*m),O.y);
    Printer.Canvas.MoveTo(O.x-round(n-(i+7/9)*m),O.y);
    Printer.Canvas.LineTo(O.x-round(n-(i+8/9)*m),O.y);
  end;
  Printer.Canvas.MoveTo(O.x-round(n-(i+0  )*m),O.y);
  Printer.Canvas.LineTo(O.x-round(n-(i+k-i)*m),O.y);

  //  Printer.Canvas.MoveTo(Printer.Canvas.PenPos.x+round(m/9),O.y);
//  Printer.Canvas.LineTo(O.x+round(n),O.y);     //画出余数部份的剩余线

end;
//-----------------------------------中心线结束-------------

procedure _OutJG(O:TPoint;N:Real;K:Integer);
var
  X,Y:Real;
  Txt:String;
begin

  point1.X:=0;
  point1.Y:=0;
  Move(O.X/mm_H+5,O.Y/mm_V-8.660254);
  line(-5,8.660254,0.09);
  line(-2.5,-4.330127,0.09);
  line(5,0,0.09);

  X:=O.X/mm_H+2.5-Length(FloatTOStr(N))*1.8;
  Y:=O.Y/mm_V-4.330127-4;
  if      K=0 then Txt:=''
  else if K=1 then Txt:='全部'
  else if K=2 then Txt:='其它';


  _OutTxt(x,y,FloatTOStr(N),4,'Txt');
  _OutTxt(x-5,y+6,Txt,4,'经典仿宋繁');

end;

procedure _OutLens(r1,r2,t,d,d2,Scale:Real;s,Film:Integer);
//Function DrawLens(r1,r2,n,t,d,scale,W,H:real):integer;
{函数名称:DrawLens(r1,r2,n,t,d,scale:real):real;
 函数功能:求厚透镜物、象方基点公式(单片)
 参数说明: r1 ---- 左球面半径
           r2 ---- 右球面半径
           n  ---- 折射率
           t  ---- 透镜中心厚度
           d  ---- 透镜口径
        scale ---- 绘图比例因子
           W  ---- 绘图区宽
           H  ---- 绘图区高
           S  ---- 生成标注尺寸  1---启用, 其它---禁用

 变量说明: Ox_r1 -- r1圆心x轴坐标
           Ox_r2 -- r2圆心x轴坐标
           x1    -- r1弧线边缘x轴坐标
           x2    -- r2弧线边缘x轴坐标
           xA    -- r1弧线象限点
           xB    -- r2弧线象限点
           y     -- 透镜边缘y轴坐标(上下边线的y轴互为相反数)
           f     -- 焦距变量
 返回值：无返回值
 -----------------------------------------------------------
  编写日期:2002.11.25 20:00
  作    者:杨振华
  编写地点：昆明欧海科技开发有限公司 (开发部)
}
var
  K,i,j:Integer;
  O_Tmp:TPoint;
  r:Array [1..2] of real;
  O:Array [1..2,1..5] of TPoint;
  w,h,f:real;
  Txt_t1,Txt_t2,Txt_d1,Txt_d2:String;
begin
  if s=1 then
  begin
    Txt_t1:='$('+FloatToStr(round(_LensVerge(r1,r2,t,d)*100)/100)+')';
    Txt_t2:='$'+FloatToStr(t)+'@0.1';
    Txt_d1:='%%c'+FloatToStr(d)+'&-0.1^-0.2';
    Txt_d2:='%%c='+FloatToStr(d)+'('+FloatToStr(D2)+')';

  end;
  r1:=r1*mm_H*Scale;
  r2:=r2*mm_H*Scale;
  t :=t*mm_H*Scale;
  d :=d*mm_H*Scale;
  w:=PageWidth+30*mm_H;
  h:=PageHeight;

  r[1]:=r1;
  r[2]:=r2;
  k:=-1; //r1 与 r2 标识器

  for i:=1 to 2 do
  begin
    for j:=1 to 5 do
    begin
      O[i,j]:=_Point(r[i],t,d,w,h,K,j);
    end;
    k:=k*(-1);
  end;

  printer.Canvas.Pen.Width:=Round(0.2*mm_H);
  for i:=1 to 2 do
  begin
    if r[i]<>0 then
      printer.Canvas.Arc( O[i,1].X,O[i,1].Y,
                          O[i,2].X,O[i,2].Y,
                          O[i,3].X,O[i,3].Y,
                          O[i,4].X,O[i,4].Y)    //输出透镜图的r
    else
      begin
      printer.Canvas.MoveTo(O[i,3].X,O[i,3].Y);
      printer.Canvas.LineTo(O[i,4].X,O[i,4].Y);
      end;

    if O[i,3].Y>O[i,4].Y then
    begin
      O_Tmp.Y:=O[i,3].Y;                      //取出上下结点的标准
      O[i,3].Y:=O[i,4].Y;
      O[i,4].Y:=O_Tmp.Y;
    end;
  end;

  for j:=3 to 4 do             //输出透镜图书的上下边线
  begin
    for i:=1 to 2-1 do
    begin
      Printer.Canvas.MoveTo(O[i,j].X,O[i,j].Y);
      Printer.Canvas.LineTo(O[i+1,j].X,O[i+1,j].Y);
    end;
  end;

  _CenterLine(O[1,5],O[2,5].x-O[1,5].x);             //-------中心线

  if s=1 then
  begin
    _dimension(O[1,3],O[2,3],+1,5*mm_V,+1,Txt_t1);            //-----------标注线(置于上边)----边缘厚
    _dimension(O[2,3],O[2,4],-1,O[2,5].x-O[2,3].x+5*mm_H,-1,Txt_D1);//-----标注线 (置于右边)---口径
    _dimension(O[1,5],O[2,5],-1,d/2+5*mm_V,-1,Txt_t2);              //-----标注线--------------中心厚
  end;
  _dimension(O[2,3],O[2,4],-1,O[2,5].x-O[2,3].x+5*mm_H,-1,Txt_D1);//-----标注线 (置于右边)---口径

//------------------------有效口径------------------------
  O_Tmp.X:=O[1,5].X-round((length(Txt_t2)-3)*3*mm_H-t/2);
  O_Tmp.Y:=O[1,5].Y+round(d/2+20*mm_V);
  _outSize(O_Tmp,Txt_D2,1);
//--------------------------------------------------------

//------------------------粗糙度符号----------------------
  O_Tmp.X:=O[2,3].X+Round((5+10)/2*mm_H);
  O_Tmp.Y:=O[2,3].Y;
  _outJG(O_Tmp,1.6,0);

  O_Tmp.X:=round(175*mm_H);
  O_Tmp.Y:=round(40*mm_V);
  _outJG(O_Tmp,0.008,2);
//--------------------------------------------------------


//------------------------输出镀膜符号----------------------

  O_Tmp.Y:=O[1,5].Y-round(d/2*(3/4)); //中心线上方3/4处输出镀膜符号
  if Film mod 2=1 then //------------------R1镀膜
  begin
   if O[1,3].X>O[1,5].X then O_Tmp.X:=O[1,5].X-round(2.5*mm_H)
   else O_Tmp.X:=O[1,3].X-round(2.5*mm_H);
   _Circle(O_Tmp.X/mm_H,O_Tmp.Y/mm_V,1,0.09);
  end;

  if Film>1 then  //-------------------------R2镀膜
  begin
   if O[2,3].X>O[2,5].X then O_Tmp.X:=O[2,3].X+round(2.5*mm_H)
   else O_Tmp.X:=O[2,5].X+round(2.5*mm_H);

   _Circle(O_Tmp.X/mm_H,O_Tmp.Y/mm_V,1,0.09);
  end;

//--------------------------------------------------------
end;

procedure _SJ(x,y:Real);
begin
  Move(x,y);
  Line(-0.81,1.41,0.09);
  Line(1.62,0,0.09);
  Line(-0.81,-1.41,0.09);
end;


procedure _OutBlock();
var
 i:Integer;
begin