Option Explicit
'======================================================================================
'Requires the Reference "Microsoft for Visual Basic for Applications Exetnsibility 5.3"
'======================================================================================
Sub Test()
Call CopyWorkbookToNewWorkbook(ThisWorkbook, IncludeVBAProject:=True)
End Sub
'------------------------------------
'Copy as Workbook into a new Workbook
'------------------------------------
Sub CopyWorkbookToNewWorkbook(SourceWorkbook As Workbook, Optional IncludeVBAProject As Boolean = False)
Dim TargetWorkbook As Workbook
Dim TabArray() As Variant
Dim VBComponents As VBComponents
Dim VBComponent As VBComponent
Dim VBComponentExtension As String
Dim VBComponentFileName As String
Dim VBComponentsCollection As New Collection
Dim ErrNumber As Long
Dim S As String
Dim i As Integer
Dim k As Integer
Dim p As Integer
Dim Rep As VbMsgBoxResult
Dim Rep2 As VbMsgBoxResult
Application.ScreenUpdating = False
On Error Resume Next
If IncludeVBAProject Then
Set VBComponents = SourceWorkbook.VBProject.VBComponents
If Err Then
Rep = MsgBox("En l'etat le niveau de sécurité dans les options d'Excel" & vbCrLf & _
"Ne permet pas la copie des modules" & vbCrLf & vbCrLf & _
"Vous devez cochez l'accès aprouvé à l'objet du modèle de projet vba" & vbCrLf & vbCrLf & _
"Voulez vous aller activer cet accès approuvé " & vbCrLf & _
"Vous pourez réessayer apres l'export", vbYesNo + vbInformation)
If Rep = vbYes Then
Application.CommandBars.ExecuteMso "MacroSecurity"
Exit Sub
Else
Rep2 = MsgBox("Très bien pas de modules exportés" & vbCrLf & _
"Voulez vous continuer la creation" & vbCrLf & "du clone de ce classeur Sans ces Macros !!!", vbYesNo, vbInformation)
If Rep2 = vbNo Then Exit Sub
End If
End If
End If
'----------------------------------------------------------------------------------
'Copy the source Workbook & Worksheets with their VBA code to a new target Workbook
'----------------------------------------------------------------------------------
With SourceWorkbook
ReDim TabArray(1 To .Worksheets.Count)
ReDim chartarray(1)
For i = 1 To .Worksheets.Count
TabArray(i) = i
Next i
'Creates a new target Workbook with the selected source Workbook Worksheets
.Worksheets(TabArray).Select
Worksheets.Copy
Set TargetWorkbook = ActiveWorkbook
'-------------------------------------
'Added by patricktoulon
'Ajout de la copie des feuilles graphiques(thisworkbook.charts)
'exemple
'un graphique dans une feuille = Worksheets("Feuil1").ChartObjects ("mongraphique")
'une feuille graphique = ThisWorkbook.Charts("mongraphique")
'-------------------------------------
Dim C
For Each C In ThisWorkbook.Charts
C.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Next
'--------------------------------------
'Added by patricktoulon
'copie du code dans Thisworkbook
Dim code$
With ThisWorkbook.VBProject.VBComponents("Thisworkbook")
code = .CodeModule.Lines(1, .CodeModule.CountOfLines)
End With
If Trim(code) <> "" Then
With ActiveWorkbook.VBProject.VBComponents("Thisworkbook")
.CodeModule.InsertLines 1, code
End With
End If
'Needed to "unlock" the all Worksheets Selection
With SourceWorkbook
.Activate
.Worksheets(1).Select
End With
TargetWorkbook.Activate
'---------------
'Copy the Shapes
'---------------
For i = 1 To .Worksheets.Count
For k = 1 To .Worksheets(i).Shapes.Count
'Copy the Shape and its position
.Worksheets(i).Shapes(k).Copy
TargetWorkbook.Worksheets(i).Paste
TargetWorkbook.Worksheets(i).Shapes(k).Left = .Worksheets(i).Shapes(k).Left
TargetWorkbook.Worksheets(i).Shapes(k).Top = .Worksheets(i).Shapes(k).Top
'Adapt the OnAction string
S = .Worksheets(i).Shapes(k).OnAction
If Not Len(S) = 0 Then
p = InStr(S, "!")
If p > 0 Then
If Replace(Left(S, p - 1), "'", "") = SourceWorkbook.Name Then
TargetWorkbook.Worksheets(i).Shapes(k).OnAction = "'" & TargetWorkbook.Name & "'!" & Mid(S, p + 1)
End If
End If
End If
Next k
'Release the last Shape selected
ActiveCell.Select
Next i
End With
'------------------------------------------------------------
'Include the VBA Project Modules, Class Modules and UserForms
'------------------------------------------------------------
If IncludeVBAProject Then
If VBEOK Then
Set VBComponents = SourceWorkbook.VBProject.VBComponents
If Not VBComponents Is Nothing Then
'Export VBComponents of the source Workbook
For Each VBComponent In VBComponents
Select Case VBComponent.Type
Case vbext_ct_StdModule
VBComponentExtension = ".bas"
Case vbext_ct_ClassModule
VBComponentExtension = ".cls"
Case vbext_ct_MSForm
VBComponentExtension = ".frm"
Case Else
VBComponentExtension = ""
End Select
If Not Len(VBComponentExtension) = 0 Then
VBComponentFileName = Environ("TMP") & "\" & VBComponent.Name & VBComponentExtension
If Not Len(Dir(VBComponentFileName)) = 0 Then
Kill VBComponentFileName
End If
VBComponent.Export VBComponentFileName
VBComponentsCollection.Add VBComponentFileName
End If
Next VBComponent
'Import VBComponents to the new target Workbook
Do While VBComponentsCollection.Count > 0
TargetWorkbook.VBProject.VBComponents.Import VBComponentsCollection(1)
Kill VBComponentsCollection(1)
VBComponentsCollection.Remove 1
Loop
'Copy the Reference list of the source Workbook into the target new Workbook
With SourceWorkbook
On Error Resume Next
For i = 1 To .VBProject.References.Count
TargetWorkbook.VBProject.References.AddFromFile .VBProject.References.Item(i).FullPath
Next i
On Error GoTo 0
End With
End If
End If
End If
Application.ScreenUpdating = True
'Close the source Workbook
SourceWorkbook.Close SaveChanges:=False
End Sub
'-------------------------------------------------------------------------------------
'Return True if the "Trust Access to the VBA Project Object Model" checkbox is checked
'-------------------------------------------------------------------------------------
Function VBEOK() As Boolean
Dim Version As String
Dim ErrNumber As Long
On Error Resume Next
Version = ThisWorkbook.VBProject.VBE.Version
ErrNumber = Err.Number
On Error GoTo 0
If ErrNumber = 0 Then
'Return value
VBEOK = True
End If
End Function
