Question

我在Outlook 2010中有一个宏。它会检查另一个用户是否打开了一个文件，如果没有，则打开它，填充数据，保存并关闭它。

当用户同时使用它时，更快的PC似乎赢了，而另一个用户被锁定，从而导致错误甚至冻结Outlook。

首先我尝试了不受保护的工作簿，所以每个人都可以同时使用这些宏（我当时没有使用isworkbookopen函数），但是它导致了自动化错误：

运行时错误＆＃39; -2147418111（80010001）＆＃39;：

自动化错误

调试时

调用被被调用者拒绝，它突出显示了wb.open strpath部分

以下是我的代码的一部分：

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)

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


Public Sub test()
Sleep 1000
End Sub


Sub Sample()

Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Excel.Worksheet

Dim xlApp2 As Object
Dim xlWB2 As Object
Dim xlSheet2 As Excel.Worksheet

Const strpath As String = "P:\Head\....xls"
Const strpath2 As String = "P:\Head\....xls"
Dim Ret
Dim Ret2

Z = 0

0:
Ret = IsWorkBookOpen(strpath) 'the path of the workbook
Ret2 = IsWorkBookOpen(strpath2)

If Ret = False Then
GoTo masodikif
Else
GoTo elseag
masodikif:
    If Ret2 = False Then
    GoTo ifvege
    Else
    GoTo elseag

elseag:     Call test
         Z = Z + 1
        If Z = 50 Then
        MsgBox "Please try again in a few second!"            
        End
        Exit Sub
        End If
        GoTo 0:

        End If
        End If

ifvege:


If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
    Application.StatusBar = "Please wait while Excel source is opened ... "
    Set xlApp = CreateObject("Excel.Application")
    bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.workbooks.Open(strpath)
Set xlSheet = xlWB.sheets("Munka1")



If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp2 = GetObject(, "Excel.Application")
If Err <> 0 Then
    Application.StatusBar = "Please wait while Excel source is opened ... "
    Set xlApp2 = CreateObject("Excel.Application")
    bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB2 = xlApp2.workbooks.Open(strpath2)
Set xlSheet2 = xlWB2.sheets("Munka1")

再次提供大量代码

xlWB2.Save
xlWB2.Close savechanges:=True

xlWB.Save
xlWB.Close savechanges:=True


Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing

Set xlApp2 = Nothing
Set xlWB2 = Nothing
Set xlSheet2 = Nothing

Answer 1

我认为使用vba原语检查工作簿是否打开是错误的方法。我可以尊重你也试图编写可重用的潜艇，但在这种情况下，我认为他们不必要地使你的代码复杂化。如果我正在做这样的事情，这就是我接近它的方式。

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)

Public Sub Sample()
    'I avoid using late binding.  If this is VBS, you'll have to, but if it is in Outlook, I'd set the references.
    Dim xlApp As Excel.Application
    Dim xlWB as Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    '... follow the example for the rest of the dims
    Const strpath as string = "P:\Head\....xls"
    Const strpath as string = "P:\Head\....xls"
    Dim Z as integer
    Z = 0
    Set xlApp = New Excel.Application
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Do until Z = 50 or xlWB.ReadOnly = False
        xlWB.Close
        Set xlWB = Nothing
        Sleep(1000)
        Set xlWB = xlApp.Workbooks.Open(strPath)
        Z = Z + 1
    Loop
    If Z = 50 and xlWB.ReadOnly = True then
        MsgBox "Please try again in a few seconds!"
        End
    End If
    'If we've made it here, we have read write access to the workbook
    'Do stuff...

我没有写出检查两个工作簿的所有代码，但是你应该从这里了解如何处理它。并不是说你的方法在使用vba原语检查工作簿是否打开之外是错误的，但我认为这将更清晰，更容易进行故障排除。我建议您尝试调整代码以遵循此示例。

从outlook打开excel文件时出错：由多个用户。自动化

1 个答案: