中止任务管理器（进程）一个正在运行的进程

[digitboy]

各位前辈/老师：

请教一下如何中止一个在任务管理器中进程项中正在运行的一个进程，在任务管理器不可见（没有），仅仅在进程中才可以看到。下列代码是启动EXCEL程序，并向启运的EXCEL文件写入数据，每运行一次进程中增加一次，占用内存，（文件在第一次启动时运行正常，如果不关闭EXCEL文件则在任何时侯都正常，只是占用内存严重）在退出释放时不能解决，不知哪里出了问题，烦请指点一下，谢谢！


另外补充一点：

在退出进程时不能退出不是因本程序打开的EXCEL文件，（此时在任务管理器中|应用程序项是可见的），否则用户会骂人哦*^_^*。
Sub WriteToXls()

Dim Sql$
Dim i%, j%, k%, iStartRow%
Dim objExcel As New Excel.Application
Dim objBook As New Excel.Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Call OpenXLSFile("ProcedurePlan", False) '打开一个指定的文件下面根据SQL结果集，向其中写入数据

Set objExcel = CreateObject("Excel.Application")
Set objBook = Workbooks("ProcedurePlan.xls")
Call OpenConnDB
Call ProdPlan_DB


Sql = "Select 工单编号,产品型号,验货日期,出货日期,订单数量,电子资料预计始日,电子资料预计末日,结构资料预计始日,结构资料预计末日,包装资料预计始日,包装资料预计末日,电子物料预计始日,电子物料预计末日,壳料物料预计始日,壳料物料预计末日,包装物料预计始日,包装物料预计末日,SMT生产预计始日,SMT生产预计末日,装配生产预计始日,装配生产预计末日,包装生产预计始日,包装生产预计末日 From " & ViewTblName
Rst.Open Sql, Conn, 1, 1
.... 写入数据省略


' ActiveWorkbook.SaveAs App.Path & "\" & DealType & Format(Now(), "yyyymmddhhmmss") & ".xls"
ActiveSheet.Name = PrdSeries

'下面三条语句在运行中好像发挥不了什么作用
objBook.Close
Set objBook = Nothing
objExcel.Quit

Call CloseConnDB
Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub

[digitboy]

Sandrer老师:

非常感谢你提供的代码以及对本贴的关注，仔细看了你的代码，其中ExcelOpened函数要解决的问题与我的问题类似，只不过我要打开的文件是一个模板文件，并且不允许出现进程中存在而以出现提示信息告诉用户的方式让用户自行关闭程序，以保证程序的正常运行。在这里我必须帮用户解决这个问题，而不仅仅是提示。

我这个程序要求用户根据数据库数据的动态更新即时生成新的图表，现在是当反复更新时， 强制关闭任务管理器中EXCEL进程出现 实时错误：462,远程服务器不存在或不能使用；不关闭任务管理器中EXCEL进程出现 实时错误：91，对象变量或With块变量未设置 ，左右都不是办法，真是郁闷。查看对应的MSDN帮助，好像程序本身也没有什么问题，不知为何当第二次运行时，则下面两种赋值方式都失败
Set objBook = ActiveWorkbook
'Set objBook = Workbooks( "ProcedurePlan.xls ")

[tianhuo_soft]

Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long

Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long

Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 1024
End Type

Const TH32CS_SNAPHEAPLIST = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPTHREAD = &H4
Const TH32CS_SNAPMODULE = &H8
Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Const TH32CS_INHERIT = &H80000000
Dim pid As Long
Dim pname As String
Const sEndProess As String = "explorer.exe" '注意必须小写，是关闭的进程名称
'---------------------------------------------------------
Private Sub Command1_Click()
Dim my As PROCESSENTRY32
Dim l As Long
Dim l1 As Long
Dim flag As Boolean
Dim mName As String
Dim i As Integer

l = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
If l Then
my.dwSize = 1060
If (Process32First(l, my)) Then '遍历第一个进程
Do
i = InStr(1, my.szExeFile, Chr(0))
mName = LCase(Left(my.szExeFile, i - 1))
If mName = lcase(sEndProess) Then
pid = my.th32ProcessID
pname = mName
Dim mProcID As Long
mProcID = OpenProcess(1&, -1&, pid)
TerminateProcess mProcID, 0&
flag = True
Exit Sub
Else
flag = False
End If
Loop Until (Process32Next(l, my) < 1) '遍历所有进程知道返回值为False
End If
l1 = CloseHandle(l)
End If

End Sub

Command1是按钮

[digitboy]

各位前辈/老师：

关于强制关闭进程我已经找到一个程序，同样的问题
请教一下为什么下列程序
强制关闭任务管理器中EXCEL进程出现 实时错误：462,远程服务器不存在或不能使用；
不关闭任务管理器中EXCEL进程出现 实时错误：91，对象变量或With块变量未设置

下列过程功能是实现对数据库的数据写入到EXCEL文件中,写入部分代码省略
该过程第一次执行此过程正常运行，当再次执行时出现上述问题，调试了一个上午都没有搞定，烦请知悉的前辈/老师指点一下，谢谢！

Sub ProdPlan_Chart()
Dim strPath$
Dim Sql$
Dim i%, j%, k%, iStartRow%

Dim objExcel As New Excel.Application
Dim objBook As New Excel.Workbook

Set objExcel = CreateObject("Excel.Application")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

strPath = App.Path & "\Template\ProcedurePlan.xls"
objExcel.Workbooks.Open strPath, Password:=XLS_W_PWD
' objExcel.Visible = True
Set objBook = ActiveWorkbook
' Set objBook = Workbooks("ProcedurePlan.xls")
当第二次运行时，Set objBook = Workbooks("ProcedurePlan.xls")出现实时错误91

Call OpenConnDB
Call ProdPlan_DB


Sql = "Select * From " & ViewTblName
Rst.Open Sql, Conn, 1, 1
...


ActiveWorkbook.SaveAs App.Path & "\" & DealType & Format(Now(), "yyyymmddhhmmss") & ".xls"

ActiveSheet.Name = PrdSeries
...'向文件写入数据
objBook.Close
' Set objBook = Nothing
' Set objExcel = Nothing
' objExcel.Quit

' Call CloseExeFile("Excel.exe")'强制关闭EXCEL进程过程

Call CloseConnDB
' Application.CutCopyMode = False
' Application.ScreenUpdating = True

End Sub

[Sandrer]

为什么要强制关闭Excel呢？
下面是我以前写的一个Excel2Txt的程序，你看一下对你有没有帮助。

Option Explicit

Private xlApp As Excel.Application
Private xlSheet As Excel.Worksheet

Private FSO As Scripting.FileSystemObject
Private FS As TextStream

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Sub cmdBrowse_Click(Index As Integer)
    With cdlShowFolder
        Select Case Index
            Case 0
                .InitDir = App.Path
                .DialogTitle = "请选择Excel工资表文件"
                .FileName = ""
                .Filter = "Excel 工作薄 (*.xls)|*.xls"
                .ShowOpen
                If .FileName <> "" Then txtPath(0) = .FileName
            Case 1
                .InitDir = App.Path
                .DialogTitle = "请选择文本文件保存路径"
                .FileName = "工资表"
                .Filter = "文本文件 (*.txt)|*.txt"
                .ShowSave
                If .FileName <> "工资表" Then txtPath(1) = .FileName
        End Select
    End With
End Sub

Private Sub cmdSave_Click()
    Dim strExcelFile As String, strTxtFile As String
    Dim i As Long, ii As Long, iii As Long
    Dim lngCol As Long, lngRow As Long
    Dim strContent(2) As String, strContentLine As String
    Dim strExploerFile As String
    On Error GoTo ErrHandle
    If Dir(txtPath(0)) = "" Then
        MsgBox "工资表文件不存在，可能已被删除！", vbCritical, "错误信息"
        Exit Sub
    End If
    strExcelFile = txtPath(0)
    If ExcelOpened(strExcelFile) Then Exit Sub
    DoEvents
    strTxtFile = txtPath(1)
    If Dir(strTxtFile) <> "" Then Kill strTxtFile
    Set xlApp = New Excel.Application
    xlApp.Workbooks.Open strExcelFile
    Set xlSheet = xlApp.Workbooks(1).Worksheets(1)
    With xlSheet
        .Activate
        lblAction.Caption = "正在检测工作薄内容....."
        DoEvents
        For i = 1 To .Columns.Count
            If .Cells(2, i).Borders(xlEdgeRight).LineStyle < 0 And .Cells(2, i).Text = "" Then
                lngCol = i
                Exit For
            End If
        Next i
        For i = 1 To lngCol
            For ii = 2 To .Rows.Count
                If .Cells(ii, i).Borders(xlEdgeRight).LineStyle < 0 And .Cells(ii, i).Text = "" Then
                    iii = ii
                    If iii > lngRow Then lngRow = iii
                    GoTo ForNext
                End If
            Next ii
ForNext:
        Next i
        lngRow = lngRow - 1: lngCol = lngCol - 1
        lblAction.Caption = "共有" & lngCol & "列，" & lngRow & "行！现在开始导出内容....."
        DoEvents
        pbrInfo.Min = 0: pbrInfo.Max = lngRow: pbrInfo.Visible = True
        Set FSO = New Scripting.FileSystemObject
        Set FS = FSO.OpenTextFile(strTxtFile, ForAppending, True)
        For i = 3 To lngRow
            strContentLine = ""
            strContent(0) = .Cells(i, 1).Text
            If CheckLength(strContent(0)) < 12 Then
                strContent(0) = strContent(0) & String(20 - CheckLength(strContent(0)), " ")
            End If
            strContent(1) = .Cells(i, 2).Text
            If CheckLength(strContent(1)) < 23 Then
                strContent(1) = strContent(1) & String(30 - CheckLength(strContent(1)), " ")
            End If
            strContent(2) = Replace(.Cells(i, 3).Text, ".", "")
            If CheckLength(strContent(2)) < 10 Then
                strContent(2) = String(10 - CheckLength(strContent(2)), " ") & strContent(2)
            End If
            For ii = LBound(strContent) To UBound(strContent)
                strContentLine = strContentLine & strContent(ii) & "　"
            Next ii
            FS.WriteLine strContentLine
            If pbrInfo.Value < pbrInfo.Max Then
                pbrInfo.Value = pbrInfo.Value + 1
            End If
        Next i
        FS.Close
        Set FS = Nothing
        Set FSO = Nothing
        If MsgBox("文件导出完毕，是否现在打开？", vbYesNo + vbInformation, "询问") = vbYes Then
            strExploerFile = IIf(Right(SystemPath, 1) <> "\", SystemPath & "\notepad.exe", SystemPath & "notepad.exe")
            If Dir(strExploerFile) = "" Then
                MsgBox "程序不能找到文本编辑器" & vbCrLf & vbCrLf & strTxtFile & "不能打开！", vbCritical, "出错信息"
            Else
                Shell strExploerFile & " " & strTxtFile, vbMaximizedFocus
            End If
        End If
        lblAction.Visible = False: lblAction.Caption = ""
        pbrInfo.Value = pbrInfo.Min: pbrInfo.Visible = False
    End With
    
    Exit Sub
    
ErrHandle:
    MsgBox "发生错误，请检查你选择的文件格式是否符合工资表的格式！" & vbCrLf & vbCrLf & _
            "工资表格式应该为：第一行为文件标题、第二行为内容标题、第三行以下为内容；总共分三列！", vbCritical, "出错信息"
    MsgBox Err.Description
    xlApp.Workbooks.Close
    xlApp.Quit
    Set xlSheet = Nothing
    Set xlApp = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    xlApp.Workbooks.Close
    xlApp.Quit
    Set xlSheet = Nothing
    Set xlApp = Nothing
End Sub

Private Function CheckLength(strString As String) As Long
    Dim lngLength As Long, i As Long
    lngLength = Len(strString)
    For i = 1 To lngLength
        If Asc(Mid(strString, i, 1)) >= 0 And Asc(Mid(strString, i, 1)) <= 255 Then
            CheckLength = CheckLength + 1
        Else
            CheckLength = CheckLength + 2
        End If
    Next i
End Function

Private Function ExcelOpened(Optional strFileName As String) As Boolean
    Dim MyXL As Object, strMessage As String
    On Error Resume Next
    Set MyXL = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Err.Clear
        ExcelOpened = False
    Else
        If MyXL.Workbooks(1).FullName = "" Then
            strMessage = "程序检测到你已经打开了一个Excel窗口，但没有打开任何文件！" & vbCrLf & vbCrLf
            strMessage = strMessage & "是否将它关闭？"
            If MsgBox(strMessage, vbYesNo + vbInformation, "询问") = vbYes Then
                MyXL.Quit
                ExcelOpened = False
            Else
                MsgBox "因为已有一个Excel窗口打开，程序无法继续工作！", vbExclamation, "出错信息"
                ExcelOpened = True
            End If
        ElseIf MyXL.Workbooks(1).FullName = strFileName And strFileName <> "" Then
            strMessage = "需要导出数据的工作薄已被Excel打开，是否需要保存并退出？"
            If MsgBox(strMessage, vbYesNo + vbInformation, "询问") = vbYes Then
                MyXL.Workbooks(1).Save
                MyXL.Workbooks(1).Close
                MyXL.Quit
                ExcelOpened = False
            Else
                strMessage = "程序无法继续执行操作，请先关闭你正在操作的工作薄！"
                MsgBox strMessage, vbExclamation, "出错信息"
                ExcelOpened = True
            End If
        Else
            strMessage = "程序检测到你已经打开了一个Excel窗口，并且已经打开了一个（或多个）文档！" & vbCrLf & vbCrLf
            strMessage = strMessage & "你需要将它关闭才能继续工作！是否现在将它关闭？"
            If MsgBox(strMessage, vbYesNo + vbInformation, "询问") = vbYes Then
                MyXL.Workbooks(1).Save
                MyXL.Workbooks(1).Close
                MyXL.Quit
                ExcelOpened = False
            Else
                MsgBox "因为已有一个Excel窗口打开并且存在一个文档，程序无法继续工作！", vbExclamation, "出错信息"
                ExcelOpened = True
            End If
        End If
    End If
    Set MyXL = Nothing
End Function

Public Function SystemPath() As String
    Dim s As String, l As Long
    l = 255
    s = String(l, 0)
    GetSystemDirectory s, l
    SystemPath = Left(s, InStr(s, Chr(0)) - 1)
End Function

[njxl]

很久没来看了,没细看你的代码,给你一段我以前调的VB过程

----------杀指定进程
Public Function kill_ADM(ByVal Kill_name As String) As String
On Error GoTo kill_ADMErr

Dim objWMIService As Object
Dim colProcesslist As Object
Dim objProcess As Object
Set objWMIService = CreateObject("winmgmts:{impersonationLevel=Impersonate}!root\cimv2")
Set colProcesslist = objWMIService.ExecQuery("select * from win32_process where name='" + Kill_name + "'")

For Each objProcess In colProcesslist
objProcess.Terminate
Next
kill_ADM = "OK"
Exit Function

kill_ADMErr:
Err.Clear
kill_ADM = "error"
End Function

[digitboy]

非常感谢Sandrer 和njxl两位前辈的热情指点，经过测试，我通过
with activeworkbook.activesheet
....
end with
顺利解决
无需定义Dim objBook As New Excel.Workbook
再次感谢

[digitboy]

不好意思，忘了感谢tianhuo_soft 前辈