• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Çalışma Kitabındaki Tüm Kodların Başlıklarını Listelemek

E

Ergün Güler

Katılım
5 Ocak 2009
Mesajlar
1,586
Excel Vers. ve Dili
2003 Türkçe
Selam,

Bir çalışma kitabındaki tüm kodları (Sayfalardaki, Workbook'taki, Form'lardaki, Module'dekileri, Class Module'deki) listelemek istiyorum. Nasıl yapabilirim?

Örnek dosyam ektedir. Sayfa1'de ise nasıl listelemek istediğim tablo şeklinde gösterdim.
Yardımcı olabilirseniz çok sevinirm.

İyi çalışmalar.
 

Ekli dosyalar

Ergün Güler' Alıntı:
Selam,

Bir çalışma kitabındaki tüm kodları (Sayfalardaki, Workbook'taki, Form'lardaki, Module'dekileri, Class Module'deki) listelemek istiyorum. Nasıl yapabilirim?

Örnek dosyam ektedir. Sayfa1'de ise nasıl listelemek istediğim tablo şeklinde gösterdim.
Yardımcı olabilirseniz çok sevinirm.

İyi çalışmalar.
Genişletmek için tıkla ...

Burada sadece Public Function kodlarında sınırlama var buradaki sınırlama 40 karekter eğer kırk karekterden fazla ise bu kodu listelemiyecek.


Kod: 
Sub makroları_yazdır()
Range("A3:C65000").ClearContents
sat = 3
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
For n = 1 To VBCodeMod.CountOfLines
deger6 = Trim(ThisWorkbook.VBProject.VBComponents(VBCodeMod).CodeModule.Lines(n, 1))
If Mid(deger6, 1, 11) = "Private Sub" Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 8) = "Function" Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 4) = "Sub " Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 16) = "Public Function " Then
If Len(deger6) < 40 Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
End If
End If
If Worksheets(ActiveSheet.Name).Cells(sat, 3).Value <> "" Then
If ModX.Type = 1 Then
Cells(sat, "A") = "Module"
ElseIf ModX.Type = 2 Then
Cells(sat, "A") = "Class Module"
ElseIf ModX.Type = 3 Then
Cells(sat, "A") = "UserForm"
ElseIf ModX.Type = 100 Then
If ModX.Name = "ThisWorkbook" Then
Cells(sat, "A") = "Çalışma kitabı"
Else
Cells(sat, "A") = "Sayfa"
End If
End If
Cells(sat, "b") = VBCodeMod
End If
 
If Worksheets(ActiveSheet.Name).Cells(sat, 3).Value <> "" Then
sat = sat + 1
End If
Next n
i = i + 1
Next
MsgBox i & " adet makro kodu bulundu işlem tamam"
End Sub


veya


Kod: 
Sub ListProcedures()
Dim LineNum As Long
Dim NumLines As Long
Dim WS As Worksheet
Dim Rng As Range
Dim ProcName As String
Dim ProcKind As VBIDE.vbext_ProcKind
Set WS = ActiveWorkbook.Worksheets("Sayfa2")
Set Rng = WS.Range("A2")
On Error Resume Next
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
LineNum = VBCodeMod.CountOfDeclarationLines + 1
Do Until LineNum >= VBCodeMod.CountOfLines
ProcName = VBCodeMod.ProcOfLine(LineNum, ProcKind)
'Rng.Value = ProcName
Rng(1, 3).Value = ProcName
'Rng(1, 2).Value = ProcKindString(ProcKind)
LineNum = VBCodeMod.ProcStartLine(ProcName, ProcKind) + _
VBCodeMod.ProcCountLines(ProcName, ProcKind) + 1
Rng(1, 2).Value = ModX.Name
If ModX.Type = 1 Then
Rng(1, 1).Value = "Module"
ElseIf ModX.Type = 2 Then
Rng(1, 1).Value = "Class Module"
ElseIf ModX.Type = 3 Then
Rng(1, 1).Value = "UserForm"
ElseIf ModX.Type = 100 Then
If ModX.Name = "ThisWorkbook" Then
Rng(1, 1).Value = "Çalışma kitabı"
Else
Rng(1, 1).Value = "Sayfa"
End If
End If
'Rng(1, 5).Value = VBCodeMod
Set Rng = Rng(2, 1)
Loop
Next

End Sub

Function ProcKindString(ProcKind As VBIDE.vbext_ProcKind) As String
Select Case ProcKind
Case vbext_pk_Get
ProcKindString = "Property Get"
Case vbext_pk_Let
ProcKindString = "Property Let"
Case vbext_pk_Set
ProcKindString = "Property Set"
Case vbext_pk_Proc
ProcKindString = "Sub Or Function"
Case Else
ProcKindString = "Unknown Type: " & CStr(ProcKind)
End Select
End Function
 
halit3' Alıntı:
Burada sadece Public Function kodlarında sınırlama var buradaki sınırlama 40 karekter eğer kırk karekterden fazla ise bu kodu listelemiyecek.


Kod: 
Sub makroları_yazdır()
Range("A3:C65000").ClearContents
sat = 3
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
For n = 1 To VBCodeMod.CountOfLines
deger6 = Trim(ThisWorkbook.VBProject.VBComponents(VBCodeMod).CodeModule.Lines(n, 1))
If Mid(deger6, 1, 11) = "Private Sub" Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 8) = "Function" Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 4) = "Sub " Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 16) = "Public Function " Then
If Len(deger6) < 40 Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
End If
End If
If Worksheets(ActiveSheet.Name).Cells(sat, 3).Value <> "" Then
If ModX.Type = 1 Then
Cells(sat, "A") = "Module"
ElseIf ModX.Type = 2 Then
Cells(sat, "A") = "Class Module"
ElseIf ModX.Type = 3 Then
Cells(sat, "A") = "UserForm"
ElseIf ModX.Type = 100 Then
If ModX.Name = "ThisWorkbook" Then
Cells(sat, "A") = "Çalışma kitabı"
Else
Cells(sat, "A") = "Sayfa"
End If
End If
Cells(sat, "b") = VBCodeMod
End If

If Worksheets(ActiveSheet.Name).Cells(sat, 3).Value <> "" Then
sat = sat + 1
End If
Next n
i = i + 1
Next
MsgBox i & " adet makro kodu bulundu işlem tamam"
End Sub
Genişletmek için tıkla ...

Selam Hocam,
Çok teşekkür ederim. Ellerinize sağlık.
İyi çalışmalar.
 
Kod: 
Sub makroları_yazdır()
Range("A3:C65000").ClearContents
sat = 3
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
For n = 1 To VBCodeMod.CountOfLines
deger6 = Trim(ThisWorkbook.VBProject.VBComponents(VBCodeMod).CodeModule.Lines(n, 1))
If Mid(deger6, 1, 11) = "Private Sub" Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 8) = "Function" Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 4) = "Sub " Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
ElseIf Mid(deger6, 1, 16) = "Public Function " Then
If Len(deger6) < 40 Then
Worksheets(ActiveSheet.Name).Cells(sat, 3).Value = deger6
End If
End If
If Worksheets(ActiveSheet.Name).Cells(sat, 3).Value <> "" Then
If ModX.Type = 1 Then
Cells(sat, "A") = "Module"
ElseIf ModX.Type = 2 Then
Cells(sat, "A") = "Class Module"
ElseIf ModX.Type = 3 Then
Cells(sat, "A") = "UserForm"
ElseIf ModX.Type = 100 Then
If ModX.Name = "ThisWorkbook" Then
Cells(sat, "A") = "Çalışma kitabı"
Else
Cells(sat, "A") = "Sayfa"
End If
End If
Cells(sat, "b") = VBCodeMod
End If
 
If Worksheets(ActiveSheet.Name).Cells(sat, 3).Value <> "" Then
sat = sat + 1
End If
Next n
i = i + 1
Next
MsgBox i & " adet makro kodu bulundu işlem tamam"
End Sub
Selam,
Hocam ayrıca bir sorum olacak. yukarıdaki kodlar ile çalışma kitabındaki tüm kodları listeliyorum. İsteğim şu; listelenen kod listesinden istediğim satırdaki kodları nasıl yazdırabilirim?
Örneğin; yukarıdaki kodları çalıştırıyorum. 67 adet makro kodu buluyor. Bulduklarından bir tanesini örneğin "Public Function txt_sırala3" seçeceğim.

yazıcıdan aşağıdaki kodların çıktısını alacağım. Mümkün müdür?
Kod: 
Public Function txt_sırala3(liste)
Dim i As Long, j As Long, X
For i = LBound(liste) + 1 To UBound(liste)
For j = i To UBound(liste)
If StrComp(liste(i, 0), liste(j, 0), vbTextCompare) > 0 Then
X = liste(i, 0)
liste(i, 0) = liste(j, 0)
liste(j, 0) = X
End If
Next j
Next i
txt_sırala3 = liste
End Function
 
Sayfa1 de önce düğmeye tıkla sayfaya gelen makro isimleri ile ilgili makro adları C sutünuna gelecek bu sutündaki makra isimlerine çift tıkla F1 ve G1 hücresine makronun adını otamatik getiriyor ve daha sonra düğmeye tekrar tıkla
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst