[求助]EXCEL不能另存？
<p>前几天我搞了一个小VBA宏，作用是把在ACAD中获取的一些数据通过一些计算，然后输入到EXCEL模板文件中，再另存。由于进行了多次调试，后来竟发现不能正常另存（起先是可以的），具体症状是：运行到另存这条语句时，似乎跳到了某个陷阱中，总是运行不结束，当然也不报错。想请各位前辈分析分析，是怎么回事，先谢谢了！</p><p>代码粘贴如下：</p><p>Private Sub CommandButton1_Click()<br/>UserForm1.Hide</p><p>Dim cir As AcadRegion: Dim li As Double: Dim lili As Double <font color="#f73809">'li=面域周长 lili=合计面域周长</font><br/>Dim th(0 To 6) As Double: Dim opo As Integer <font color="#ff0000">'opo=小孔数</font></p><p>Dim i As Integer<br/>Dim plate As Integer: plate = 6<br/>Dim ty As String: ty = "冲修" <font color="#ff0000">'ty = 模具类型<br/></font><font color="#f73809">'Dim path1 As String<br/>'path1 = ThisDrawing.Path 'path1 = 文件另存路径<br/></font>th(0) = CDbl(TextBox1.Text)<br/>th(1) = CDbl(TextBox2.Text)<br/>th(2) = CDbl(TextBox3.Text)<br/>th(3) = CDbl(TextBox4.Text)<br/>th(4) = CDbl(TextBox5.Text)<br/>th(5) = CDbl(TextBox6.Text)<br/>th(6) = 56</p><p> </p><p> </p><p>Dim ExcelApp As New Excel.Application<br/>ExcelApp.Workbooks.Open "f:\工作目录\btl\成本预算\temp\线割加工单.xls"<br/>With ExcelApp.ActiveWorkbook.Worksheets("sheet1")<br/>.Range("c" & 9) = TextBox7.Text<br/>.Range("g" & 9) = TextBox8.Text<br/>.Range("b" & 11) = "凸凹模"<br/>.Range("b" & 12) = "内退料"<br/>.Range("b" & 13) = "外退料"<br/>.Range("b" & 14) = "下垫板"<br/>.Range("b" & 15) = "凹模"<br/>.Range("b" & 16) = "上固板"<br/>.Range("b" & 17) = "异形冲头"</p><p><br/>If OptionButton2.Value = True Then<br/>th(2) = 40<br/>plate = 3: ty = "翻边"<br/>.Range("b" & 11) = "凹模"<br/>.Range("b" & 12) = "退料板"<br/>.Range("b" & 13) = "凸模"<br/>.Range("b" & 14) = "上固板"<br/>.Range("b" & 15) = ""<br/>.Range("b" & 16) = ""<br/>.Range("b" & 17) = ""<br/>.Range("b" & 18) = ""</p><p><br/>ElseIf OptionButton3.Value = True Then<br/>th(2) = 40<br/>plate = 3: ty = "包胎"<br/>.Range("b" & 11) = "凹模"<br/>.Range("b" & 12) = "退料板"<br/>.Range("b" & 13) = "凸模"<br/>.Range("b" & 14) = "上固板"<br/>.Range("b" & 15) = ""<br/>.Range("b" & 16) = ""<br/>.Range("b" & 17) = ""<br/>.Range("b" & 18) = ""<br/>End If<br/>.Range("k" & 9) = ty</p><p><br/>Dim sset As AcadSelectionSet <font color="#ff0000">'定义选择集</font></p><p><br/>On Error Resume Next</p><p>For ii = 0 To plate<br/>Set sset = ThisDrawing.SelectionSets.Add("sz4")<br/>Dim FilterType(0) As Integer: Dim FilterData(0) As Variant<br/>FilterType(0) = 0: FilterData(0) = "region" <font color="#ff0000">'过滤条件<br/></font>sset.SelectOnScreen FilterType, FilterData</p><p>opo = 0: lili = 0</p><p>For Each cir In sset</p><p> </p><p>li = cir.Perimeter<br/>cir.color = 2<br/>If li < 1000 / th(i) Then<br/>cir.color = 4<br/>li = 0<br/>opo = opo + 1<br/>End If<br/>lili = lili + li</p><p>Next</p><p>sset.Delete</p><p> </p><p>.Range("d" & 11 + i) = th(i)<br/>.Range("e" & 11 + i) = opo<br/>.Range("g" & 11 + i) = lili<br/>i = i + 1</p><p><br/>Next ii</p><p> End With</p><p>ExcelApp.ActiveWorkbook.SaveAs "d:\book2.xls" <font color="#f73809">'(path1 & "\" & TextBox8.Text & ty & ".xls")<br/></font> <br/> ExcelApp.Workbooks.Close<br/> ExcelApp.Quit<br/> ThisDrawing.Application.Update</p><p>End Sub</p><p> 以下是源码</p>
页:
[1]