明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1249|回复: 0

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

[复制链接]
发表于 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
上面的画图框是没错的,下面的加文本就加不了。

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-27 04:32 , Processed in 0.158848 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表