copy worksheets into new workbook preserving code and objects

[fspino]

Hallo,
I need to copy almost all of the worksheets enclosed in addin workbook in a new workbook as a copy of addin workbook, without the modules and classes, but preserving the code and the object (Image1) included into the originals worksheets.

The code enclosed into the worksheet modules of my addin is very simple:

Option Explicit
Public Dove As String
Private Sub Image1_Click()
    Dim temp
    If Dove = "Close" Then
        temp = Application.Run("Vecacs_2.11.xla!cancellaLavagna", ActiveSheet.Name)
        'Image1.Visible = False
    'Else
    '    If Dove <> "Bar" Then
    '        MsgBox Dove
    '    End If
    End If
End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Y <= 17 Then
        If X >= 404 Then
            Dove = "Close"
        Else
            Dove = "Bar"
        End If
    Else
        Dove = "X=" + Trim(Str(X)) + ", Y=" + Trim(Str(Y))
    End If
End Sub

The code as shown in the code is linked to an Image enclosed into each worksheet.

My VBA code works exacly as I want: preserves both images and code but when I save the new workbook and then I reopen it the code into the worksheet modules... vanished!

I saw, that's no problem! When the new workbook is re-opened I check if exists the code into the worksheet modules...if doesn't I re-create it...simply!

But, of course, it doesn't work!

I tried two different ways: first one crashes Excel (none explain), the second returns: run-time error 57017 (something like "Routine management of events is not valid") at the row: LineNum = .CreateEventProc(Evento, Oggetto) (see below).

The code to create the aforementioned subs is the following.

Addin module RepairSheet:

Option Explicit
Public Sub AddEventProcedure(Progetto As String, Modulo As String, Oggetto As String, Evento As String, MacroCode As String)
    Dim VBCodeMod As CodeModule
    Dim LineNum As Long
    Set VBCodeMod = Workbooks(Progetto).VBProject.VBComponents(Modulo).CodeModule
    With VBCodeMod
        LineNum = .CreateEventProc(Evento, Oggetto)
        LineNum = LineNum + 1
        .InsertLines LineNum, MacroCode
    End With
End Sub
Public Sub AddProcedure(Progetto As String, Modulo As String, Macro As String, MacroCode As String)
' Use Microsoft Visual Basic For Applications Extensibility 5.3
    Dim VBCodeMod As CodeModule
    Dim LineNum As Long
    Set VBCodeMod = Workbooks(Progetto).VBProject.VBComponents(Modulo).CodeModule
    With VBCodeMod
        LineNum = .CountOfLines + 1
        .InsertLines LineNum, MacroCode
    End With
    'Dopo che la macro è stata creata la si può lanciare con:
    'Application.Run Macro
End Sub
Public Sub DeleteProcedure(Progetto As String, Modulo As String, Macro As String)
' Use Microsoft Visual Basic For Applications Extensibility 5.3
    Dim VBCodeMod As CodeModule
    Dim StartLine As Long
    Dim HowManyLines As Long
    Set VBCodeMod = Workbooks(Progetto).VBProject.VBComponents(Modulo).CodeModule
    With VBCodeMod
        StartLine = .ProcStartLine(Macro, vbext_pk_Proc)
        HowManyLines = .ProcCountLines(Macro, vbext_pk_Proc)
        .DeleteLines StartLine, HowManyLines
    End With
End Sub
Public Function ComponentName(Progetto As String, Foglio As String) As String
' Use Microsoft Visual Basic For Applications Extensibility 5.3
    Dim comp As VBComponent
    ComponentName = ""
    For Each comp In Workbooks(Progetto).VBProject.VBComponents
        If comp.Properties.Item("Name") = Foglio Then
            ComponentName = comp.Name
            Exit For
        End If
    Next comp
End Function
Public Function CheckProcedure(Progetto As String, Modulo As String, Macro As String) As Boolean
' Use Microsoft Visual Basic For Applications Extensibility 5.3
    Dim VBCodeMod As CodeModule
    Dim StartLine As Long
    Dim HowManyLines As Long
    HowManyLines = 0
    StartLine = 0
    CheckProcedure = False
    On Error Resume Next
    Set VBCodeMod = Workbooks(Progetto).VBProject.VBComponents(Modulo).CodeModule
    If VBCodeMod Is Nothing Then
        CheckProcedure = False
    Else
        With VBCodeMod
            StartLine = .ProcStartLine(Macro, vbext_pk_Proc)
            HowManyLines = .ProcCountLines(Macro, vbext_pk_Proc)
        End With
        If StartLine = 0 And HowManyLines = 0 Then CheckProcedure = False Else CheckProcedure = True
    End If
End Function
Public Sub AddBlackboardCode(Progetto As String, Modulo As String)
    Dim MacroCode As String
    Dim Macro As String
    Macro = "Image1_Click"
    MacroCode = _
    "Option Explicit" & vbCrLf & _
    "Public Dove As String"
    AddProcedure Progetto, Modulo, Macro, MacroCode
    
    '"Private Sub Image1_Click()" & vbCrLf &
    MacroCode = _
    "    Dim temp" & vbCrLf & _
    "    If Dove = ""Close"" Then" & vbCrLf & _
    "        temp = Application.Run(""Vecacs_2.11.xla!cancellaLavagna"", ActiveSheet.Name)" & vbCrLf & _
    "        'Image1.Visible = False" & vbCrLf & _
    "    'Else" & vbCrLf & _
    "    '    If Dove <> ""Bar"" Then" & vbCrLf & _
    "    '        MsgBox Dove" & vbCrLf & _
    "    '    End If" & vbCrLf & _
    "    End If" & vbCrLf
    '"End Sub" & vbCrLf
    AddEventProcedure Progetto, Modulo, "Image1", "Click", MacroCode
    
    '"Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)" & vbCrLf &
    MacroCode = _
    "    If Y <= 17 Then" & vbCrLf & _
    "        If x >= 404 Then" & vbCrLf & _
    "            Dove = ""Close""" & vbCrLf & _
    "        Else" & vbCrLf & _
    "            Dove = ""Bar""" & vbCrLf & _
    "        End If" & vbCrLf & _
    "    Else" & vbCrLf & _
    "        Dove = ""X="" + Trim(Str(x)) + "", Y="" + Trim(Str(Y))" & vbCrLf & _
    "    End If" & vbCrLf
    '"End Sub" & vbCrLf
    AddEventProcedure Progetto, Modulo, "Image1", "MouseMove", MacroCode
End Sub

Addin module CmdExec:

      ...
      ...
      ActWsName = ActWsName = ActiveSheet.Name
      ...
      ...
      actModName = ComponentName(ActiveWorkbook.Name, ActWsName)
      If actModName <> "" Then
        If Not CheckProcedure(ActiveWorkbook.Name, actModName, "Image1_Click") Then
            AddBlackboardCode ActiveWorkbook.Name, actModName
        End If
      End If
      ...
      ...

Not all!
If I create, manually, the code into the worksheets into the reopened workbook the code is not linked to "Image1")!

Then...now I have now two chance:
1. I find a system to create new workbook with the object and code that remain the same after saved.
2. I find a system to generate code into the worksheet of the new workbook as it reopened.

Please, can somebody helps me?

Many thanks in advance.

Francesco

 

[fspino]

Nobody else can help me? ray: