Public Sub CopyComponentsModules() 'copies code from sheets/Thisworkbook/Userforms/Modules/Classes to a new workbook
Dim src As CodeModule, dest As CodeModule
Dim i&
Dim Fname As Variant, sFileName As String
Dim WB_Dest As Workbook
Dim Comp As VBComponent
'sFileName = Trim(Application.Range("txtLostFileName").Value)
Fname = Application.GetOpenFilename(FileFilter:="Excel files (*.xlsm;*.xlsb), *.xlsm;*.xlsb", Title:="Chon file can copy code macro", MultiSelect:=False)
If Fname = False Then
MsgBoxUni UNC("Cha chän file cÇn copy macro!"), vbCritical + vbOKOnly, UNC("Chó ý")
Exit Sub
End If
sFileName = Fname
sFileName = CutLoR2(sFileName, "\", False)
If Not Len(sFileName) > 0 Then
MsgBoxUni UNC("Cha thÊy tªn file cÇn copy macro!"), vbCritical + vbOKOnly, UNC("Chó ý")
Exit Sub
End If
If Not IsLegalFilename(sFileName) Then
MsgBoxUni UNC("Tªn file cÇn copy macro kh«ng hîp lÖ!"), vbCritical + vbOKOnly, UNC("Chó ý")
Exit Sub
End If
On Error Resume Next 'needed for testing if component already exists in destination WorkBook and for cross-references.
If IsFileOpen(sFileName) Then
Set WB_Dest = Application.Workbooks(sFileName) '///////////<==Input workbook name here/////
Else
Set WB_Dest = Workbooks.Open(FileName:=sFileName, Password:=OPassword, ReadOnly:=False, UpdateLinks:=0)
'Set WB_Dest = Workbooks.Open(FileName:=sFileName, ReadOnly:=False, UpdateLinks:=0)
'ActiveWindow.Visible = False
End If
If WB_Dest Is Nothing Then '''Set WB_Dest = Application.Workbooks.Add
MsgBoxUni UNC("Kh«ng t×m thÊy file cÇn copy macro ®ang ®îc më!"), vbCritical + vbOKOnly, UNC("Chó ý")
Exit Sub
End If
'Copy userform
CopyUserForm "DatePickerForm", WB_Dest
CopyUserForm "frmGetDataOpt", WB_Dest
CopyUserForm "frmListAcc", WB_Dest
CopyUserForm "frmListObj", WB_Dest
CopyUserForm "frmProgress", WB_Dest
'Copy source code
For Each Comp In ThisWorkbook.VBProject.VBComponents
If Comp.Type <> vbext_ct_MSForm Then
'i = i + 1
'sh.Cells(i, 1).Value = Comp.Name
'Set Source code module
Set src = Comp.CodeModule 'ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
'test if destination component exists first
i = 0: i = Len(WB_Dest.VBProject.VBComponents(Comp.Name).Name)
If i <> 0 Then 'or: if err=0 then
Set dest = WB_Dest.VBProject.VBComponents(Comp.Name).CodeModule
Else 'create component
With WB_Dest.VBProject.VBComponents.Add(Comp.Type)
.Name = Comp.Name
Set dest = .CodeModule
End With
End If
'copy module/Form/Sheet/Class 's code:
dest.DeleteLines 1, dest.CountOfLines
dest.AddFromString src.Lines(1, src.CountOfLines)
End If
Next Comp
'Add references as well :
Dim Ref As Reference
For Each Ref In ThisWorkbook.VBProject.References
'Debug.Print Ref.Name 'Nom
WB_Dest.VBProject.References.AddFromFile Ref.FullPath
'Debug.Print Ref.FullPath 'Chemin complet
'Debug.Print Ref.Description 'Description de la référence
'Debug.Print Ref.IsBroken 'Indique si la référence est manquante
'Debug.Print Ref.Major & "." & Ref.Minor 'Version
'Debug.Print "---"
Next Ref
Err.Clear: On Error GoTo 0
WB_Dest.Activate
MsgBox "Copy macro completed! Please save the lost-macro file!", vbOKOnly, "Note"
Set Ref = Nothing
Set src = Nothing
Set dest = Nothing
Set Comp = Nothing
Set WB_Dest = Nothing
End Sub
