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:
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:
Addin module CmdExec:
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
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:
Code:
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 SubThe 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:
Code:
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 SubAddin module CmdExec:
Code:
...
...
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
