[求助]EXCEL不能另存？

szj612

前几天我搞了一个小VBA宏，作用是把在ACAD中获取的一些数据通过一些计算，然后输入到EXCEL模板文件中，再另存。由于进行了多次调试，后来竟发现不能正常另存（起先是可以的），具体症状是：运行到另存这条语句时，似乎跳到了某个陷阱中，总是运行不结束，当然也不报错。想请各位前辈分析分析，是怎么回事，先谢谢了！

代码粘贴如下：

Private Sub CommandButton1_Click()
UserForm1.Hide

Dim cir As AcadRegion: Dim li As Double: Dim lili As Double 'li=面域周长 lili=合计面域周长
Dim th(0 To 6) As Double: Dim opo As Integer   'opo=小孔数

Dim i As Integer
Dim plate As Integer: plate = 6
Dim ty As String:  ty = "冲修"   'ty = 模具类型
'Dim path1 As String
'path1 = ThisDrawing.Path       'path1 = 文件另存路径
th(0) = CDbl(TextBox1.Text)
th(1) = CDbl(TextBox2.Text)
th(2) = CDbl(TextBox3.Text)
th(3) = CDbl(TextBox4.Text)
th(4) = CDbl(TextBox5.Text)
th(5) = CDbl(TextBox6.Text)
th(6) = 56

 

 

Dim ExcelApp As New Excel.Application
ExcelApp.Workbooks.Open "f:\工作目录\btl\成本预算\temp\线割加工单.xls"
With ExcelApp.ActiveWorkbook.Worksheets("sheet1")
.Range("c" & 9) = TextBox7.Text
.Range("g" & 9) = TextBox8.Text
.Range("b" & 11) = "凸凹模"
.Range("b" & 12) = "内退料"
.Range("b" & 13) = "外退料"
.Range("b" & 14) = "下垫板"
.Range("b" & 15) = "凹模"
.Range("b" & 16) = "上固板"
.Range("b" & 17) = "异形冲头"

If OptionButton2.Value = True Then
th(2) = 40
plate = 3: ty = "翻边"
.Range("b" & 11) = "凹模"
.Range("b" & 12) = "退料板"
.Range("b" & 13) = "凸模"
.Range("b" & 14) = "上固板"
.Range("b" & 15) = ""
.Range("b" & 16) = ""
.Range("b" & 17) = ""
.Range("b" & 18) = ""

ElseIf OptionButton3.Value = True Then
th(2) = 40
plate = 3: ty = "包胎"
.Range("b" & 11) = "凹模"
.Range("b" & 12) = "退料板"
.Range("b" & 13) = "凸模"
.Range("b" & 14) = "上固板"
.Range("b" & 15) = ""
.Range("b" & 16) = ""
.Range("b" & 17) = ""
.Range("b" & 18) = ""
End If
.Range("k" & 9) = ty

Dim sset As AcadSelectionSet '定义选择集

On Error Resume Next

For ii = 0 To plate
Set sset = ThisDrawing.SelectionSets.Add("sz4")
Dim FilterType(0) As Integer: Dim FilterData(0) As Variant
FilterType(0) = 0: FilterData(0) = "region" '过滤条件
sset.SelectOnScreen FilterType, FilterData

opo = 0: lili = 0

For Each cir In sset

 

li = cir.Perimeter
cir.color = 2
If li < 1000 / th(i) Then
cir.color = 4
li = 0
opo = opo + 1
End If
lili = lili + li

Next

sset.Delete

 

.Range("d" & 11 + i) = th(i)
.Range("e" & 11 + i) = opo
.Range("g" & 11 + i) = lili
i = i + 1

Next ii

 End With

ExcelApp.ActiveWorkbook.SaveAs "d:\book2.xls" '(path1 & "\" & TextBox8.Text & ty & ".xls")
 
 ExcelApp.Workbooks.Close
 ExcelApp.Quit
 ThisDrawing.Application.Update

End Sub

 以下是源码