AW: microsoft scripting runtime einbinden
26.10.2007 23:18:00
Ramses
Hallo
Sub Show_References()
'(C) Ramses
Dim i As Integer
With ThisWorkbook.VBProject.References
For i = 1 To .count
'Debug.Print .Item(i).Description
Sheets("Sheet1").Cells(i, 1) = .Item(i).GUID
Sheets("Sheet1").Cells(i, 2) = .Item(i).Description
Sheets("Sheet1").Cells(i, 3) = .Item(i).major
Sheets("Sheet1").Cells(i, 4) = .Item(i).minor
Next
End With
End Sub
Zum setzten kannst du auch noch das verwenden
'Häufig gebrauchte Verweise "References" setzen
'Const erweitert von Ramses
'Verweise anpassen
Dim isRef As Boolean, i As Integer, link As Object
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 strExcel11 As String = "{00020813-0000-0000-C000-000000000046}" 'Microsoft Excel 11.0 Object Library (Excel 2003)
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 strWord11 As String = "{00020905-0000-0000-C000-000000000046}" 'Microsoft Word 11.0 Object Library (Word 2003)
Const strMSOff11 As String = "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}" 'Microsoft Office 11.0 Object Library
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)
Const strOutlook11 As String = "{00062FFF-0000-0000-C000-000000000046}" 'Microsoft Outlook 11.0 Object Library (Outlook 2003)
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 strVBA As String = "{000204EF-0000-0000-C000-000000000046}" 'Visual Basic for Application
Const strMSF20 As String = "{0D452EE1-E08F-101A-852E-02608C4D0BB4}" 'Microsoft Forms 2.0 Object Library
Const strWComCon As String = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" 'Windows Common Controls 6.0 SP6
Const strAcroDist As String = "{317DA881-ECC5-11D1-B976-00600802DB86}" 'Acrobat Distiller
Sub SetReference(ref As String)
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