电子表格如何用代码来关闭,打开就关不了,各种方法都试过,没用
试题批量导入模板.xls这个电子表格如何关闭程序代码:
Private Sub Image2_Click() On Error GoTo err1 Dim ZJStr() As String '章节列表 Dim ZJId() As String Dim FileStr As String FileStr = AppStr & "试题批量导入模板.xls" If FileStr = "" Then Exit Sub End If Label1.Caption = "正在分析章节信息,请稍后!" Dim Sql As String Dim MsgTxt As String Dim Rs_Zj As ADODB.Recordset Dim Rs As ADODB.Recordset Sql = "select * from zjinfo " Set Rs_Zj = ExecuteSQL(Sql, MsgTxt) If InStr(MsgTxt, "错误") Then MsgBox MsgTxt Exit Sub End If ReDim ZJStr(0) ReDim ZJId(0) If Rs_Zj.RecordCount > 0 Then '========================获取章节信息 如果有 For i = 1 To Rs_Zj.RecordCount ReDim Preserve ZJStr(i) ReDim Preserve ZJId(i) ZJStr(i) = Rs_Zj.Fields("zjname") & "" ZJId(i) = Rs_Zj.Fields("zjid") & "" Rs_Zj.MoveNext Next i End If Sql = "select * from tminfo" Set Rs = ExecuteSQL(Sql, MsgTxt) If InStr(MsgTxt, "错误") Then MsgBox MsgTxt Exit Sub End If Dim NewApp Dim NewSheet Dim NewBook Set NewApp = New Excel.Application Set NewBook = NewApp.Workbooks.Open(FileStr, , , , "") '第一位为路径,第五位为密码 Set NewSheet = NewBook.Worksheets(1) For i = 2 To NewSheet.Cells.Count Label1.Caption = "正在读取第" & i & 项 DoEvents If Trim(NewSheet.Cells(i, 1)) = "" Then Exit For End If '先判断该章节是否已经添加 For j = 1 To UBound(ZJId) If ZJStr(j) = Trim(NewSheet.Cells(i, 8)) Then Exit For End If Next j If j > UBound(ZJId) Then '没有找到 Rs_Zj.AddNew Rs_Zj.Fields("zjname") = Trim(NewSheet.Cells(i, 8)) Rs_Zj.Update ReDim Preserve ZJStr(j) ReDim Preserve ZJId(j) ZJStr(j) = Trim(NewSheet.Cells(i, 8)) ZJId(j) = Rs_Zj.Fields("zjid") & "" End If Rs.AddNew Text8.Text = Trim(NewSheet.Cells(i, 1)) Rs.Fields("TMStra") = jm(Text8.Text) Dim a As String If Len(NewSheet.Cells(i, 2)) > 2 Then a = Left(NewSheet.Cells(i, 2), 2) If InStr(a, "A") Then NewSheet.Cells(i, 2) = Mid(NewSheet.Cells(i, 2), 2, Len(NewSheet.Cells(i, 2))) End If End If If Len(NewSheet.Cells(i, 3)) > 2 Then a = Left(NewSheet.Cells(i, 3), 2) If InStr(a, "B") Then NewSheet.Cells(i, 3) = Mid(NewSheet.Cells(i, 3), 2, Len(NewSheet.Cells(i, 3))) End If End If If Len(NewSheet.Cells(i, 4)) > 2 Then a = Left(NewSheet.Cells(i, 4), 2) If InStr(a, "C") Then NewSheet.Cells(i, 4) = Mid(NewSheet.Cells(i, 4), 2, Len(NewSheet.Cells(i, 4))) End If End If If Len(NewSheet.Cells(i, 5)) > 2 Then a = Left(NewSheet.Cells(i, 5), 2) If InStr(a, "D") Then NewSheet.Cells(i, 5) = Mid(NewSheet.Cells(i, 5), 2, Len(NewSheet.Cells(i, 5))) End If End If If Len(NewSheet.Cells(i, 6)) > 2 Then a = Left(NewSheet.Cells(i, 6), 2) If InStr(a, "E") Then NewSheet.Cells(i, 6) = Mid(NewSheet.Cells(i, 6), 2, Len(NewSheet.Cells(i, 6))) End If End If Rs.Fields("XXA") = jm(Trim(NewSheet.Cells(i, 2))) Rs.Fields("XXB") = jm(Trim(NewSheet.Cells(i, 3))) Rs.Fields("XXC") = jm(Trim(NewSheet.Cells(i, 4))) Rs.Fields("XXD") = jm(Trim(NewSheet.Cells(i, 5))) Rs.Fields("XXE") = jm(Trim(NewSheet.Cells(i, 6))) Rs.Fields("ZJID") = ZJId(j) Rs.Fields("STJX") = jm(Trim(NewSheet.Cells(i, 9))) Rs.Fields("TMFS") = jm(Trim(NewSheet.Cells(i, 10))) If Len(Trim(NewSheet.Cells(i, 7))) = "1" Then If Trim(UCase(NewSheet.Cells(i, 7))) = "A" Or Trim(UCase(NewSheet.Cells(i, 7))) = "B" Or Trim(UCase(NewSheet.Cells(i, 7))) = "C" Or Trim(UCase(NewSheet.Cells(i, 7))) = "D" Or Trim(UCase(NewSheet.Cells(i, 7))) = "E" Then Rs.Fields("TMtype") = "单选" Select Case Trim(NewSheet.Cells(i, 7)) Case "A" Rs.Fields("TMDA") = 0 Case "B" Rs.Fields("TMDA") = 1 Case "C" Rs.Fields("TMDA") = 2 Case "D" Rs.Fields("TMDA") = 3 Case "E" Rs.Fields("TMDA") = 4 End Select End If If Trim(NewSheet.Cells(i, 7)) = "0" Or Trim(NewSheet.Cells(i, 7)) = "1" Then Rs.Fields("TMtype") = "判断" Rs.Fields("TMDA") = Trim(NewSheet.Cells(i, 7)) End If Else Rs.Fields("TMtype") = "多选" Dim DXStr As String DXStr = "" If InStr(Trim(NewSheet.Cells(i, 7)), "A") Then DXStr = DXStr & "0" Else DXStr = DXStr & "8" End If If InStr(Trim(NewSheet.Cells(i, 7)), "B") Then DXStr = DXStr & "1" Else DXStr = DXStr & "8" End If If InStr(Trim(NewSheet.Cells(i, 7)), "C") Then DXStr = DXStr & "2" Else DXStr = DXStr & "8" End If If InStr(Trim(NewSheet.Cells(i, 7)), "D") Then DXStr = DXStr & "3" Else DXStr = DXStr & "8" End If If InStr(Trim(NewSheet.Cells(i, 7)), "E") Then DXStr = DXStr & "4" Else DXStr = DXStr & "8" End If Rs.Fields("TMDA") = jm(DXStr) End If Rs.MoveNext Next i Label1.Caption = "读取完毕!共读取" & i - 2 & "个记录" Rs.MoveFirst Label1.Caption = "正在重新分配题目号码!" For i = 1 To UBound(ZJId) DoEvents Sql = "select * from tminfo where zjid=" & ZJId(i) Set Rs = ExecuteSQL(Sql, MsgTxt) Label1.Caption = "正在重新分配题目号码 ID:" & ZJId(i) If Rs.RecordCount > 0 Then For j = 1 To Rs.RecordCount DoEvents Rs.Fields("TMNum") = j Rs.Update Label1.Caption = "正在重新分配题目号码 ID:" & ZJId(i) & " 题目号码:" & j Rs.MoveNext Next j End If Next i If MsgBox("题目导入完毕!请将本文件夹中的TK文件复制到【给客户使用文件夹】即可!", vbQuestion Or vbOKCancel, "消息询问") = vbOK Then End End If Text9.Text = "" Main.add_zj ListView2.HideSelection = False ListView1.HideSelection = False If ListView2.ListItems.Count > 0 Then Call ListView2_ItemClick(ListView2.ListItems.Item(1)) End If err1: If Err.Number > 0 Then MsgBox Err.Description, vbCritical, "错误提示" Exit Sub End If End Sub