| 网站首页 | 业界新闻 | 小组 | 交易 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
共有 1808 人关注过本帖
标题:电子表格如何用代码来关闭,打开就关不了,各种方法都试过,没用
只看楼主 加入收藏
natesc
Rank: 1
等 级:新手上路
帖 子:40
专家分:0
注 册:2013-9-15
结帖率:37.5%
收藏
已结贴  问题点数:16 回复次数:9 
电子表格如何用代码来关闭,打开就关不了,各种方法都试过,没用
试题批量导入模板.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
搜索更多相关主题的帖子: 电子 如何 
2017-03-28 12:02
xzlxzlxzl
Rank: 15Rank: 15Rank: 15Rank: 15Rank: 15
来 自:湖北
等 级:贵宾
威 望:125
帖 子:1091
专家分:5825
注 册:2014-5-3
收藏
得分:6 
经测试,用如下两条语句可完全关闭:
   NewBook.Close
   Set NewApp = Nothing
2017-03-28 14:45
natesc
Rank: 1
等 级:新手上路
帖 子:40
专家分:0
注 册:2013-9-15
收藏
得分:0 
回复 2楼 xzlxzlxzl
谢谢楼主,加在最后吗,加在最后经测试不行


[此贴子已经被作者于2017-3-28 19:17编辑过]

附件: 游客没有浏览附件的权限,请 登录注册
2017-03-28 19:12
ZHRXJR
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:116
帖 子:1003
专家分:5352
注 册:2016-5-10
收藏
得分:6 
ExcelApp.Visible = False       '不显示Excel界面
ExcelApp.Quit   '关闭Excel
对象名称可能与你的不一样,ExcelApp 是 Set ExcelApp = CreateObject("Excel.Application") 这里创建的Excel 对象

请不要选我做版主
2017-03-28 20:52
natesc
Rank: 1
等 级:新手上路
帖 子:40
专家分:0
注 册:2013-9-15
收藏
得分:0 
谢谢,不知道什么原因,各种方法都试过,还是关不了。在进程中也看不到具体名称,只有这个
附件: 游客没有浏览附件的权限,请 登录注册
2017-03-29 11:12
卓文
Rank: 2
等 级:论坛游民
威 望:2
帖 子:18
专家分:38
注 册:2012-6-3
收藏
得分:6 
    NewBook.Close (False) '关闭EXCEL工作簿
    NewApp.Quit '关闭EXCEL
    Set NewApp = Nothing '释放EXCEL对象
2017-03-29 15:45
natesc
Rank: 1
等 级:新手上路
帖 子:40
专家分:0
注 册:2013-9-15
收藏
得分:0 
回复 6楼 卓文
谢谢,依然是3楼的问题,关不了
2017-03-29 21:07
natesc
Rank: 1
等 级:新手上路
帖 子:40
专家分:0
注 册:2013-9-15
收藏
得分:0 
回复 4楼 ZHRXJR
版主好,原程序附上,请看
https://bbs.bccn.net/thread-475669-1-1.html
2017-03-30 21:32
ZHRXJR
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:116
帖 子:1003
专家分:5352
注 册:2016-5-10
收藏
得分:0 
回复 8楼 natesc
哎,怎么说呢?一个非常简单的问题,你搞的太复杂了,Excel(还是2003版本)导入到Access,非常简单的。
你的代码我没有仔细看,导入到2003的Access二步就完成了,读出数据,存储到Access中,总代码要不了100行。字段仅仅9个,太简单了。
联系我,给你代码。

请不要选我做版主
2017-03-30 22:20
natesc
Rank: 1
等 级:新手上路
帖 子:40
专家分:0
注 册:2013-9-15
收藏
得分:0 
回复 9楼 ZHRXJR
谢谢,我要的是上面原程序中关闭电子表格,要是改了程序,影响我相关的其它操作,对我来说就没有什么帮助了。谢谢

[此贴子已经被作者于2017-3-31 10:55编辑过]

2017-03-31 10:38
快速回复:电子表格如何用代码来关闭,打开就关不了,各种方法都试过,没用
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.064699 second(s), 8 queries.
Copyright©2004-2020, BCCN.NET, All Rights Reserved