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

hoxnazig 发表于 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

("AutoCAD.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

雪山飞狐_lzh 发表于 2005-1-6 19:11:00

用无名块

bl="*U"

hoxnazig 发表于 2005-1-6 22:49:00

OK 尝试一下谢谢啊

页: [1]

明经CAD社区's Archiver

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

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