lbz123 发表于 2008-7-20 10:30

好的学习资料！！！

看董了一部分，还得仔细阅读加实践！！

huangxp07 发表于 2008-7-31 11:50

Thank you

wsj249201 发表于 2008-7-31 13:15

这本书看过，原来这个论坛上有:handshake

断供 发表于 2008-8-3 21:47

汗颜，以为自己水平还不错的，看了此帖觉得自己也就一菜鸟

jiangyaolei 发表于 2008-8-6 15:33

:lol :lol :lol :lol :lol :lol :lol :lol :lol :lol

yrgui 发表于 2008-8-7 08:35

回复 #26 liujingui 的帖子

这个你得说清楚一些,你的"高程数据文件"是什么样子的.

gqlxiaogou 发表于 2008-8-16 14:04

太好了！这个教程很不错！

kszxm 发表于 2008-8-16 15:57

看了还是一头雾水，但楼主的教程确实很棒！

gqlxiaogou 发表于 2008-8-16 17:07

第5课我怎么运行老是出错？

hughfs 发表于 2008-8-16 21:17

:victory: 好东西收藏了！像这样有技术含量的帖子这么可以不收藏呢！

gqlxiaogou 发表于 2008-8-18 15:51

楼主的帖子越来越精彩了！再顶下！
还有个问题就是VBA是不是应该有一个函数库一类的东西啊？VB中就有啊！

158063366 发表于 2008-8-18 16:32

真的很好   顶顶

wqzhen 发表于 2008-8-19 09:59

太好了，非常感谢！

gqlxiaogou 发表于 2008-8-23 14:28

最近刚学，参照楼主的足球场，我自己画了一个篮球场！现把代码发上来，清大家多指教！

Sub lqc()
Dim lqclay As AcadLayer'定义球场图层
Dim ent As AcadEntity    '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim centerp As Variant '中心坐标
Dim fqdp(2) As Double, sfxp(2) As Double
fqd = 5800 '罚球点位置
sfx = 6250 '三分线半径
zqr = 1800 '中圈半径
lbh = 1575 '篮板后宽度
bxk = 1250 '三分线到边线宽
chang = 28000 '长
kuan = 15000 '宽

'设置图层
centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

'把当前图层设为球场图层
Set courtlay = ThisDrawing.Layers.Add("球场")
ThisDrawing.ActiveLayer = courtlay

'画球场边框
linep1(1) = centerp(1) + kuan / 2
linep1(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2
linep2(0) = centerp(0) + chang / 2
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

linep1(1) = centerp(1) - kuan / 2
linep1(0) = centerp(0)
linep2(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

linep1(1) = centerp(1) + kuan / 2
linep1(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'画罚球圈
fqdp(1) = centerp(1)
fqdp(0) = centerp(0) + chang / 2 - fqd
Call ThisDrawing.ModelSpace.AddCircle(fqdp, zqr)

'画三分线
sfxp(1) = centerp(1)
sfxp(0) = centerp(0) + chang / 2 - lbh
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
ang2 = ThisDrawing.Utility.AngleToReal(270, 0)
Call ThisDrawing.ModelSpace.AddArc(sfxp, sfx, ang1, ang2) '画弧

'画左三分接头线
linep1(1) = centerp(1) + kuan / 2 - bxk
linep1(0) = centerp(0) + chang / 2 - lbh
linep2(1) = centerp(1) + kuan / 2 - bxk
linep2(0) = centerp(0) + chang / 2
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'画右三分接头线
linep1(1) = centerp(1) - kuan / 2 + bxk
linep1(0) = centerp(0) + chang / 2 - lbh
linep2(1) = centerp(1) - kuan / 2 + bxk
linep2(0) = centerp(0) + chang / 2
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'画左二分线
linep1(1) = centerp(1) + 3000
linep2(0) = centerp(0) + chang / 2 - fqd
linep2(1) = centerp(1) + zqr
linep1(0) = centerp(0) + chang / 2
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'画右二分线
linep1(1) = centerp(1) - 3000
linep2(0) = centerp(0) + chang / 2 - fqd
linep2(1) = centerp(1) - zqr
linep1(0) = centerp(0) + chang / 2
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'镜像轴
linep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2

'镜像
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
If ent.Layer = "足球场" Then '对象在"足球场"图层中
ent.Mirror linep1, linep2 '镜像
End If
Next ent

'画中线
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'画中圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)

ZoomExtents '显示整个图形
End Sub

gqlxiaogou 发表于 2008-8-23 14:30

有没有高手指点下，看看这个代码还能不能精简！
页: 2 3 4 5 6 7 8 9 10 11 [12] 13 14 15 16 17 18 19 20 21
查看完整版本: Autocad VBA初级教程 （强烈推荐）