excel文件中单元格的设置值打开多个excel文件时得到错误

Question

我想在outlook中编写一个宏来检查是否excel文件打开，如果这个文件没有打开，打开它并为单元格设置值（1 ，1）。否则，如果它是开放的，只需为单元格（1,1）设置值就不需要再次打开它。我这样做，它运行良好。

这里是我的源代码，做这样的

Sub test_3() 
    Dim objExcel As Object 
    Dim WB As Object 
    Dim WS As Object 
    If (IsWorkBookOpen("C:\Users\sang\Desktop\Book2.xlsm") = True) Then 'check whether is file opening? if yes 
     Set objExcel = GetObject(, "Excel.Application") 
     objExcel.Visible = True 
     Set WB = objExcel.Workbooks("Book2.xlsm") 
     WB.Activate 
    Else 'file is not opening 
     Set objExcel = CreateObject("Excel.Application") 
     objExcel.Visible = True 
     Set WB = objExcel.Workbooks.Open("C:\Users\sang\Desktop\Book2.xlsm") 'open file 
     WB.Activate 
    End If 
    Set WS = WB.Worksheets("Sheet1") 
    WS.Range("A1").Value = "haha" 'set value for cell 
End Sub 

Function IsWorkBookOpen(FileName As String) 
    Dim ff As Long, ErrNo As Long 
    On Error Resume Next 
    ff = FreeFile() 
    Open FileName For Input Lock Read As #ff 
    Close ff 
    ErrNo = Err 
    On Error GoTo 0 
    Select Case ErrNo 
    Case 0: IsWorkBookOpen = False 
    Case 70: IsWorkBookOpen = True 
    Case Else: Error ErrNo 
    End Select 
End Function 

但是，当该文件被打开和其他一些文件被打开，也是我的问题是。它不能为单元格设置值，并得到错误“下标超出范围”。当我调试时，错误定位在“Set WB = objExcel.Workbooks（”Book2.xlsm“）”。你能告诉我它有什么问题，我该如何解决它。一切都只是运行正常的时候只是我的一个Excel文件，并获得有一些文件用它打开时，问题

Answer 1

你会碰到的问题，如果有运行中的Excel.Application多个实例，但这会不然工作。

Sub TestWrite() 
    Const FULLNAME As String = "C:\Users\sang\Desktop\Book2.xlsm" 

    Dim objExcel As Object, WB As Object, WS As Object 
    Set objExcel = getExcelAppication 
    objExcel.Visible = True 
    Set WB = getWorkbook(objExcel, FULLNAME) 

    If WB Is Nothing Then 
     MsgBox "File not found: " & FULLNAME, vbInformation, ":(" 
    Else 
     Set WS = WB.Worksheets("Sheet1") 
     WS.Range("A1").Value = "haha" 
    End If 

End Sub 

Function getExcelAppication() As Object 
    Dim objExcel As Object 
    If GetObject("winmgmts:").ExecQuery("select * from win32_process where name='Excel.exe'").Count > 0 Then 
     Set objExcel = GetObject(, "Excel.Application") 
    Else 
     Set objExcel = CreateObject("Excel.Application") 
    End If 
    Set getExcelAppication = objExcel 
End Function 

Function getWorkbook(objExcel As Object, FULLNAME As String) As Object 
    Dim ShortName As String 
    Dim WB As Object, WS As Object 
    ShortName = Right(FULLNAME, Len(FULLNAME) - InStrRev(FULLNAME, "\")) 

    For Each WB In objExcel.Workbooks 
     If WB.Name = ShortName Then 
      Set getWorkbook = WB 
      Exit Function 
     End If 
    Next 

    Set getWorkbook = objExcel.Workbooks.Open(FULLNAME) 

End Function 

Answer 2

如果有的Excel中打开多个实例，那么就无法保证

Set objExcel = GetObject(, "Excel.Application") 

将获得打开文件的实例。

尝试，而不是

Set objExcel = GetObject("C:\Users\sang\Desktop\Book2.xlsm", "Excel.Application") 

或只是

Set objExcel = GetObject("C:\Users\sang\Desktop\Book2.xlsm") 

Answer 3

下面的代码也适用于多个打开的Excel实例。

这是体改适合这个职位的代码的一部分，从Ozgrid

采取下面的代码是有点长，但比它的工作原理很不错的（测试）

Option Explicit 

Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" _ 
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _ 
ByVal lpsz2 As String) As Long 

Private Declare Function IIDFromString Lib "ole32" _ 
(ByVal lpsz As Long, ByRef lpiid As GUID) As Long 

Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _ 
(ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _ 
ByRef ppvObject As Object) As Long 

Private Type GUID 
    Data1 As Long 
    Data2 As Integer 
    Data3 As Integer 
    Data4(7) As Byte 
End Type 

Private Const RETURN_OK As Long = &H0 
Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0 

Sub ComplexTest() 

    Dim hWndXL As Long 
    Dim oXLApp As Object 
    Dim oWB As Object   
    Dim objExcel As Object 
    Dim WB As Object 
    Dim WS As Object 
    Dim FullFileName As String 
    Dim CleanFileName As String 

    FullFileName = "C:\Users\sang\Desktop\Book2.xlsm" 
    CleanFileName = Right(FullFileName, Len(FullFileName) - InStrRev(FullFileName, "\")) 

    ' check if the Excel's file name is already open 
    If IsWorkBookOpen(FullFileName) Then           
     ' first Excel Window 
     hWndXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)    
     ' got one Excel instance open ? 
     Do While hWndXL > 0 

      ' Get a reference to current excel instance 
      If GetReferenceToXLApp(hWndXL, oXLApp) Then      
       ' loop through workbooks 
       For Each oWB In oXLApp.Workbooks 
        If oWB.Name = CleanFileName Then 
         Set WB = oWB 
        End If 
       Next 
      End If 

      ' Find the next Excel Window 
      hWndXL = FindWindowEx(0, hWndXL, "XLMAIN", vbNullString) 
     Loop 
    Else 
     Set objExcel = CreateObject("Excel.Application") 
     objExcel.Visible = True 
     Set WB = objExcel.Workbooks.Open(FullFileName) 'open file 
    End If 

    Set WS = WB.Worksheets("Sheet1") 
    WS.Range("A1").Value = "haha" 'set value for cell 

End Sub 

' This section of code was taken from Ozgrid 
' link: http://www.ozgrid.com/forum/showthread.php?t=182853 
' 
' The Function Returns a reference to a specific instance of Excel. 
' The Instance is defined by the Handle (hWndXL) passed by the calling procedure 

Function GetReferenceToXLApp(hWndXL As Long, oXLApp As Object) As Boolean 

    Dim hWinDesk As Long 
    Dim hWin7 As Long 
    Dim obj As Object 
    Dim iID As GUID 

    ' Rather than explaining, go read 
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms687262(v=vs.85).aspx 
    Call IIDFromString(StrPtr(IID_IDispatch), iID) 

    ' We have the XL App (Class name XLMAIN) 
    ' This window has a child called 'XLDESK' (which I presume to mean 'XL desktop') 
    ' XLDesk is the container for all XL child windows.... 
    hWinDesk = FindWindowEx(hWndXL, 0&, "XLDESK", vbNullString) 

    ' EXCEL7 is the class name for a Workbook window (and probably others, as well) 
    ' This is used to check there is actually a workbook open in this instance. 
    hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString) 

    ' Deep API... read up on it if interested. 
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/dd317978(v=vs.85).aspx 
    If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iID, obj) = RETURN_OK Then 
     Set oXLApp = obj.Application 
     GetReferenceToXLApp = True 
    End If 

End Function 

Function IsWorkBookOpen(FileName As String) 

    Dim ff As Long, ErrNo As Long 

    On Error Resume Next 
    ff = FreeFile() 
    Open FileName For Input Lock Read As #ff 
    Close ff 
    ErrNo = Err 
    On Error GoTo 0 

    Select Case ErrNo 
     Case 0: IsWorkBookOpen = False 
     Case 70: IsWorkBookOpen = True 
     Case Else: Error ErrNo 
    End Select 

End Function