Code läuft nicht bei geschütztem Projekt
Fritz_W
von Josef Ehrensberger habe ich nachfolgenden Code, der (makrofreie) für jeden Eintrag im Zellbereich A1:A20 der Tabelle 1 Kopien der Datei erstellt, die jeweils nach jedem Zelleintrag aus A1:A20 benannt werden und in den gleichen Ordner wie die Quelldatei kopiert werden.
Soweit funktioniert das Ganze wunderbar.
Sobald ich jedoch das Projekt schütze, erscheint folgende Fehlermeldung:
Fehler 50289
Die Operation kann nicht durchgeführt werden, solange das Projekt geschützt ist.
Kann man den Code dahingehend ändern, dass das Ganze auch bei geschütztem Projekt läuft.
Im Voraus besten Dank für Eure Unterstützung.
mfg
Fritz
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub copyMe()
Dim objWB As Workbook
Dim vbComp As Object
Dim rng As Range
Dim strSave As String, strExt As String, strSaveXLSM As String, intCnt As Integer
On Error GoTo ErrExit
GMS
For Each rng In ThisWorkbook.Sheets("Tabelle1").Range("A1:A20")
If rng "" Then
intCnt = intCnt + 1
Application.StatusBar = "Speichern von Datei " & CStr(intCnt) & " / " & rng.Text & Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
strSave = ThisWorkbook.Path & "\" & rng.Text & Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
ThisWorkbook.SaveCopyAs strSave
Set objWB = Workbooks.Open(strSave)
With objWB
With .Sheets("Tabelle1")
.Range("A1:A20").ClearContents
.Range("A1") = rng
.Rows(1).Hidden = True
End With
For Each vbComp In .VBProject.vbcomponents
If vbComp.Type = 100 Then
With .VBProject.vbcomponents(vbComp.Name).CodeModule
.DeleteLines 1, .CountOfLines
End With
Else
.VBProject.vbcomponents.Remove vbComp
End If
Next
strExt = Mid(strSave, InStrRev(strSave, "."))
If Len(strExt) > 4 Then strExt = Left(strExt, 4) & "x"
strSaveXLSM = Left(strSave, InStrRev(strSave, ".") - 1)
strSaveXLSM = strSaveXLSM & strExt
objWB.SaveAs strSaveXLSM, FileFormat:=IIf(Len(strExt) = 5, 51, -4143)
objWB.Close
Kill strSave
End With
End If
Next
ErrExit:
With Err
If .Number 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (copyMe) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / copyMe"
End With
GMS True
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
.StatusBar = False
End With
End Sub