Verweise generieren
Ramses
Hallo ihr beiden
hier mal ein Codebeispiel wie man das realisieren könnte
'Setzen aller benötigten Verweise
Sub SetReference(Ref As String)
' Häufig gebrauchte Verweise "References" setzen (2001) hw
' Const erweitert von Ramses
Dim isRef As Boolean, i As Integer, link As Object
Const strDAO As String = "{00025E01-0000-0000-C000-000000000046}" 'Microsoft DAO 3.6 Objects Library (DAO)
Const strADOX As String = "{00000600-0000-0010-8000-00AA006D2EA4}" 'ADO Ext. 2.1 for DDL And Security (ADOX)
Const strADO As String = "{00000201-0000-0010-8000-00AA006D2EA4}" 'Microsoft ActiveX Data Objects Library 2.1 (ADO)
Const strScript As String = "{420B2830-E718-11CF-893D-00A0C9054228}" 'Microsoft Scripting Runtime (WSH, FileSystemObject)
Const strExcel9 As String = "{00020813-0000-0000-C000-000000000046}" 'Microsoft Excel 9.0 Objects Library (Excel2000)
Const strExcel10 As String = "{00024500-0000-0000-C000-000000000046}" 'Microsoft Excel 10.0 Objects Library (Excel XP)
Const strWord8 As String = "{00020900-0000-0000-C000-000000000046}" 'Microsoft Word 8.0 Objects Library (Word 97)
Const strWord9 As String = "{00020905-0000-0000-C000-000000000046}" 'Microsoft Word 9.0 Objects Library (Word 2000)
Const strWord10 As String = "{000209FF-0000-0000-C000-000000000046}" 'Microsoft Word 10.0 Objects Library (Word XP)
Const strOutlook9 As String = "{00062FFF-0000-0000-C000-000000000046}" 'Microsoft Outlook 9.0 Objects Library (Outlook 2000)
Const strOutlook10 As String = "{00020D75-0000-0000-C000-000000000046}" 'Microsoft Outlook 10.0 Objects Library (Outlook XP)
With Application.VBE.ActiveVBProject.References
' Aktuelle gesetzte Verweise durchgehen
On Error GoTo KillRef
i = 0: Do: i = i + 1: isRef = .Item(i).Name = Ref: Loop Until i% >= .count Or isRef
If isRef Then
If .Item(Ref).IsBroken Then ' Verweis ungültig
.Remove .Item(Ref)
Else ' Verweis ist bereits gesetzt
GoTo Sub_Exit
End If
End If
On Error GoTo Err_Check:
' Verweise entsprechend der Registry GUID setzen
If Ref = "DAO" Then Set link = .AddFromGuid(strDAO, 5, 0)
If Ref = "ADOX" Then Set link = .AddFromGuid(strADOX, 2, 1)
If Ref = "ADO" Then Set link = .AddFromGuid(strADO, 2, 1)
If Ref = "Script" Then Set link = .AddFromGuid(strScript, 1, 0)
If Ref = "Excel" Then Set link = .AddFromGuid(strExcel, 1, 1)
If Ref = "Word" Then Set link = .AddFromGuid(strWord, 8, 1)
If Ref = "Outlook" Then Set link = .AddFromGuid(strOutlook, 9, 0)
Sub_Exit:
Set link = Nothing
End With
Exit Sub
Err_Check:
' Namenskonflikt mit Verweistabelle or Index außerhalb Bereich
If Err.Number = 32813 Or Err.Number = 9 Then
Resume Next
Else
MsgBox "Error Number : " & Err.Number & vbCrLf & Err.Description
GoTo Sub_Exit:
End If
KillRef:
With Application.VBE.ActiveVBProject.References
If .Item(i).IsBroken Then .Remove .Item(i)
End With
Resume Next
End Sub
Gruss Rainer