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

Question

I have a macro in Outlook 2010. It checks if a file is opened by another user, if not then open it, fill it up with data, save it and close it.

When the users use it at the same time, the faster pc seems to win, and the other user is locked out, thus resulting in a error and even freezes Outlook.

First I tried unprotected workbooks, so everyone can use the macros at the same time (I didn't do the isworkbookopen function then), but it resulted in an automation error:

Run-time error '-2147418111 (80010001)':

Automation error

Call was rejected by callee when debugged, it highlighted the wb.open strpath part

Here is a part of my code now:

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")

A lot of code again

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

I think using the vba primitives to check to see if the workbook is open is the wrong approach here. I can respect that you're trying to write reusable subs as well, but in this case I think they needlessly complicate your code. If I were doing something like this, here is how I would approach it.

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... 

I didn't write out all the code to check both workbooks, but you should get the general idea of how to handle it from here. Not that your approach is wrong outside of using the vba primitives to check to see if the workbook is open, but I think this would be much cleaner and easier to troubleshoot. I'd recommend you try adapting your code to follow this example.