Code - Macro - Save!

The following code is a help, if you liked to save all macros of your unprotected files (optional with subfolders) in a text file. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in a "Module"


Der folgende Code hilft Ihnen, wenn Sie alle Makros ihrer ungeschützten Dateien (Optional mit Unterordnern) in einer Textdatei sichern möchten. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgede Code gehört in ein "Modul."


Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Public lngCount As Long
' IMPORTANT
' Tools - References... Microsoft Scripting Runtime
' Extras - Verweise... Microsoft Scripting Runtime
Public Sub Code_Save()
Dim strDirOld As String
Dim strPath As String
Dim blnTMP As Boolean
On Error GoTo Code_Save_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
lngCount = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Folder"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Else
MsgBox "No Folder!"
Call SetCurrentDirectory(strDirOld$)
Exit Sub
End If
End With
Select Case MsgBox("Subfolders?", vbYesNo Or _
vbQuestion Or vbDefaultButton1, "Subfolders")
Case vbYes
blnTMP = True
Case vbNo
blnTMP = False
End Select
Application.ScreenUpdating = False
FileList strPath, blnTMP
MsgBox "Finished! " & lngCount & " files were read in!"
Call SetCurrentDirectory(strDirOld$)
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
Code_Save_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
Application.ScreenUpdating = True
End Sub
Public Sub FileList(ByVal strStartFolder As String, _
ByVal blnFolder As Boolean)
Dim objFSO As Scripting.FileSystemObject
Dim scrStartFolder As Scripting.Folder
Dim scrSubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim blnStatus As Boolean
Dim wkbBook As Workbook
Dim intFile As Integer
Dim objCodes As Object
Dim varItem As Variant
Dim lngRow As Long
On Error GoTo FileList_Error
Set objFSO = New Scripting.FileSystemObject
Set scrStartFolder = objFSO.GetFolder(strStartFolder)
blnStatus = Application.DisplayStatusBar
Application.DisplayStatusBar = True
For Each FileItem In scrStartFolder.Files
If FileItem.Name Like "*.xls" And _
Dir(FileItem.Name) <> ThisWorkbook.Name Then
Application.StatusBar = "Work on file: " & FileItem.Name & " ..."
lngCount = lngCount + 1
Set wkbBook = GetObject(strStartFolder & "\" & FileItem.Name)
intFile = FreeFile
Open ThisWorkbook.Path & "\" & Left(FileItem.Name, _
Len(FileItem.Name) - 4) & ".txt" For Output As #intFile
Print #intFile, "File name: " & FileItem.Name
Print #intFile, "Folder: " & strStartFolder
Print #intFile, "Created: " & Now
Print #intFile, String(32, "#")
Print #intFile, ""
Print #intFile, "File created: " & FileItem.DateCreated
Print #intFile, "Last access: " & FileItem.DateLastAccessed
Print #intFile, "Last change: " & FileItem.DateLastModified
Print #intFile, String(32, "#")
Print #intFile, ""
For Each objCodes In wkbBook.VBProject.VBComponents
Print #intFile, ""
With objCodes.CodeModule
Print #intFile, "'" & "Name: " & objCodes.Name
For lngRow = 1 To .CountOfLines
If Trim(.Lines(lngRow, 1)) <> "" Then
Print #intFile, .Lines(lngRow, 1)
End If
Next lngRow
End With
Next objCodes
Print #intFile, ""
Print #intFile, String(25, "#")
Print #intFile, ""
Print #intFile, "Verweise im Editor:"
Print #intFile, ""
Set objCodes = wkbBook.VBProject.References
For Each varItem In objCodes
Print #intFile, varItem.Description
Next varItem
wkbBook.Close False
Close intFile
End If
Next FileItem
If blnFolder Then
For Each scrSubFolder In scrStartFolder.SubFolders
FileList scrSubFolder.Path, True
Next scrSubFolder
End If
Set scrStartFolder = Nothing
Set objFSO = Nothing
Application.StatusBar = False
Application.DisplayStatusBar = blnStatus
On Error GoTo 0
Exit Sub
FileList_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Application.StatusBar = False
Application.DisplayStatusBar = blnStatus
Set scrStartFolder = Nothing
Set objFSO = Nothing
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...