Da meine Recherche nicht ergeben hat.
Ich weiß das Thema VBA-Passwort wird Kontrovers hoch und runter diskutiert.
Ich bin aber davon überzeugt das es bei der unwissenheit der Nutzer doch eine gewisse Sicherheit gibt und daher würde ich gerne in meiner Datei eines anlegen.
Also hier wie ich vorgehe:
1)Neue Datei wird aus Tabellenblatt erstellt
WsTabelle.Copy
2)Makro wird importiert mit:
ActiveWorkbook.VBProject.VBComponents.Import (DatPfad & "\Modul1.bas") ' importiert die Makros
Jetzt soll das Passwort für diese VBAProject vergeben werden
hat jemand eine Idee?
Vielleicht was wie
ActiveWorkbook.VBProject.VBComponents.Passwort "Geheim" ?
oder
Application.VBE.ActiveVBProject.VBComponents("Automatisierung").Passwort "Geheim"
Falls das hilft hier die sub:
Sub Speichern() 'Alle Dateien überschreiben
Dim WsTabelle As Worksheet
Dim DatPfad As String
DatPfad = ActiveWorkbook.Path
Application.VBE.ActiveVBProject.VBComponents("Automatisierung").Export (DatPfad & "\Modul1. _
_
bas") ' exportiert das Modul um es in die Dateien zu übergeben
For Each WsTabelle In Sheets 'Alle Dateien werden erstellt
If WsTabelle.Index > 4 Then 'auslassen der ersten Tabellen
WsTabelle.Copy
ActiveWorkbook.Password = Left(ActiveSheet.Name, 3)
ActiveWorkbook.VBProject.VBComponents.Import (DatPfad & "\Modul1.bas") ' importiert _
_
die Makros
'Knopf für Makros werden erstellt (zwei Stück)
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 550, 5, 100, 25).Select
Selection.ShapeRange.Name = "PasswortÄnd"
With Selection.ShapeRange("PasswortÄnd")
.ShapeStyle = msoShapeStylePreset11
.TextFrame2.TextRange.Characters.Text = "Passwort ändern?"
.OnAction = "PasswortÄndern"
End With
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 670, 5, 145, 25).Select
Selection.ShapeRange.Name = "DMS"
With Selection.ShapeRange("DMS")
.ShapeStyle = msoShapeStylePreset11
.TextFrame2.TextRange.Characters.Text = "Übergeben an Buchhaltung?"
.OnAction = "DMSundExcelÜbergabe"
.Fill.ForeColor.RGB = RGB(255, 0, 0)
End With
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=DatPfad & "/" & ActiveSheet.Name & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close True
Application.DisplayAlerts = True
End If
Next WsTabelle
If Len(Dir(DatPfad & "\Modul1.bas")) > 0 Then Kill DatPfad & "\Modul1.bas" 'löscht das _
exportierte Modul
End Sub