Вопрос: Библиотечные ссылки (поиск нарушенных ссылок)

Совет: 
Sub ReferenceProperties()
    Dim ref As Reference

    ' Перечисление семейства ссылок.
    For Each ref In References
        ' Проверка свойства IsBroken.
        If ref.IsBroken = False Then
            Debug.Print "Имя: ", ref.Name
            Debug.Print "Путь: ", ref.FullPath
            Debug.Print "Версия: ", ref.Major & "." & ref.Minor
            Debug.Print "================"
        Else
            Debug.Print "Коды GUID для нарушенных ссылок:"
            Debug.Print ref.Guid
            Debug.Print "Имя: ", ref.Name
            Debug.Print "================"
        End If
    Next ref

End Sub
=======================================================
Вопрос: Ccылки на ADOX  разных версий

Совет: 
Программист-Любитель 

 Я благополучно наступил на эти грабли. При переносе из одной версии оффиса в другую у меня при запуске автоматически переликовываются таблицы из отдельного файла и ссылки на библиотеки. Где-то ADOX версии 2.8, где-то 2.7 ... 2.5. Но GUID у них одинаковый.

    Open Application.CurrentProject.Path & "\\" & "Application.Log.Startup" For Output As #1
    Print #1, "Starting Application", Now
    Print #1, ""
    
    Dim ref As Reference
    For Each ref In Application.References
        If Not ref.IsBroken Then
            Print #1, ref.Name, ref.Major, ref.Minor, ref.Guid, ref.FullPath
        Else
            Print #1, "<Broken reference>", ref.Major, ref.Minor, ref.Guid, ""
        End If
    Next ref
    
    With Application.References

        On Error Resume Next
        'Linking ADODB 
        Print #1, "AddFromGuid ""{00000205-0000-0010-8000-00AA006D2EA4}"", 2, 5"
        .AddFromGuid "{00000205-0000-0010-8000-00AA006D2EA4}", 2, 5
        If Err.Number <> 0 Then
            Print #1, Err.Number, Err.Description
            Err.Clear
        End If
        
        'Linking ADOX from 2.8 to 2.5 
        Print #1, "AddFromGuid ""{00000600-0000-0010-8000-00AA006D2EA4}"", 2, 8"
        .AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}", 2, 8
        If Err.Number = 0 Then GoTo ADD_REFERENCE_OK
        Print #1, Err.Number, Err.Description
        Err.Clear
        
        Print #1, "AddFromGuid ""{00000600-0000-0010-8000-00AA006D2EA4}"", 2, 7"
        .AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}", 2, 7
        If Err.Number = 0 Then GoTo ADD_REFERENCE_OK
        Print #1, Err.Number, Err.Description
        Err.Clear
        
        Print #1, "AddFromGuid ""{00000600-0000-0010-8000-00AA006D2EA4}"", 2, 6"
        .AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}", 2, 6
        If Err.Number = 0 Then GoTo ADD_REFERENCE_OK
        Print #1, Err.Number, Err.Description
        Err.Clear
        
        Print #1, "AddFromGuid ""{00000600-0000-0010-8000-00AA006D2EA4}"", 2, 6"
        .AddFromGuid "{00000600-0000-0010-8000-00AA006D2EA4}", 2, 5
        If Err.Number = 0 Then GoTo ADD_REFERENCE_OK
        Print #1, Err.Number, Err.Description
        Err.Clear
        
    End With
    
ADD_REFERENCE_OK:
    Close #1

  Да, чуть не забыл: при выгрузке ОБЯЗАТЕЛЬНО
 отцепите благополучно установленные ссылки. Сломаные у меня програмно так и не удалились, а правильная на место не становится, пока плохая есть. Только руками в окне VBA.

=========================
Вопрос: Библиотечные ссылки: Получение параметров всех установленных ссылок и сохранение их в таблице

Совет: 
Данная функция сохраняет все установленные БИБЛИОТЕЧНЫЕ ссылки и ВСЕ их параметры в специальной табличке - "JS_References" - кою сама же и создает. 
 
Function JS_TableWithReferences()
Dim MyTable As TableDef
Dim MyField As Field
Dim MyRst As Recordset
Dim MyIdx As Index

 

Dim MyReference As Reference
Dim MyRefName As String
Dim MyRefPath As String
Dim MyRefVer As String
Dim MyRefGUID As String
Dim MyRefBuildIn As Boolean


Dim MySQL As String

 

'Создаем табличку
On Error Resume Next
CurrentDb.TableDefs.Delete "JS_References"
Err.Clear
Set MyTable = CurrentDb.CreateTableDef("JS_References")
MyTable.Fields.Append MyTable.CreateField("Ref_Name", dbText, 40)
MyTable.Fields.Append MyTable.CreateField("Ref_Ver", dbText, 4)
MyTable.Fields.Append MyTable.CreateField("Ref_GUID", dbText, 50)
MyTable.Fields.Append MyTable.CreateField("Ref_BuildIn", dbBoolean)
MyTable.Fields.Append MyTable.CreateField("Ref_Path", dbText, 250)

Set MyIdx = MyTable.CreateIndex("Primary Key")
With MyIdx
.Fields.Append .CreateField("Ref_Name")
.Unique = True
.Primary = True
End With
MyTable.Indexes.Append MyIdx
CurrentDb.TableDefs.Append MyTable

'Добавляем записи в табличку
For Each MyReference In References

MyRefName = MyReference.Name
MyRefPath = MyReference.FullPath
MyRefVer = MyReference.Major & "." & MyReference.Minor
MyRefGUID = MyReference.Guid
MyRefBuildIn = MyReference.BuiltIn

MySQL = "INSERT INTO JS_References" & _
" ([Ref_Name], [Ref_Path], [Ref_Ver], [Ref_GUID], [Ref_BuildIn])" & _
" VALUES ('" & MyRefName & "', '" & MyRefPath & _
"', '" & MyRefVer & "', '" & MyRefGUID & "', " & MyRefBuildIn & ")"

DoCmd.SetWarnings False
CurrentDb.Execute MySQL
Next MyReference
End Function

==================
Вопрос: Библиотечные ссылки: Проверка и автоматическое восстановление библиотечных ссылок

Совет: 
Отработает только в MDB.
В MDE файлах проверить - то проверит - а восстановить не сможет. Выход есть но это уже другая история....
 
Public Function RefRestore() As Boolean
Dim MyReference As Reference
Dim i As Integer, x As Integer
'x= количество ссылок
Dim MyErr As Byte
Dim RefGUID() As String

'************************
'Задаем количество ссылок
x = 1
'Задаем размерность массива согласно x
ReDim RefGUID(1 To x, 0 To 5) As String

'Набивка массива
'Ссылка DAO 4.0
RefGUID(1, 0) = "{00025E01-0000-0000-C000-000000000046}"
RefGUID(1, 1) = "DAO"
RefGUID(1, 2) = 4
RefGUID(1, 3) = 0
RefGUID(1, 4) = "DAO350.DLL"
RefGUID(1, 5) = "Microsoft DAO 3.51 Object Library"

'OLE Automation
'RefGUID(2, 0) = "{00020430-0000-0000-C000-000000000046}"
'RefGUID(2, 1) = "stdole"
'RefGUID(2, 2) = 2
'RefGUID(2, 3) = 0
'RefGUID(2, 4) = "STDOLE2.TLB"
'RefGUID(2, 5) = "OLE Automation"

For i = 1 To x
    On Error Resume Next
    Set MyReference = References(RefGUID(i, 1))
    'Если ссылка не установлена - пытаемся восстановить из реестра
    If Err > 0 Then
        Err.Clear
        Set MyReference = References.AddFromGuid(RefGUID(i, 0), RefGUID(i, 2), RefGUID(i, 3))
            'Если ссылка не прописана в реестре
            If Err > 0 Then
                GoTo For_Err
            End If
    End If

'Если версии требуемой и установленной совпадают с уже установленной ссылкой то переходим к следующей
    If CStr(MyReference.Guid) = RefGUID(i, 0) Then
        'MsgBox RefGUID(i, 4) & " - " & RefGUID(i, 4) & " в порядке!"
        GoTo ForBye
    Else 'Если версии требуемой и установленной НЕ совпадают
        'и первые 3 символа названия не совпадают
        If Left(CStr(MyReference.Guid), 3) = Left(RefGUID(i, 0), 3) Then
            References.Remove MyReference 'Удаляем установленную
            'Пытаемся подключить требуюмую
            Set MyReference = References.AddFromGuid(RefGUID(i, 0), RefGUID(i, 2), RefGUID(i, 3))
                If Err > 0 Then
                    GoTo For_Err
                End If
        End If
    End If

'Проверяем "Не отвалилась ли???"
    If MyReference.IsBroken = True Then
        MyErr = 1
        MsgBox "Библиотечная ссылка: " & RefGUID(i, 5) & " отвалилась !!!"
    End If
    GoTo ForBye

For_Err:
    MyErr = 1
    MsgBox Err.Description & vbCrLf & _
    "Библиотечная ссылка: " & RefGUID(i, 5)

ForBye:
Next i
Set MyReference = Nothing
'если все прошло нормально
If MyErr = 0 Then RefRestore = True
End Function
===================================
Вопрос: Библиотечные ссылки: Проверка и восстановление библиотечных ссылок

Совет: 
Пишешь тут... пишешь - отсылаешь клиенту - НЕ РАБОТАЕТ :(  

Начинаешь выяснять причину - у него "Microsoft DAO 3.6 Object Library" либо и в помине нет - либо отвалилась напрочь.  

   Мучался я... мучался с этой бедой - и надумал такую вот штуку... 

(ТОЛЬКО для MSA -2000) - хотя можно и под  97-й, но тогда  переписать названия и параметры библиотек не забудьте. 

Допишите в функцию ссылки какие есть еще в Вашем проекте (полезно воспользоваться функцией Получение параметров всех установленных ссылок и сохранение их в таблице) 

- протестируйте - и пользуйтесь если понравится. 

В данном примере восстанавливаются ссылки на: 

     "Microsoft DAO 3.6 Object Library" 

     "OLE Automation" 

(У кого клиенты буржуйские - не забудете ремарки Русские убрать (то же - не вредно будет), а у кого НАШИ тексты сообщений поменяйте ) 

Грабли: 

В MDE - добавление ссылок не отработает 
 
Function JS_ReferencesRestore()
Dim MyReference As Reference
'Массив на 4 ссылки
Dim RefGUID(1, 5) As String
Dim i As Integer

'Набивка массива
'DAO 3.6

RefGUID(0, 0) = "{00025E01-0000-0000-C000-000000000046}"
RefGUID(0, 1) = "DAO"
RefGUID(0, 2) = 5
RefGUID(0, 3) = 0
RefGUID(0, 4) = "DAO360.DLL"
RefGUID(0, 5) = "Microsoft DAO 3.6 Object Library"

 

'OLE Automation

RefGUID(1, 0) = "{00020430-0000-0000-C000-000000000046}"
RefGUID(1, 1) = "stdole"
RefGUID(1, 2) = 2
RefGUID(1, 3) = 0
RefGUID(1, 4) = "STDOLE2.TLB"
RefGUID(1, 5) = "OLE Automation"

 

For i = 0 To 1
    On Error Resume Next
    Set MyReference = References(RefGUID(i, 1))
    'Если ссылка не установлена - пытаемся восстановить из реестра
    If Err > 0 Then
        Err.Clear
        Set MyReference = References.AddFromGuid(RefGUID(i, 0), RefGUID(i, 2), RefGUID(i, 3))
            'Если ссылка не прописана в реестре
            If Err > 0 Then
                GoTo For_Err
            End If
    End If


    'Если версии требуемой и установленной совпадают с уже установленной ссылкой
    If MyReference.Guid = GUIDFromString(RefGUID(i, 0)) Then
        'MsgBox RefGUID(i, 4) & " - " & RefGUID(i, 4) & " у порядке!"
        GoTo ForBye
    Else 'Если версии требуемой и установленной НЕ совпадают
        References.Remove MyReference 'Удаляем установленную
        'Пытаемся подключить требуюмую
        Set MyReference = References.AddFromGuid(RefGUID(i, 0), RefGUID(i, 2), RefGUID(i, 3))
            If Err > 0 Then
                GoTo For_Err
            End If
    End If


    'Проверяем "Не отвалилась ли???"
    If MyReference.IsBroken = True Then
        MsgBox "Reference to: " & RefGUID(i, 5) & " is broken"
    End If
    GoTo ForBye

For_Err:
    MsgBox "Can't find file: " & RefGUID(i, 4) & " for reference: " & RefGUID(i, 5)

ForBye:
Next i

Set MyReference = Nothing
End Function
====================================
Вопрос: Библиотечные ссылки: Удаление всех не обязательных библиотечных ссылок

Совет: 
Все понятно - отсекаем все .... и все... дело ТРУБА! :) 

(Тем кто не совсем хорошо понимает что делает - ПОЛЬЗОВАТЬСЯ КРАЙНЕ НЕ РЕКОМЕНДУЕТСЯ) 
 
Function JS_ReferencesDelete()
Dim MyReference As Reference
For Each MyReference In References
If MyReference.BuiltIn = False Then
References.Remove MyReference
End If
Next MyReference
Set MyReference = Nothing
End Function