nochmals Dateien mit Makros für Boris
15.10.2004 19:33:20
Rolf
aus reinem Eigennutz habe ich deine gestrige Aufgabenstellung
mal auf meine Bedürfnisse angepasst.
Ich denke, es kommt deinen Anforderungen entgegen.
Bitte den kompletten Code in ein Modulblatt kopieren
und mit "start_makro_identifikation" ausführen.
m.d.B. um feedback
Rolf
'Dateien mit Makros identifizieren
'by Rolf Beißner
'10.2004
Option Explicit
Option Base 1
Dim awb As Workbook 'Startmappe
Dim nws As Worksheet 'neues Sheet
Dim fl As Object 'geöffnete Datei
Dim verz As String 'abzuarbeitendes Verzeichnis
Dim k As Long 'Satzzähler
Dim p As Long 'Summenposition
'Startmakro
Sub start_makro_identifikation()
Call parameter
Call ShowFileList(verz)
Call gliedern
End Sub
'Parameter definieren
Sub parameter()
Dim i As Integer
Dim A As Variant
verz = Ordner_def 'dank K.Rola
ChDrive verz
ChDir verz
Application.ScreenUpdating = False
Set awb = ActiveWorkbook
Set nws = Worksheets.Add
k = 1
A = Array("Gliederungsebene", "Verzeichnis", "Datei", "Komponente", "Kompon.-Typ", "Anz.Codezeilen")
For i = 1 To 6
nws.Cells(k, i) = A(i)
Next
End Sub
'Excel-Dateien öffnen
Sub ShowFileList(folderspec) 'Argumentübergabe z.B "C:\excel\Arbeitsdateien"
Dim fs, f, fc As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each fl In fc
If fl.Type = "Microsoft Excel-Arbeitsblatt" Then
k = k + 1
p = k
nws.Cells(k, 1) = 1
nws.Cells(k, 2) = folderspec
nws.Cells(k, 3) = fl.Name
Workbooks.Open (fl.Name)
projkomponenten
Application.DisplayAlerts = False
Workbooks(fl.Name).Close
End If
Next
End Sub
'Projektkomponenten auflisten
Sub projkomponenten()
Dim vb, vbc As Object
Dim cl As Integer
cl = 0
Set vb = ActiveWorkbook.VBProject.VBComponents
For Each vbc In vb
k = k + 1
nws.Cells(k, 1) = 2
nws.Cells(k, 4) = vbc.Name
nws.Cells(k, 5) = vbc.Type
nws.Cells(k, 6) = vbc.codemodule.countoflines
cl = cl + vbc.codemodule.countoflines
nws.Cells(p, 6) = cl
Next
End Sub
'Gliederung aus den Angaben in Spalte 1 generieren
Sub gliedern()
Dim e, h As Integer
Dim zellen As Range
[a1].ClearOutline
h = Application.Max(Columns(1)) 'höchste Ebene
For Each zellen In ActiveSheet.UsedRange.Offset(1, 0).Resize(, 1)
zellen.Select
If zellen.Value = "" Then
e = 0
Else
e = zellen.Value
End If
If e = 0 Then e = h + 1 'definiert Stufe h+1
With Rows(zellen.Row)
.OutlineLevel = e
End With
Next
With ActiveSheet.Outline
.SummaryRow = xlAbove
.ShowLevels rowLevels:=1
End With
Cells.EntireColumn.AutoFit
End Sub
'aus Herber-Forum von K.Rola am 11.10.04
Function Ordner_def()
Dim objFolderItem As Object, strPath As String, objShell As Object
Dim varDefaultPath As Variant 'wichtig muss Variant sein!
Dim objFolder As Object
varDefaultPath = "C:\"
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, varDefaultPath)
If objFolder Is Nothing Then End
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Ordner_def = strPath
End Function