[VBA]关于图块使用问题 请教！急
编制了一个绘制轴的程序但是在一个图形内只能使用一次 之后无论怎么修改参数 绘制的都是第一次参
数绘出的图形。 图块设置上有点搞不懂
那个高手帮我修改一下，使它可以连续使用
'******************************************************
'
'
'******************************************************
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 用无名块
bl="*U" OK 尝试一下 谢谢啊
页:
[1]