ActiveWorkbook.VBProject.References.Count

halit3 · 11 Mayıs 2014

ActiveWorkbook.VBProject.References.Count

Bu dosyada Sayfada ve Userformda Referansları listelemek, eklemek ve kaldırmak ile ilgili çalışmam.

Hayırlı Olsun

slayt

görsel video

halit3 · 11 Mayıs 2014

Referansları listelemek için
Sayfanın birincisi için 5 adet makroyu bir modülün içine koyun
kod:

Kod:

Option Explicit

#If VBA7 Then
#Else
#End If


#If Win64 Then
Private Declare PtrSafe Function  RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare PtrSafe Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare PtrSafe Function  RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, ByRef lpcbValue As Long) As Long
Private Declare PtrSafe Function  RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#Else
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, ByRef lpcbValue As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#End If

Sub RefList3()
Dim R1 As Long
Dim R2 As Long
Dim hHK1 As Long
Dim hHK2 As Long
Dim hHK3 As Long
Dim hHK4 As Long
Dim i As Long
Dim i2 As Long
Dim lpPath As String
Dim lpGUID As String
Dim lpName As String
Dim lpValue As String
Dim deg4, son


Range("A2:G5000").ClearContents
Range("A2:G5000").Interior.ColorIndex = xlNone

   lpPath = String$(128, vbNullChar)
   lpValue = String$(128, vbNullChar)
   lpName = String$(128, vbNullChar)
   lpGUID = String$(128, vbNullChar)
    R1 = RegOpenKeyEx(-2147483648#, "TypeLib", ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK1)
   If R1 = 0& Then
       i = 1
       Do While Not R1 = 259&
           R1 = RegEnumKey(hHK1, i, lpGUID, Len(lpGUID))
           If R1 = 0& Then
               R2 = RegOpenKeyEx(hHK1, lpGUID, ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK2)
               If R2 = 0& Then
                   i2 = 0
                   Do While Not R2 = 259&
                       R2 = RegEnumKey(hHK2, i2, lpName, Len(lpName)) '1.0
                       If R2 = 0& Then
                           RegQueryValue hHK2, lpName, lpValue, Len(lpValue)
                           RegOpenKeyEx hHK2, lpName, ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK3
                           RegOpenKeyEx hHK3, "0", ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK4
                           RegQueryValue hHK4, "win32", lpPath, Len(lpPath)
                           
    
                           i2 = i2 + 1
                            Cells(i + 1, 1) = lpValue
                           Cells(i + 1, 2) = lpGUID
                           Cells(i + 1, 3) = lpPath
 

deg4 = Split(Replace(lpName, ".", ","), ",")
If UBound(deg4) > 0 Then
Cells(i + 1, "d").Value = deg4(0)
Cells(i + 1, "e").Value = deg4(1)
End If

                       End If
                   Loop
               End If
           End If
           i = i + 1
       Loop
       RegCloseKey hHK1
       RegCloseKey hHK2
       RegCloseKey hHK3
       RegCloseKey hHK4
   End If
 
son = Sheets(ActiveSheet.Name).Range("a65500").End(3).Row
Sheets(ActiveSheet.Name).Range("A2:G" & son).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
   
  MsgBox "işlem tamam"
End Sub


Sub yükle()
On Error Resume Next
Dim a, deg1, deg2, deg3
Dim ID
a = ActiveWindow.Selection.Row

If Val(ActiveWindow.Selection.Row) <= 1 Then Exit Sub

Set ID = ThisWorkbook.VBProject.References

deg1 = Cells(a, "b").Value
deg2 = Cells(a, "d").Value
deg3 = Cells(a, "e").Value
MsgBox deg1 & Chr(10) & deg2 & Chr(10) & deg3

ID.AddFromGuid deg1, deg2, deg3
'ID.AddFromGuid "{00000205-0000-0010-8000-00AA006D2EA4}", 2, 5
End Sub

Sub silRemoveReference1()
Dim Reference As Object
Dim aranan

If Val(ActiveWindow.Selection.Row) <= 1 Then Exit Sub

aranan = Cells(ActiveWindow.Selection.Row, "a").Value
For Each Reference In ThisWorkbook.VBProject.References
If Reference.Description = aranan Then '"Microsoft Visual Basic for Applications Extensibility 5.3" Then
ThisWorkbook.VBProject.References.Remove Reference
MsgBox (aranan & " silindi")
End If
Next

MsgBox "işlem tamam"
End Sub

Sub silRemoveReference3()
Range("G2:G5000").ClearContents
Range("G2:G5000").Interior.ColorIndex = xlNone
Dim r, n, aranan
For r = 2 To Cells(Rows.Count, "a").End(3).Row
aranan = Cells(r, "b").Value

On Error Resume Next

For n = 1 To ActiveWorkbook.VBProject.References.Count
If aranan = ActiveWorkbook.VBProject.References.Item(n).GUID Then
Cells(r, "g").Value = "x"
Cells(r, "g").Interior.ColorIndex = 8

Exit For
End If
Next n

Next
MsgBox "işlem tamam"

End Sub


Sub silRemoveReference2()

Dim Reference As Object
Dim r, aranan
For r = 12 To Cells(Rows.Count, "a").End(3).Row
If Cells(r, "g").Value = "x" Then
aranan = Cells(ActiveWindow.Selection.Row, "a").Value
For Each Reference In ThisWorkbook.VBProject.References
If Reference.Description = aranan Then
ThisWorkbook.VBProject.References.Remove Reference
Cells(r, "g").Value = ""
Cells(r, "g").Interior.ColorIndex = xlNone
Exit For
End If
Next

End If
Next

MsgBox "işlem tamam"
End Sub

Kullanılan Referanslar için
sayfanın ikincisi için 4 adet makroyu bir mödülün içine koyun
kod:

Kod:

Option Explicit

Sub Grab_References()

Range("A2:G5000").ClearContents
Range("A2:G5000").Interior.ColorIndex = xlNone

Dim n As Integer

'Sheets.Add
'ActiveSheet.Name = "GUIDS"

On Error Resume Next
For n = 1 To ActiveWorkbook.VBProject.References.Count
Cells(n + 1, 1) = ActiveWorkbook.VBProject.References.Item(n).Description
Cells(n + 1, 2) = ActiveWorkbook.VBProject.References.Item(n).GUID
Cells(n + 1, 3) = ActiveWorkbook.VBProject.References.Item(n).FullPath


Cells(n + 1, 4) = ActiveWorkbook.VBProject.References.Item(n).Major
Cells(n + 1, 5) = ActiveWorkbook.VBProject.References.Item(n).Minor
Cells(n + 1, 6) = ActiveWorkbook.VBProject.References.Item(n).Name
Next n

End Sub
Sub referanssil1()

On Error Resume Next
Dim deg1, nesne, a
If Val(ActiveWindow.Selection.Row) <= 1 Then Exit Sub

deg1 = Cells(ActiveWindow.Selection.Row, 6).Value
Set nesne = ThisWorkbook.VBProject.References.Item(deg1)
a = MsgBox(nesne.Name & " Silmek istiyormusunuz.?", vbYesNo + vbInformation, " UYASRI")
If a = vbYes Then
ThisWorkbook.VBProject.References.Remove nesne
'End If
End If
Grab_References

End Sub
Sub References_RemoveMissing()
'Macro purpose:  To remove missing references from the VBE

Dim nesne As Variant, i As Long
Dim a
On Error Resume Next

For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set nesne = ThisWorkbook.VBProject.References.Item(i)

'If nesne.IsBroken = True Then
a = MsgBox(nesne.Name & " Silmek istiyormusunuz.?", vbYesNo + vbInformation, " UYASRI")
If a = vbYes Then
ThisWorkbook.VBProject.References.Remove nesne
'End If
End If
Next i


Grab_References
On Error GoTo 0
End Sub

Sub referanssil2()

On Error Resume Next
Dim r, deg1, nesne
For r = 2 To Cells(Rows.Count, "a").End(3).Row
If Cells(r, "g").Value = "x" Then
deg1 = Cells(r, 6).Value
Set nesne = ThisWorkbook.VBProject.References.Item(deg1)

ThisWorkbook.VBProject.References.Remove nesne
Cells(r, "g").Value = ""

End If
Next

Grab_References

End Sub


Sub anasayfa()
UserForm1.Show 0
End Sub

userform için
1 adet ListView nesnesi
7 adet TextBox nesnesi
4 adet CommandButton nesnesi
1 adet CheckBox nesnesi
kod:

Kod:

Option Explicit

#If VBA7 Then
#Else
#End If

#If Win64 Then
Private Declare PtrSafe Function  RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare PtrSafe Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare PtrSafe Function  RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, ByRef lpcbValue As Long) As Long
Private Declare PtrSafe Function  RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#Else
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, ByRef lpcbValue As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#End If

Private Sub CheckBox1_Click()

If CheckBox1.Value = False Then
CommandButton1_Click
Else
CommandButton5_Click
End If

End Sub



Private Sub CommandButton1_Click()


With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
.LabelEdit = lvwManual
.AllowColumnReorder = True

.Font.Bold = True
.ColumnHeaders.Add , , "Referans adı", 250
.ColumnHeaders.Add , , "Referans kodu", 96
.ColumnHeaders.Add , , "Adres", 96
.ColumnHeaders.Add , , "Sürüm no 1.deger", 80
.ColumnHeaders.Add , , "Sürüm no 2.deger", 80

End With



Dim R1 As Long
Dim R2 As Long
Dim hHK1 As Long
Dim hHK2 As Long
Dim hHK3 As Long
Dim hHK4 As Long
Dim i As Long
Dim i2 As Long
Dim lpPath As String
Dim lpGUID As String
Dim lpName As String
Dim lpValue As String
Dim deg4, X

Dim aranan1, bulunan1
aranan1 = UCase(TextBox7.Text)
aranan1 = UCase(Replace(Replace(aranan1, "I", "İ"), "i", "I"))

    lpPath = String$(128, vbNullChar)
   lpValue = String$(128, vbNullChar)
   lpName = String$(128, vbNullChar)
   lpGUID = String$(128, vbNullChar)
    R1 = RegOpenKeyEx(-2147483648#, "TypeLib", ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK1)
   If R1 = 0& Then
       i = 1
       Do While Not R1 = 259&
           R1 = RegEnumKey(hHK1, i, lpGUID, Len(lpGUID))
           If R1 = 0& Then
               R2 = RegOpenKeyEx(hHK1, lpGUID, ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK2)
               If R2 = 0& Then
                   i2 = 0
                   Do While Not R2 = 259&
                       R2 = RegEnumKey(hHK2, i2, lpName, Len(lpName)) '1.0
                       If R2 = 0& Then
                           RegQueryValue hHK2, lpName, lpValue, Len(lpValue)
                           RegOpenKeyEx hHK2, lpName, ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK3
                           RegOpenKeyEx hHK3, "0", ByVal 0&, ((131072 Or 1 Or 8 Or 16) And (Not 1048576)), hHK4
                           RegQueryValue hHK4, "win32", lpPath, Len(lpPath)
                           
                           i2 = i2 + 1
                    
                           
bulunan1 = UCase(Mid(lpValue, 1, Len(TextBox7.Text)))
bulunan1 = UCase(Replace(Replace(bulunan1, "I", "İ"), "i", "I"))

If aranan1 = bulunan1 Or aranan1 = "" Then
                                            
X = X + 1
ListView1.ListItems.Add , , lpValue
ListView1.ListItems(X).ListSubItems.Add , , lpGUID
ListView1.ListItems(X).ListSubItems.Add , , lpPath



deg4 = Split(Replace(lpName, ".", ","), ",")
If UBound(deg4) > 0 Then
ListView1.ListItems(X).ListSubItems.Add , , deg4(0)
ListView1.ListItems(X).ListSubItems.Add , , deg4(1)
End If


                           
End If


                           
                           
                       End If
                   Loop
               End If
           End If
           i = i + 1
       Loop
       RegCloseKey hHK1
       RegCloseKey hHK2
       RegCloseKey hHK3
       RegCloseKey hHK4
   End If
   
Application.Wait (Now + TimeValue("0:00:1"))
ListView1.Sorted = True
ListView1.SortKey = 0
ListView1.SortOrder = lvwAscending
ListView1.Sorted = False


End Sub

 


Private Sub CommandButton2_Click()

If CheckBox1.Value = False Then
On Error Resume Next
Dim ID

Set ID = ThisWorkbook.VBProject.References
MsgBox TextBox2.Text & Chr(10) & TextBox4.Text & Chr(10) & TextBox5.Text
MsgBox ID.Description
ID.AddFromGuid TextBox2.Text, TextBox4.Text, TextBox5.Text
'ID.AddFromGuid "{00000205-0000-0010-8000-00AA006D2EA4}", 2, 5
temizle_Click
Unload Me
UserForm1.Hide
anasayfa

Else
MsgBox "seçenek düğmesinin tikini kaldırın"
End If

End Sub

Private Sub temizle_Click()
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
End Sub




Private Sub ListView1deger()
On Error Resume Next

temizle_Click
Dim X, hucre
If ListView1.ListItems.Count = 0 Then Exit Sub
X = ListView1.SelectedItem.Index

TextBox1.Text = ListView1.ListItems(X).Text
TextBox2.Text = ListView1.ListItems(X).ListSubItems(1).Text
TextBox3.Text = ListView1.ListItems(X).ListSubItems(2).Text
TextBox4.Text = ListView1.ListItems(X).ListSubItems(3).Text
TextBox5.Text = ListView1.ListItems(X).ListSubItems(4).Text
TextBox6.Text = ListView1.ListItems(X).ListSubItems(5).Text

End Sub

Private Sub CommandButton3_Click()
If CheckBox1.Value = True Then

Dim Reference As Object
For Each Reference In ThisWorkbook.VBProject.References

If Reference.Description = TextBox1.Text Then
ThisWorkbook.VBProject.References.Remove Reference
MsgBox (TextBox5.Text & " silindi")
End If
Next

temizle_Click
Unload Me
UserForm1.Hide
'Application.Wait (Now + TimeValue("0:00:2"))
anasayfa
Else
MsgBox "seçenek düğmesinin tikini işaretleyin"
End If

End Sub

Private Sub CommandButton4_Click()


If CheckBox1.Value = True Then
 On Error Resume Next
Dim a, nesne
Set nesne = ThisWorkbook.VBProject.References.Item(TextBox6.Text)

a = MsgBox(nesne.Name & " Silmek istiyormusunuz.?", vbYesNo + vbInformation, " UYASRI")
If a = vbYes Then
ThisWorkbook.VBProject.References.Remove nesne
End If
CommandButton5_Click
temizle_Click
Me.Show 0

Else
MsgBox "seçenek düğmesinin tikini işaretleyin"
End If
 
 
End Sub

Private Sub CommandButton5_Click()
temizle_Click

 With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
.LabelEdit = lvwManual
.AllowColumnReorder = True
.Font.Bold = True
.ColumnHeaders.Add , , "Referans adı", 250
.ColumnHeaders.Add , , "Referans kodu", 96
.ColumnHeaders.Add , , "Adres", 96
.ColumnHeaders.Add , , "Sürüm no 1.deger", 80
.ColumnHeaders.Add , , "Sürüm no 2.deger", 80
.ColumnHeaders.Add , , "referans", 80
End With
   
Dim n As Integer
Dim aranan1, bulunan1
On Error Resume Next


aranan1 = UCase(TextBox7.Text)
aranan1 = UCase(Replace(Replace(aranan1, "I", "İ"), "i", "I"))

For n = 1 To ActiveWorkbook.VBProject.References.Count

bulunan1 = UCase(Mid(ActiveWorkbook.VBProject.References.Item(n).Description, 1, Len(TextBox7.Text)))

bulunan1 = UCase(Replace(Replace(bulunan1, "I", "İ"), "i", "I"))

If aranan1 = bulunan1 Or aranan1 = "" Then
ListView1.ListItems.Add , , ActiveWorkbook.VBProject.References.Item(n).Description
ListView1.ListItems(n).ListSubItems.Add , , ActiveWorkbook.VBProject.References.Item(n).GUID
ListView1.ListItems(n).ListSubItems.Add , , ActiveWorkbook.VBProject.References.Item(n).FullPath
ListView1.ListItems(n).ListSubItems.Add , , ActiveWorkbook.VBProject.References.Item(n).Minor
ListView1.ListItems(n).ListSubItems.Add , , ActiveWorkbook.VBProject.References.Item(n).Major
ListView1.ListItems(n).ListSubItems.Add , , ActiveWorkbook.VBProject.References.Item(n).Name
End If

Next n

Application.Wait (Now + TimeValue("0:00:1"))
ListView1.Sorted = True
ListView1.SortKey = 0
ListView1.SortOrder = lvwAscending
ListView1.Sorted = False
End Sub



Private Sub ListView1_Click()
ListView1deger
End Sub

Private Sub ListView1_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
ListView1deger
End Sub

Private Sub ListView1_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
ListView1deger
End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
  
ListView1.Sorted = True
ListView1.SortKey = ColumnHeader.Index - 1
If ListView1.SortOrder = lvwAscending Then
ListView1.SortOrder = lvwDescending
Else
ListView1.SortOrder = lvwAscending
End If
ListView1.Sorted = False

End Sub


Private Sub TextBox6_Change()

End Sub

Private Sub TextBox7_Change()
If CheckBox1.Value = False Then
CommandButton1_Click
Else
CommandButton5_Click
End If

End Sub

Private Sub UserForm_Initialize()
CheckBox1_Click
End Sub

Murat OSMA · 11 Mayıs 2014

Referanslar yeni kullanıcılar için zaman zaman sıkıntı oluşturabiliyor.
Bu dosya o kullanıcılar için kolaylık sağlayacaktır.

Ellerinize sağlık Halit Bey.

irfancantr · 11 Mayıs 2014

halit3' Alıntı:
ActiveWorkbook.VBProject.References.Count

Bu dosyada Sayfada ve Userformda Referansları listelemek, eklemek ve kaldırmak ile ilgili çalışmam.

Hayırlı Olsun

Güzel bir çalışma, teşekkürler sayın halit3

halit3 · 11 Mayıs 2014

Murat OSMA' Alıntı:
Referanslar yeni kullanıcılar için zaman zaman sıkıntı oluşturabiliyor.
Bu dosya o kullanıcılar için kolaylık sağlayacaktır.

Ellerinize sağlık Halit Bey.

Teşekkürler Murat Bey iyi çalışmalar

halit3 · 11 Mayıs 2014

irfancantr' Alıntı:
Güzel bir çalışma, teşekkürler sayın halit3

Teşekkürler İyi çalışmalar

omeryılmaz · 11 Mayıs 2014

Ellerinize sağlık Halit Bey.

halit3 · 11 Mayıs 2014

omeryılmaz' Alıntı:
Ellerinize sağlık Halit Bey.

Teşekkürler iyi çalışmalar

halit3 · 11 Mayıs 2014

1 nolu mesajdaki dosya güncellendi.

ZorBey_ · 11 Mayıs 2014

Elinize Sağlık
Sayın halit3

halit3 · 11 Mayıs 2014

ZorBey_' Alıntı:
Elinize Sağlık
Sayın halit3

Teşekkürler iyi çalışmalar

halit3 · 11 Mayıs 2014

1 nolu mesaja görsel video 2 nolu mesaja da kullanılan kodlar eklendi.

ActiveWorkbook.VBProject.References.Count

halit3

Uzman

Ekli dosyalar

halit3

Uzman

Murat OSMA

Altın Üye

irfancantr

halit3

Uzman

halit3

Uzman

omeryılmaz

halit3

Uzman

halit3

Uzman

ZorBey_

Destek Ekibi

halit3

Uzman

halit3

Uzman