AW: Lösung zum Problem beim Einfügen von Code (@Al
08.01.2008 15:28:54
Code
Hallo Luschi,
Du hast recht. Ich habe da einiges geändert, vielleicht stelle ich noch mal den aktuellen Code ein:
Public Function transferVBACode(source As Masterlist, dest As Masterlist) As Boolean
Dim returnValue As Boolean
Dim FName As String
Dim VBComp As VBIDE.VBComponent
Dim VBCompInDest As VBIDE.VBComponent
Dim restoreScreenUpdating As Boolean
Dim restoreEvents As Boolean
Dim destWorkbook As Workbook
Dim sourceWorkbook As Workbook
Dim destVBComponents As VBComponents
Dim sourceVBComponents As VBComponents
Dim destFolderPath As String
Dim currentComp_Name As String
Dim currentComp_Type As Integer
Dim currentComp_Code As String
Dim newComp As VBComponent
Dim comp_match As Boolean
Dim search_ws_ml As Boolean
Dim i As Integer
If Application.ScreenUpdating = False Then
Application.ScreenUpdating = True
restoreScreenUpdating = True
End If
If Application.enableEvents = True Then
Application.enableEvents = False
restoreEvents = True
End If
' Projekte wenn nötig entsperren
If source.VBAProjectProtected = True Then
returnValue = source.UnlockVBAProject
If returnValue = False Then
transferVBACode = False
Exit Function
End If
End If
If dest.VBAProjectProtected = True Then
returnValue = dest.UnlockVBAProject
If returnValue = False Then
transferVBACode = False
Exit Function
End If
End If
' Workbook- und Component-Objekte initialisieren
Set destWorkbook = dest.GetMLWorkbook
Set sourceWorkbook = source.GetMLWorkbook
Set destVBComponents = destWorkbook.VBProject.VBComponents
Set sourceVBComponents = sourceWorkbook.VBProject.VBComponents
' Ordnerpfad der Zieldatei merken
destFolderPath = dest.GetFolderPath
' ### Code der Zieldatei löschen ###
For Each VBComp In destVBComponents
With VBComp.CodeModule
If VBComp.Type vbext_ct_MSForm Then
.DeleteLines 1, .CountOfLines
End If
If VBComp.Type = vbext_ct_MSForm Or _
VBComp.Type = vbext_ct_ClassModule Or _
VBComp.Type = vbext_ct_StdModule Then
destVBComponents.Remove VBComp
End If
End With
Next VBComp
' ### Module kopieren ###
' Hier kommt es darauf an, den Code einer Komponente des Templates der richtigen
' Komponente der Zieldatei zuzuordnen. Diese Zuordnung kann eindeutig geschehen, wenn
' der Name und der Typ beider Komponenten übereinstimmen.
' Wird keine Entsprechung in der Zieltabelle gefunden, wird eine Komponente mit diesem
' Namen und Typ generiert und der Code dort eingefügt.
' !!!Wichtiger Hinweis!!! Wer über folgendes Fragment stolpert:
' .AddFromString String:=Replace(currentComp_Code, "Private ", "")
' Wird der Code einer Ereignisprozedur mit dem Schlüsselwort "Private" in der Signatur
' eingefügt, stürzt Excel danach komplett ab. Dies ist ein Fehler im VBE und wird durch
' oben stehendes Konstrukt umgangen! Das herauszufinden, hat mich viele Arbeitsstunden
' gekostet. Falls daher mal beim Aktualisieren einer Masterliste ein Absturz erfolgt,
' sollte der Fehler zunächst hier gesucht werden (evtl. tritt das Problem auch bei
' anderen Schlüsselwörtern auf)!
For Each VBComp In sourceVBComponents
' Namen (Worksheet-Name), Typ und Code der aktuellen Komponente des Templates auslesen
currentComp_Type = VBComp.Type
currentComp_Code = VBComp.CodeModule.Lines(1, VBComp.CodeModule.CountOfLines)
Select Case currentComp_Type
Case vbext_ct_StdModule, vbext_ct_Document, vbext_ct_ClassModule
' Spezialfall "DieseArbeitsmappe": der Name ist hier nicht in den Properties zu _
finden
If VBComp.Name = "DieseArbeitsmappe" Then
' Neuen Code einfügen
destVBComponents(VBComp.Name).CodeModule.AddFromString String:=Replace
Else
comp_match = False
' Komponente mit gleichen (Klartext-)Namen der Zieldatei suchen
For Each VBCompInDest In destVBComponents
If VBCompInDest.Properties("Name") = VBComp.Properties("Name") Then
' Neuen Code einfügen
VBCompInDest.CodeModule.AddFromString String:=Replace( _
currentComp_Code, "Private ", "")
comp_match = True
Exit For
End If
Next VBCompInDest
' Komponente ist nicht in der Zieldatei vorhanden
If comp_match = False Then
' Modul ist nicht vorhanden
' -> neue Komponente des richtigen Typs erstellen
Set newComp = destVBComponents.Add(VBComp.Type)
' Code einfügen
newComp.CodeModule.AddFromString String:=Replace(currentComp_Code, " _
Private ", "")
' Nun müssen noch alle Eigenschafts-Werte der Komponente übertragen _
werden
' For i = 1 To VBComp.Properties.Count
' newComp.Properties.Item(i) = VBComp.Properties.Item(i)
' Next i
End If
End If
Case vbext_ct_MSForm
' Formular-Modul in den Ordner der Zieldatei exportieren ...
FName = destFolderPath & "\" & VBComp.Name & ".frm"
VBComp.Export FName
' ... und importieren
destVBComponents.Import FName
' temporäre Datei(en) löschen
Kill FName
Kill Replace(FName, ".frm", ".frx")
Case Else
End Select
comp_match = False
Next VBComp ' nächste Komponente
' Operation war erfolgreich, wenn wir bis hierher gekommen sind
transferVBACode = True
' Das aktive Projekt soll nun wieder dieses sein
Set Application.VBE.ActiveVBProject = ThisWorkbook.VBProject
Application.VBE.MainWindow.Visible = False
If restoreScreenUpdating Then
Application.ScreenUpdating = False
End If
If restoreEvents Then
Application.enableEvents = True
End If
' Objekte freigeben
Set destWorkbook = Nothing
Set sourceWorkbook = Nothing
Set destVBComponents = Nothing
Set sourceVBComponents = Nothing
Set VBCompInDest = Nothing
Set newComp = Nothing
Set VBComp = Nothing
End Function
Hier ist die Zeile auf jeden Fall vorhanden. Der Code funktioniert auch bei den meisten Dateien, nur eben nicht dort, wo eines der Formulare nicht gelöscht wird.
Gruß,
Kolja