Ошибка при открытии файла excel из Outlook: несколькими пользователями. Автоматизация

Question

У меня есть макрос в Outlook 2010. Он проверяет, открыт ли файл другим пользователем, если нет, тогда откройте его, заполните его данными, сохраните и закройте.

Когда пользователи используют его одновременно, более быстрый ПК, похоже, победит, а другой пользователь заблокирован, что приведет к ошибке и даже заморозит Outlook.

Сначала я пытался незащищенные рабочие книги, так что каждый может использовать макросы в то же время (я не делал isworkbookopen функции тогда), но это привело к ошибке автоматизации:

ошибка времени выполнения " -2147418111 (80010001) ':

ошибка автоматизации

Вызов был отклонен вызываемым когда отлажена, она подчеркнула 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, чтобы проверить, открыта ли рабочая книга, но я думаю, что это было бы намного чище и проще в устранении неполадок. Я бы рекомендовал вам попробовать адаптировать свой код, чтобы следовать этому примеру.