absolute Pfade in Makros ändern automatisch ??

Hallo und herzliche Grüße
Das ist hier mein erstes Posting :-)
Nun zum Problem:
Ich habe hier einen Ordner auf LW C:\. Nennen wir ihn "TEST".
In diesem Ordner befinden sich zwei Arbeitsmappen (Mappe1.xls und Mappe2.xls).
In Mappe1.xls befindet sich ein CommandButton, welchem ein Makro zugewiesen ist, welches Mappe2.xls öffnen soll.
Soweit so gut, das funktioniert auch hervorragend, solange der Ordner "TEST" eben auf diesem Laufwerk C:\ bleibt.
Kopiere ich jetzt den Ordner "Test" auf Laufwerk D:\ und benenne den Ordner "Test" auf LW C:\ in "TEST1" um, funktioniert das Makro nicht mehr.
Ist ja auch klar, denn im VB-Script steht ja auch der absolute Pfad zur Mappe2.xls drin, der ja da nun nicht mehr ist (CHDIR=c:\TEST\Mappe2.xls oder so).
Meine Frage:
Das hier ist nur ein kurzes Beispiel, um die Sache etwas anschaulicher zu gestalten.
Habe hier einen Ordner mit ca. 700 Tabellen mit je 3-7 Makros.
Wie kann ich, am besten "in einem Abwasch" alle Makros so konvertieren, das sie nicht mehr absolute sondern relative Pfade verwenden.
Alle Arbeitsmappen liegen in einem Ordner.
Da das Programm auf verschiedenen Laufwerken installiert werden muß, wären absolute Pfade nicht so toll.
Vielen Dank im Vorraus für Eure Hilfe
Kay-Uwe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Kay-Uwe
damit geht's, aber nur, wenn die VBA - Projekte nicht mit einem Kennwort geschützt sind.

Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Enum Fileattribute
    INVALID_HANDLE_VALUE = -1
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum
Private Const MAX_PATH = 260
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
Private Const strText_old As String = "N:\PROJ\NOTIZ\Scha9\" 'nach dem Text  wird gesucht
Private Const strText_new As String = "S:\Operations_Technology\PROJ\NOTIZ\Scha9\" 'und durch diesen Text ersetzt
Private lngDirCount As Long
Private lngFileCount As Long
Private strFiles() As String
Public Sub start()
    Dim intIndex As Integer, strDateiname As String
    Dim myFSO As Object, myDrives As Object, myDrive As Object
    lngDirCount = 1
    lngFileCount = 0

'   ******************* Diesen Teil verwenden, wenn alle Mappen auf allen Laufwerke bearbeitet werden
'    Set myFSO = CreateObject("Scripting.FileSystemObject")
'    Set myDrives = myFSO.Drives
'    For Each myDrive In myDrives
'        If myDrive.IsReady Then Call FindFiles(myDrive.DriveLetter & ":\", "*.xls")
'    Next

'   **************************************************************************************************
'   ******************* Diesen Teil verwenden, wenn alle Mappen in einem Ordner bearbeitet werden
    Call FindFiles("D:\Eigene Dateien\Eigene Tabellen\", "*.xls")

'   **************************************************************************************************
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For intIndex = 1 To lngFileCount
        If strFiles(intIndex) <> ThisWorkbook.FullName Then
            strDateiname = Right(strFiles(intIndex), InStr(1, StrReverse(strFiles(intIndex)), "\") - 1)
            Workbooks.Open strFiles(intIndex)
            Call Teistring_tauschen(strDateiname)
            Workbooks(strDateiname).Close SaveChanges:=True
        End If
    Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox "Fertig.", 64, "Info"
End Sub
Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    Dim strDirName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath, strSearch
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = TrimNulls(WFD.cFileName)
                If (strDirName <> ".") And (strDirName <> "..") Then
                    lngDirCount = lngDirCount + 1
                    FindFiles strFolderPath & strDirName, strSearch
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    Dim strFileName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = TrimNulls(WFD.cFileName)
                lngFileCount = lngFileCount + 1
                ReDim Preserve strFiles(1 To lngFileCount)
                strFiles(lngFileCount) = strFolderPath & strFileName
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub
Private Function TrimNulls(ByVal strStringIn As String) As String
    If InStr(strStringIn, Chr(0)) > 0 Then strStringIn = Left$(strStringIn, InStr(strStringIn, Chr(0)) - 1)
    TrimNulls = strStringIn
End Function
Private Sub Teistring_tauschen(strDateiname As String)
    Dim objVBC As Object, intLine As Integer, strFront As String, strBack As String
    For Each objVBC In Workbooks(strDateiname).VBProject.VBComponents
        With objVBC.CodeModule
            For intLine = 1 To .CountOfLines
                If InStr(1, .Lines(intLine, 1), strText_old) <> 0 Then
                    strFront = Left$(.Lines(intLine, 1), InStr(1, .Lines(intLine, 1), strText_old) - 1)
                    strBack = Mid$(.Lines(intLine, 1), InStr(1, .Lines(intLine, 1), strText_old) + 20)
                    .ReplaceLine intLine, strFront & strText_new & strBack
                End If
            Next
        End With
    Next
End Sub

Gruß
Nepumuk

Sub replace_macro_code() Dim int_files As Integer Dim str_filename As String Dim int_counter As Integer Dim int_macros As Integer Dim lng_position As Long With Application.FileSearch .NewSearch .LookIn = "C:\Dokumente und Einstellungen\DE0328\Desktop\new" .FileType = msoFileTypeExcelWorkbooks .Execute For int_files = 1 To .FoundFiles.Count Cells(int_files, 1).Value = .FoundFiles(int_files) Next End With Application.EnableEvents = False For int_counter = 1 To int_files Application.Workbooks.Open Filename:=Cells(int_counter, 1).Value For int_macros = 1 To ActiveWorkbook.VBProject.VBComponents.Count For lng_position = 1 To ActiveWorkbook.VBProject.VBComponents(int_macros).CodeModule.CountOfLines If ActiveWorkbook.VBProject.VBComponents(int_macros).CodeModule.Lines(lng_position, 1) = "Workbooks.Open Filename:=""C:\Test\Mappe2.xls""" Then ActiveWorkbook.VBProject.VBComponents(int_macros).CodeModule.ReplaceLine lng_position, "Workbooks.Open Filename:=ThisWorkbook.Path & ""\Mappe2.xls""" End If Next Next Application.DisplayAlerts = False ActiveWorkbook.Save Application.DisplayAlerts = True ActiveWorkbook.Close Next Application.EnableEvents = True End Sub

Beliebteste Forumthreads (12 Monate)

absolute Pfade in Makros ändern automatisch ??

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

absolute Pfade in Makros ändern automatisch ??

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread