为 excel 文件中的单元格设置值在打开多个 excel 文件时出错
Set value for cell in excel file get error when open multi excel files
我想在outlook中写一个宏来检查excel文件是否打开，如果这个文件没有打开，打开它并为单元格（1,1）设置值。否则，如果它正在打开，只需为 cell(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
但我的问题是打开此文件时同时打开其他一些文件。它无法为单元格设置值并出现错误 "Subscript out of range"。当我调试时，错误定位在"Set WB = objExcel.Workbooks("Book2.xlsm")”。你能告诉我它有什么问题吗，我该如何解决。当只有我的单个 excel 文件时，一切都 运行 很好，当用它打开的文件很少时会出现问题
如果打开了多个 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")
如果有多个 Excel.Application 运行ning 实例，您将 运行 遇到问题，但否则这将起作用。
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
下面的代码也适用于多个打开的 Excel 实例。
为适应此 post 而修改的部分代码取自 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
我想在outlook中写一个宏来检查excel文件是否打开，如果这个文件没有打开，打开它并为单元格（1,1）设置值。否则，如果它正在打开，只需为 cell(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
但我的问题是打开此文件时同时打开其他一些文件。它无法为单元格设置值并出现错误 "Subscript out of range"。当我调试时，错误定位在"Set WB = objExcel.Workbooks("Book2.xlsm")”。你能告诉我它有什么问题吗，我该如何解决。当只有我的单个 excel 文件时，一切都 运行 很好，当用它打开的文件很少时会出现问题
如果打开了多个 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")
如果有多个 Excel.Application 运行ning 实例，您将 运行 遇到问题，但否则这将起作用。
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
下面的代码也适用于多个打开的 Excel 实例。
为适应此 post 而修改的部分代码取自 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