[求助]文本样式加不到图中

dynacy 发表于 2006-5-14 10:09:00

高人好：       我利用vb在CAD中出图（公路纵断面），我事先用下面的getpnt()过程取点，画好了图框，在编辑了下面这个添加文本的程序时，CAD中却不显示，而单行文本就很容易显示出来，请您给看看，指点一下： Public Sub getpnt(basepnt As Variant, distance As Double, angle As Double, pnt1() As Double) pnt1(0) = basepnt(0) + distance * Cos(angle * pi / 180) pnt1(1) = basepnt(1) + distance * Sin(angle * pi / 180) pnt1(2) = 0 End Sub
 '在CAD中画直线 Public Function addln(basepnt As Variant, _ length As Double, lnangle As Double) As AcadLine Dim pnt(0 To 2) As Double Call getpnt(basepnt, length * scales, lnangle, pnt()) Set addln = zdmms.AddLine(basepnt, pnt) End Function Public Sub drawtk() '绘制外图框 Dim pnt3(0 To 2) As Double, pnt4(0 To 2) As Double Dim wtkln1 As AcadLine, wtkln2 As AcadLine, wtkln3 As AcadLine, wtkln4 As AcadLine Dim ntkln1 As AcadLine, ntkln2 As AcadLine, ntkln3 As AcadLine, ntkln4 As AcadLine Dim l1 As AcadLine, l2 As AcadLine, l3 As AcadLine, l4 As AcadLine, l5 As AcadLine, _ l6 As AcadLine, l7 As AcadLine, l8 As AcadLine, l9 As AcadLine, l10 As AcadLine, _ l11 As AcadLine, l12 As AcadLine, l13 As AcadLine, l14 As AcadLine, l15 As AcadLine Dim zhuanye As AcadText, sheji As AcadText, shenhe As AcadText Dim tuhao As AcadText, bili As AcadText, riqi As AcadText
Dim pt5(0 To 2) As Double, pt6(0 To 2) As Double, pt7(0 To 2) As Double Dim pt8(0 To 2) As Double, pt9(0 To 2) As Double, pt10(0 To 2) As Double Dim dist As Double, jd As Double Dim l16 As AcadLine, l17 As AcadLine, l18 As AcadLine, l19 As AcadLine pnt3(0) = 0 pnt3(1) = 0 pnt3(2) = 0 pnt4(0) = 25 pnt4(1) = 10 pnt4(2) = 0 Set wtkln1 = addln(pnt3, 297 / scales, 90) Set wtkln2 = addln(wtkln1.EndPoint, 420 / scales, 0) Set wtkln3 = addln(wtkln2.EndPoint, 297 / scales, 270) Set wtkln4 = addln(wtkln3.EndPoint, 420 / scales, 180) '绘制内图框 Set ntkln1 = addln(pnt4, 277 / scales, 90) Set ntkln2 = addln(ntkln1.EndPoint, 385 / scales, 0) Set ntkln3 = addln(ntkln2.EndPoint, 277 / scales, 270) Set ntkln4 = addln(ntkln3.EndPoint, 385 / scales, 180) Dim p1(0 To 2) As Double Dim pnt5(0 To 2) As Double, pnt6(0 To 2) As Double, pnt7(0 To 2) As Double, _ pnt8(0 To 2) As Double, pnt9(0 To 2) As Double, pnt11(0 To 2) As Double Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double, pt3(0 To 2) As Double, pt4(0 To 2) As Double, _ pt11(0 To 2) As Double, pt12(0 To 2) As Double, pt13(0 To 2) As Double, pt14() As Double Call getpnt(pnt4, 10, 90, p1) Set l1 = addln(p1, 385 / scales, 0) '横线 '各栏分隔线 Call getpnt(pnt4, 53, 0, pnt5) Set l2 = addln(pnt5, 10 / scales, 90) Call getpnt(pnt5, 32, 0, pnt6) Set l3 = addln(pnt6, 10 / scales, 90) Call getpnt(pnt6, 20, 0, pnt7) Set l4 = addln(pnt7, 10 / scales, 90) Call getpnt(pnt7, 30, 0, pnt8) Set l5 = addln(pnt8, 10 / scales, 90) Call getpnt(pnt8, 20, 0, pnt9) Set l6 = addln(pnt9, 10 / scales, 90) Call getpnt(pnt9, 30, 0, pnt11) Set l7 = addln(pnt11, 10 / scales, 90) Call getpnt(pnt11, 20, 0, pt1) Set l8 = addln(pt1, 10 / scales, 90) Call getpnt(pt1, 30, 0, pt2) Set l9 = addln(pt2, 10 / scales, 90) Call getpnt(pt2, 20, 0, pt3) Set l10 = addln(pt3, 10 / scales, 90) Call getpnt(pt3, 30, 0, pt4) Set l11 = addln(pt4, 10 / scales, 90) Call getpnt(pt4, 20, 0, pt11) Set l12 = addln(pt11, 10 / scales, 90) Call getpnt(pt11, 30, 0, pt12) Set l13 = addln(pt12, 10 / scales, 90) Call getpnt(pt12, 20, 0, pt13) Set l14 = addln(pt13, 10 / scales, 90) Call getpnt(pt13, 30, 0, pt14) Set l15 = addln(pt14, 10 / scales, 90) '插入标题栏文字 '定义CAD中的文字 Dim pt5(0 To 2) As Double, pt6(0 To 2) As Double, pt7(0 To 2) As Double Dim pt8(0 To 2) As Double, pt9(0 To 2) As Double, pt10(0 To 2) As Double Dim dist As Double, jd As Double
'定义插入点 dist = Sqr(20 * 20 + 10 * 10) jd = 180 * Atn(10 / 20) / pi '定义标题栏文字的样式为仿宋体。并将文字样式层定为当前图层。 Set wzysh = zdm.TextStyles.Add("仿宋体") wzysh.fontFile = "C:\WINDOWS\Fonts\simfang.ttf" zdm.ActiveTextStyle = wzysh '指定文字的插入点 Call getpnt(pnt6, dist / 2, jd, pt5) Call getpnt(pnt8, dist / 2, jd, pt6) Call getpnt(pnt11, dist / 2, jd, pt7) Call getpnt(pt2, dist / 2, jd, pt8) Call getpnt(pt4, dist / 2, jd, pt9) Call getpnt(pt12, dist / 2, jd, pt10)
'将字体层设置为当前层，在标题栏中添加文字，并使文字在每个标题栏图框里居中显示 Dim layerziti As AcadLayer Call addlayer Set layerziti = zdm.Layers("字体") Set layerziti = zdm.ActiveLayer Set zhuanye = zdmms.AddText("专业", pt5, 3) zhuanye.Alignment = acAlignmentMiddleCenter zhuanye.Move pnt3, pt5 Set sheji = zdmms.AddText("设计", pt7, 3) sheji.Alignment = acAlignmentMiddleCenter
Set shenhe = zdmms.AddText("审核", pt9, 3) shenhe.Alignment = acAlignmentMiddleCenter shenhe.Move pnt3, pt9 Set tuhao = zdmms.AddText("图号", pt6, 3) tuhao.Alignment = acAlignmentMiddleCenter tuhao.Move pnt3, pt6 Set bili = zdmms.AddText("比例", pt8, 3) bili.Alignment = acAlignmentMiddleCenter bili.Move pnt3, pt8 Set riqi = zdm.ModelSpace.AddText("日期", pt10, 3) riqi.Alignment = acAlignmentMiddleCenter riqi.Move pnt3, pt10 end sub private sub form_load() call addtxt end sub 上面的画图框是没错的，下面的加文本就加不了。

页: [1]

明经CAD社区's Archiver

[求助]文本样式加不到图中