乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 29|回复: 2

[VBA]关于图块使用问题 请教!急

[复制链接]

1

主题

2

帖子

1

银币

初来乍到

Rank: 1

铜币
6
发表于 2005-1-6 15:57:00 | 显示全部楼层 |阅读模式
编制了一个绘制轴的程序
但是在一个图形内只能使用一次         之后无论怎么修改参数 绘制的都是第一次参
数绘出的图形。         图块设置上有点搞不懂
那个高手帮我修改一下,使它可以连续使用
'******************************************************
'
'                                         
'******************************************************
Private Sub cmdsure_Click()
                                 
                                 '定义变量 读入数据
                                 Dim D1 As Double
                                 Dim D2 As Double
                                 Dim D3 As Double
                                 Dim D4 As Double
                                 Dim L1 As Double
                                 Dim L2 As Double
                                 Dim L3 As Double
                                 Dim L4 As Double
                                 Dim jianL As Double
                                 Dim jianW As Double
                                 
                                 D1 = txtd1.Text
                                 D2 = txtd2.Text
                                 D3 = txtd3.Text
                                 D4 = txtd4.Text
                                 L1 = txtl1.Text
                                 L2 = txtl2.Text
                                 L3 = txtl3.Text
                                 L4 = txtl4.Text
                                 jianL = txtjianL.Text
                                 jianW = TxtjianW.Text
                                 
                                 '隐藏窗口
                                 frmzhou.Hide
                                 
                                 Dim sysOSMODE As Integer
                                 sysOSMODE = ThisDrawing.GetVariable("osmode")
                                 ThisDrawing.SetVariable "osmode", 0
                                 '定义点
                                 Dim p(1 To 22), pa, pb, insertPt As Variant
                                 Dim di1, di2, di3, di4 As Variant
                                 Dim o1, o2, o3, o4, o5, o6 As Variant
                                 Dim jian(1 To 6) As Variant
                                 Dim utilObj As Object
                                 Set utilObj = ThisDrawing.Utility
                                 '获取输入点
                                 insertPt = ThisDrawing.Utility.GetPoint(, "输入插入点:")
                 
                                 utilObj.CreateTypedArray p(1), vbDouble, insertPt(0), insertPt
(1) + 2 - D1 / 2, 0
                                 utilObj.CreateTypedArray p(2), vbDouble, insertPt(0), insertPt
(1) - 2 + D1 / 2, 0
                                 utilObj.CreateTypedArray p(3), vbDouble, insertPt(0) + L1,
insertPt(1) - D2 / 2, 0
                                 utilObj.CreateTypedArray p(4), vbDouble, insertPt(0) + L1,
insertPt(1) + D2 / 2, 0
                                 utilObj.CreateTypedArray p(5), vbDouble, insertPt(0) + L1 + L2,
insertPt(1) - D3 / 2, 0
                                 utilObj.CreateTypedArray p(6), vbDouble, insertPt(0) + L1 + L2,
insertPt(1) + D3 / 2, 0
                                 utilObj.CreateTypedArray p(7), vbDouble, insertPt(0) + L1 + L2 +
L3, insertPt(1) - D3 / 2, 0
                                 utilObj.CreateTypedArray p(8), vbDouble, insertPt(0) + L1 + L2 +
L3, insertPt(1) + D3 / 2, 0
                                 utilObj.CreateTypedArray p(9), vbDouble, insertPt(0) + L1 + L2 +
L3 + L4, insertPt(1) + 2 - D4 / 2, 0
                                 utilObj.CreateTypedArray p(10), vbDouble, insertPt(0) + L1 + L2
+ L3 + L4, insertPt(1) - 2 + D4 / 2, 0
                                 
                                 utilObj.CreateTypedArray p(11), vbDouble, insertPt(0) + L1,
insertPt(1) - (D2 + D1) / 4, 0
                                 utilObj.CreateTypedArray p(12), vbDouble, insertPt(0) + L1 - (D2
- D1) / 4, insertPt(1) - D1 / 2, 0
                                 utilObj.CreateTypedArray p(13), vbDouble, insertPt(0) + L1,
insertPt(1) + (D2 + D1) / 4, 0
                                 utilObj.CreateTypedArray p(14), vbDouble, insertPt(0) + L1 - (D2
- D1) / 4, insertPt(1) + D1 / 2, 0
                                 utilObj.CreateTypedArray p(15), vbDouble, insertPt(0) + L1 + L2,
insertPt(1) - (D3 + D2) / 4, 0
                                 utilObj.CreateTypedArray p(16), vbDouble, insertPt(0) + L1 + L2
- (D3 - D2) / 4, insertPt(1) - D2 / 2, 0
                                 utilObj.CreateTypedArray p(17), vbDouble, insertPt(0) + L1 + L2,
insertPt(1) + (D3 + D2) / 4, 0
                                 utilObj.CreateTypedArray p(18), vbDouble, insertPt(0) + L1 + L2
- (D3 - D2) / 4, insertPt(1) + D2 / 2, 0
                                 utilObj.CreateTypedArray p(19), vbDouble, insertPt(0) + L1 + L2
+ L3, insertPt(1) - (D4 + D3) / 4, 0
                                 utilObj.CreateTypedArray p(20), vbDouble, insertPt(0) + L1 + L2
+ L3 - (D4 - D3) / 4, insertPt(1) - D4 / 2, 0
                                 utilObj.CreateTypedArray p(21), vbDouble, insertPt(0) + L1 + L2
+ L3, insertPt(1) - (D4 + D3) / 4, 0
                                 utilObj.CreateTypedArray p(22), vbDouble, insertPt(0) + L1 + L2
+ L3 - (D4 - D3) / 4, insertPt(1) + D4 / 2, 0
                                 
                                 
                                 utilObj.CreateTypedArray di1, vbDouble, insertPt(0) + 2,
insertPt(1) - D1 / 2, 0
                                 utilObj.CreateTypedArray di2, vbDouble, insertPt(0) + 2,
insertPt(1) + D1 / 2, 0
                                 utilObj.CreateTypedArray di3, vbDouble, insertPt(0) + L1 + L2 +
L3 + L4 - 2, insertPt(1) - D4 / 2, 0
                                 utilObj.CreateTypedArray di4, vbDouble, insertPt(0) + L1 + L2 +
L3 + L4 - 2, insertPt(1) + D4 / 2, 0
                 
                                 
                                 utilObj.CreateTypedArray pa, vbDouble, insertPt(0) - 20,
insertPt(1), 0
                                 utilObj.CreateTypedArray pb, vbDouble, insertPt(0) + L1 + L2 +
L3 + L4 + 20, insertPt(1), 0
                                 
                                 
                                 utilObj.CreateTypedArray o1, vbDouble, insertPt(0) + L1 - (D2 -
D1) / 4, insertPt(1) - (D2 + D1) / 4, 0
                                 utilObj.CreateTypedArray o2, vbDouble, insertPt(0) + L1 - (D2 -
D1) / 4, insertPt(1) + (D2 + D1) / 4, 0
                                 utilObj.CreateTypedArray o3, vbDouble, insertPt(0) + L1 + L2 -
(D3 - D2) / 4, insertPt(1) - (D3 + D2) / 4, 0
                                 utilObj.CreateTypedArray o4, vbDouble, insertPt(0) + L1 + L2 -
(D3 - D2) / 4, insertPt(1) + (D3 + D2) / 4, 0
                                 utilObj.CreateTypedArray o5, vbDouble, insertPt(0) + L1 + L2 +
L3 - (D4 - D3) / 4, insertPt(1) - (D4 + D3) / 4, 0
                                 utilObj.CreateTypedArray o6, vbDouble, insertPt(0) + L1 + L2 +
L3 - (D4 - D3) / 4, insertPt(1) + (D4 + D3) / 4, 0
                                 
                                 utilObj.CreateTypedArray jian(1), vbDouble, insertPt(0) + L1 +
L2 + L3 / 2 - jianL / 2 + jianW / 2, insertPt(1) - jianW / 2, 0
                                 utilObj.CreateTypedArray jian(2), vbDouble, insertPt(0) + L1 +
L2 + L3 / 2 - jianL / 2 + jianW / 2, insertPt(1) + jianW / 2, 0
                                 utilObj.CreateTypedArray jian(3), vbDouble, insertPt(0) + L1 +
L2 + L3 / 2 + jianL / 2 - jianW / 2, insertPt(1) - jianW / 2, 0
                                 utilObj.CreateTypedArray jian(4), vbDouble, insertPt(0) + L1 +
L2 + L3 / 2 + jianL / 2 - jianW / 2, insertPt(1) + jianW / 2, 0
                                 utilObj.CreateTypedArray jian(5), vbDouble, insertPt(0) + L1 +
L2 + L3 / 2 - jianL / 2 + jianW / 2, insertPt(1), 0
                                 utilObj.CreateTypedArray jian(6), vbDouble, insertPt(0) + L1 +
L2 + L3 / 2 + jianL / 2 - jianW / 2, insertPt(1), 0
                                 
                                 
                                 Dim bl As String
                                 bl = "block"
                                 
                                 Dim flagno As Integer
                                 flagno = 0
                                 
                                 Dim iblock As Integer
                                 iblock = ThisDrawing.Blocks.Count
                                 While (iblock > 0)
                                 If ThisDrawing.Blocks.Item(iblock - 1).Name = mx Then
                                 flagno = 1
                                 End If
                                 iblock = iblock - 1
                                 Wend
                                 
                                 If flagno = 0 Then
                                 
                                 
                                 
                                 '创建块 连线,画弧
                                 Set blockobj = ThisDrawing.Blocks.Add(insertPt, bl)
                                 Dim line(1 To 21), linec As AcadLine
                                 Dim arc(1 To 8) As AcadArc
                                 
                                 Set line(1) = blockobj.AddLine(p(1), p(2))
                                 Set line(2) = blockobj.AddLine(di1, di2)
                                 Set line(3) = blockobj.AddLine(p(1), di1)
                                 Set line(4) = blockobj.AddLine(p(2), di2)
                                 Set line(5) = blockobj.AddLine(di1, p(12))
                                 
                                 Set line(6) = blockobj.AddLine(di2, p(14))
                                 Set line(7) = blockobj.AddLine(p(3), p(4))
                                 Set line(8) = blockobj.AddLine(p(3), p(16))
                                 Set line(9) = blockobj.AddLine(p(4), p(18))
                                 Set line(10) = blockobj.AddLine(p(5), p(6))
                                 Set line(11) = blockobj.AddLine(p(5), p(7))
                                 Set line(12) = blockobj.AddLine(p(6), p(8))
                                 Set line(13) = blockobj.AddLine(p(7), p(8))
                                 
                                 Set line(14) = blockobj.AddLine(p(22), di4)
                                 Set line(15) = blockobj.AddLine(p(20), di3)
                                 Set line(16) = blockobj.AddLine(di3, di4)
                                 Set line(17) = blockobj.AddLine(di3, p(9))
                                 Set line(18) = blockobj.AddLine(p(10), di4)
                                 Set line(19) = blockobj.AddLine(p(9), p(10))
                                 Set line(20) = blockobj.AddLine(jian(1), jian(3))
                                 Set line(21) = blockobj.AddLine(jian(2), jian(4))
                                 
                                 Set linec = blockobj.AddLine(pa, pb)
                                 
                                 Set arc(1) = blockobj.AddArc(o1, (D2 - D1) / 4, 0#, 1.5707963)
                                 Set arc(2) = blockobj.AddArc(o2, (D2 - D1) / 4, 1.5 * 3.1415926,
0#)
                                 Set arc(3) = blockobj.AddArc(o3, (D3 - D2) / 4, 0#, 1.5707963)
                                 Set arc(4) = blockobj.AddArc(o4, (D3 - D2) / 4, 1.5 * 3.1415926,
0#)
                                 Set arc(5) = blockobj.AddArc(o5, (D3 - D4) / 4, 1.5707963,
3.1415926)
                                 Set arc(6) = blockobj.AddArc(o6, (D3 - D4) / 4, 3.1415926, 1.5 *
3.1415926)
                                 Set arc(7) = blockobj.AddArc(jian(5), jianW / 2, 1.5707963, 1.5
* 3.1415926)
                                 Set arc(8) = blockobj.AddArc(jian(6), jianW / 2, 1.5 *
3.1415926, 1.5707963)
                                 '设置线形
                                 ThisDrawing.Linetypes.Load "CENTER", "acadiso.lin"
                                 linec.Linetype = "CENTER"
                                 '设置颜色
                                 Dim color As AcadAcCmColor
                                 Set color = AcadApplication.GetInterfaceObject
(".AcCmColor.16")
                                 Call color.SetRGB(80, 14, 24)
                                 linec.TrueColor = color
                                 
                                 End If
                                 '插入图块
                                 Dim blockrefobj As AcadBlockReference
                                 Set blockrefobj = ThisDrawing.ModelSpace.InsertBlock(insertPt,
bl, 1#, 1#, 1#, 0)
                                 
                                 
                                 ThisDrawing.Regen acActiveViewport
                                 
                                 
                                 
End Sub
Private Sub cmdexit_Click()
         End
End Sub
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2005-1-6 19:11:00 | 显示全部楼层
用无名块
bl="*U"
回复

使用道具 举报

1

主题

2

帖子

1

银币

初来乍到

Rank: 1

铜币
6
发表于 2005-1-6 22:49:00 | 显示全部楼层
OK 尝试一下 谢谢啊
回复

使用道具 举报

发表回复

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

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-16 17:25 , Processed in 1.481720 second(s), 59 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表