dage23wo 发表于 2015-6-18 09:44:51

VBA中的将一段程序编程块的问题

纯新手，在网上找了很多关于VBA变成块的问题，但是还是不知道怎么操作，还有，就是镜像后的图形能保存快么，下面是我画的图形，不知道怎么写块，求大神指点下，然后我自己琢磨，谢谢各位对新手的指教。

Private Sub CommandButton1_Click()



'#############################################################################图幅起始点

Dim x, y, z As Double

'线性添加
Dim entry As AcadLineType
Dim found As Boolean
Dim Itname(0 To 3) As String
Dim i As Integer
found = False
'添加三种线型
Itname(0) = "BORDER"
Itname(1) = "CENTER"
Itname(2) = "DASHDOT"
Itname(3) = "DASHED"
For i = 0 To 3
'搜寻要添加的线型在集合中是否存在
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, Itname(i), 1) = 0 Then
found = True
Exit For
End If
Next
'如果不存在将其从文件acadiso.lin中加载
If Not (found) Then
ThisDrawing.Linetypes.Load Itname(i), "acadiso.lin"
End If
Next
Dim objline(1 To 2000)As AcadLine
Dim objarc(1 To 2000)As AcadArc
Dim objcircle(1 To 2000) As AcadCircle


'#############################################################################主视图




Dim zc As Double

x = 1000
y = 1000
z = 0
zc = 0

Dim pt01(2) As Double
Dim pt02(2) As Double
Dim pt03(2) As Double
Dim pt04(2) As Double
Dim pt05(2) As Double
Dim pt06(2) As Double
Dim pt07(2) As Double
Dim pt08(2) As Double
Dim pt09(2) As Double
Dim pt10(2) As Double

Dim pt11(2) As Double
Dim pt12(2) As Double
Dim pt13(2) As Double
Dim pt14(2) As Double
Dim pt15(2) As Double
Dim pt16(2) As Double
Dim pt17(2) As Double
Dim pt18(2) As Double
Dim pt19(2) As Double
Dim pt20(2) As Double

Dim pt95(2) As Double
Dim pt96(2) As Double


pt01(0) = x: pt01(1) = y: pt01(2) = z
pt02(0) = x: pt02(1) = y + 40: pt02(2) = z
pt03(0) = x: pt03(1) = y + 47: pt03(2) = z
pt04(0) = x: pt04(1) = y + 50: pt04(2) = z
pt05(0) = x: pt05(1) = y + 57: pt05(2) = z
pt06(0) = x + 3.3: pt06(1) = y + 57: pt06(2) = z
pt07(0) = x + 3.3: pt07(1) = y + 50: pt07(2) = z
pt08(0) = x + 8.9: pt08(1) = y + 50: pt08(2) = z
pt09(0) = x + 8.9: pt09(1) = y + 47: pt09(2) = z
pt10(0) = x + 40: pt10(1) = y + 47: pt10(2) = z
pt11(0) = x + 40: pt11(1) = y + 40: pt11(2) = z
pt12(0) = x + 90: pt12(1) = y + 40: pt12(2) = z
pt13(0) = x + 90: pt13(1) = y: pt13(2) = z
pt14(0) = x + 4.5: pt14(1) = y + 50: pt14(2) = z
pt15(0) = x + 4.5: pt15(1) = y + 47: pt15(2) = z
pt16(0) = x + 35: pt16(1) = y + 47: pt16(2) = z
pt17(0) = x + 35: pt17(1) = y + 40: pt17(2) = z

pt95(0) = x: pt95(1) = y + 75: pt95(2) = z
pt96(0) = x: pt96(1) = y - zc - 613: pt96(2) = z


Dim objLayer As AcadLayer
Set objLayer = ThisDrawing.Layers.Add("粗实线")
objLayer.color = acWhite
objLayer.Linetype = "Continuous"
objLayer.Lineweight = acLnWt030
ThisDrawing.ActiveLayer = objLayer



Set objline(1) = ThisDrawing.ModelSpace.AddLine(pt05, pt06)
Set objline(2) = ThisDrawing.ModelSpace.AddLine(pt06, pt07)
Set objline(3) = ThisDrawing.ModelSpace.AddLine(pt04, pt08)
Set objline(4) = ThisDrawing.ModelSpace.AddLine(pt08, pt09)
Set objline(5) = ThisDrawing.ModelSpace.AddLine(pt03, pt10)
Set objline(6) = ThisDrawing.ModelSpace.AddLine(pt10, pt11)
Set objline(7) = ThisDrawing.ModelSpace.AddLine(pt02, pt12)
Set objline(8) = ThisDrawing.ModelSpace.AddLine(pt12, pt13)
Set objline(9) = ThisDrawing.ModelSpace.AddLine(pt01, pt13)
Set objline(10) = ThisDrawing.ModelSpace.AddLine(pt14, pt15)
Set objline(11) = ThisDrawing.ModelSpace.AddLine(pt16, pt17)


Dim xhcs As Integer
For xhcs = 1 To 11
objline(xhcs).Mirror pt95, pt96
Next







End Sub




看天的小树 发表于 2015-6-20 23:28:58


Private Sub CommandButton1_Click()   '点击按钮_程序





'#############################################################################图幅起始点


Dim x, y, z As Double


'线性添加

Dim entry As AcadLineType'声明线型

Dim found As Boolean

Dim Itname(0 To 3) As String'声明数组

Dim i As Integer

found = False

'添加三种线型

Itname(0) = "BORDER"

Itname(1) = "CENTER"

Itname(2) = "DASHDOT"

Itname(3) = "DASHED"

For i = 0 To 3

'搜寻要添加的线型在集合中是否存在

For Each entry In ThisDrawing.Linetypes   '在线型中循环

If StrComp(entry.Name, Itname(i), 1) = 0 Then'如果线型名字为三种的一种

found = True

Exit For'退出循环

End If

Next

'如果不存在将其从文件acadiso.lin中加载

If Not (found) Then

ThisDrawing.Linetypes.Load Itname(i), "acadiso.lin" '如果不存在自动加载

End If

Next

Dim objline(1 To 2000)As AcadLine

Dim objarc(1 To 2000)As AcadArc

Dim objcircle(1 To 2000) As AcadCircle




'#############################################################################主视图







Dim zc As Double


x = 1000

y = 1000

z = 0

zc = 0


Dim pt01(2) As Double

Dim pt02(2) As Double

Dim pt03(2) As Double

Dim pt04(2) As Double

Dim pt05(2) As Double

Dim pt06(2) As Double

Dim pt07(2) As Double

Dim pt08(2) As Double

Dim pt09(2) As Double

Dim pt10(2) As Double


Dim pt11(2) As Double

Dim pt12(2) As Double

Dim pt13(2) As Double

Dim pt14(2) As Double

Dim pt15(2) As Double

Dim pt16(2) As Double

Dim pt17(2) As Double

Dim pt18(2) As Double

Dim pt19(2) As Double

Dim pt20(2) As Double


Dim pt95(2) As Double

Dim pt96(2) As Double




pt01(0) = x: pt01(1) = y: pt01(2) = z

pt02(0) = x: pt02(1) = y + 40: pt02(2) = z

pt03(0) = x: pt03(1) = y + 47: pt03(2) = z

pt04(0) = x: pt04(1) = y + 50: pt04(2) = z

pt05(0) = x: pt05(1) = y + 57: pt05(2) = z

pt06(0) = x + 3.3: pt06(1) = y + 57: pt06(2) = z

pt07(0) = x + 3.3: pt07(1) = y + 50: pt07(2) = z

pt08(0) = x + 8.9: pt08(1) = y + 50: pt08(2) = z

pt09(0) = x + 8.9: pt09(1) = y + 47: pt09(2) = z

pt10(0) = x + 40: pt10(1) = y + 47: pt10(2) = z

pt11(0) = x + 40: pt11(1) = y + 40: pt11(2) = z

pt12(0) = x + 90: pt12(1) = y + 40: pt12(2) = z

pt13(0) = x + 90: pt13(1) = y: pt13(2) = z

pt14(0) = x + 4.5: pt14(1) = y + 50: pt14(2) = z

pt15(0) = x + 4.5: pt15(1) = y + 47: pt15(2) = z

pt16(0) = x + 35: pt16(1) = y + 47: pt16(2) = z

pt17(0) = x + 35: pt17(1) = y + 40: pt17(2) = z


pt95(0) = x: pt95(1) = y + 75: pt95(2) = z

pt96(0) = x: pt96(1) = y - zc - 613: pt96(2) = z




Dim objLayer As AcadLayer

Set objLayer = ThisDrawing.Layers.Add("粗实线")

objLayer.color = acWhite

objLayer.Linetype = "Continuous"

objLayer.Lineweight = acLnWt030

ThisDrawing.ActiveLayer = objLayer





Set objline(1) = ThisDrawing.ModelSpace.AddLine(pt05, pt06)

Set objline(2) = ThisDrawing.ModelSpace.AddLine(pt06, pt07)

Set objline(3) = ThisDrawing.ModelSpace.AddLine(pt04, pt08)

Set objline(4) = ThisDrawing.ModelSpace.AddLine(pt08, pt09)

Set objline(5) = ThisDrawing.ModelSpace.AddLine(pt03, pt10)

Set objline(6) = ThisDrawing.ModelSpace.AddLine(pt10, pt11)

Set objline(7) = ThisDrawing.ModelSpace.AddLine(pt02, pt12)

Set objline(8) = ThisDrawing.ModelSpace.AddLine(pt12, pt13)

Set objline(9) = ThisDrawing.ModelSpace.AddLine(pt01, pt13)

Set objline(10) = ThisDrawing.ModelSpace.AddLine(pt14, pt15)

Set objline(11) = ThisDrawing.ModelSpace.AddLine(pt16, pt17)




Dim xhcs As Integer

For xhcs = 1 To 11

objline(xhcs).Mirror pt95, pt96

Next











End Sub点击按钮名为command_1的按钮即可调用
页: [1]
查看完整版本: VBA中的将一段程序编程块的问题