ôter les macros quand on suaveagarde un fichierRésolu

Question

Bonjour,

ma question est la suivante :

à l'aide d'une macro, je suavegarde un fichier excel sous un nom différent (ça je sais faire :
ActiveWorkbook.SaveAs Filename:= _
        "D:\blabla
ouveau.xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False)

mais je voudrais que le nouveau fichier ne contienne ni les macros ni les boutons des macros du fichier d'origine.

Quelqu'un peut-il me dépanner ? Merci d'avance.

cs_Le Pivert · Accepted Answer

Bonjour,
Il y a plus simple:

Sub SaveAsWithoutMacros()
 ThisWorkbook.Sheets.Copy
  ActiveWorkbook.SaveAs ("Chemin du nouveau fichier")
  ThisWorkbook.Close False
End Sub



@+
Le Pivert

c148270 · Answer

Bonjour Voici des fonctions. Il faudra faire le tri. Le point de départ est la fonction Cherche. Avec ces fonctions je peut ajouter ou supprimer des modules Public Repertoire Public Filesavename Public Fic As String Public Choix Public Retannul Function Cherche() Dim Retval1 ' With Assistant ' .On = True ' .Visible = True ' .Sounds = True ' End With debut: Choix = InputBox("Création (1)ou suppression (2) de module ?") If Choix = "" Then GoTo fin Chercherep Filesavename = Filesavename & "" boutdroit = Len(Filesavename) boutgauche = InStrRev(Filesavename, "", boutdroit, 1) Repertoire = Left(Filesavename, boutgauche) With Application.FileSearch .NewSearch .LookIn = Repertoire .SearchSubFolders = True lenlookin = Len(.LookIn) If Mid(.LookIn, lenlookin, lenlookin) = "" Then rien = .LookIn Else rien = .LookIn & "" End If ' pour comparaison que le nom du répertoire soit en majuscules ou minuscules ou mixte End With With Application.FileSearch If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Fic = .FoundFiles(i) 'retval1 = MsgBox(Fic, vbYesNoCancel, "Fichier à nettoyer") ' If retval1 = 6 Then Suppmodule ' End If If Retannul = 2 Then GoTo fin Next i End If End With fin: With Assistant .On = False .Visible = False .Sounds = False End With End Function Function Chercherep() Dim oFolderitems As FolderItems Dim oFolderitem As FolderItem Dim objShell As Shell Dim ssfWINDOWS As Long Dim objFolder As Folder Dim lenlookin As String Dim boutdroit As Integer ssfWINDOWS = 0 Set objShell = New Shell Set objFolder = objShell.BrowseForFolder(0, "Choisissez un répertoire", 0, ssfWINDOWS) If (Not objFolder Is Nothing) Then Set oFolderitems = objFolder.Items Set oFolderitem = oFolderitems.Item Filesavename = oFolderitem.Path 'Add code here ' si l'utilisateur choisi un répertoire racine, le nom est suivi d'un \ ' exemple : choix data (d:) alors filesavename c:\ ' si l'utilisateur choisi un sous-répertoire, le nom N'EST PAS SUIVI D'UN \ lenlookin = Len(Filesavename) If Mid(Filesavename, lenlookin, lenlookin) = "" Then lenlookin = lenlookin - 1 Filesavename = Left(Filesavename, lenlookin) End If End If Set objFolder = Nothing Set objShell = Nothing End Function Function Suppmodule() Dim i As Long, l As Long Application.DisplayAlerts = False Workbooks.Open Fic Retval1 = MsgBox(Fic, vbYesNoCancel, "Fichier à nettoyer") Retannul = Retval1 If Retval1 = 6 Then GoTo debut 'Suppmodule If Retval1 = 2 Then ActiveWorkbook.Close Savechanges:=False Exit Function End If If Retval1 = 7 Then ActiveWorkbook.Close Savechanges:=False Exit Function End If debut: If Choix = 1 Then Majout GoTo suite2 End If If Choix < 1 Or Choix > 2 Then Exit Function Application.DisplayAlerts = True If ActiveWorkbook Is Nothing Then Exit Function Set balon = Assistant.NewBalloon With balon .BalloonType = msoBalloonTypeBullets .Icon = msoIconTip .Button = msoButtonSetOK .Heading = "Suppression de modules" .CheckBoxes(1).Text = "Formulaires" .CheckBoxes(2).Text = "Modules standards" .CheckBoxes(3).Text = "Modules de classe" .CheckBoxes(4).Text = "Formulaires et Modules" balon.Show If .CheckBoxes(1).Checked = True Then ok = 1 GoTo suite0 End If If .CheckBoxes(2).Checked = True Then ok = 2 GoTo suite0 End If If .CheckBoxes(3).Checked = True Then ok = 3 GoTo suite0 End If If .CheckBoxes(4).Checked = True Then ok = 4 GoTo suite0 End If Exit Function End With suite0: i = 0 On Error Resume Next i = ActiveWorkbook.VBProject.VBComponents.Count On Error GoTo 0 If i < 1 Then ' pas de VBComponents or VBProject protégé MsgBox "The VBProject in " & ActiveWorkbook.Name & _ " is protected or has no components!", _ vbInformation, "Remove All Macros" Exit Function End If With ActiveWorkbook.VBProject For i = .VBComponents.Count To 1 Step -1 If ok = 1 Then If .VBComponents(i).Type = vbext_ct_MSForm Then GoTo suite End If If ok = 2 Then If .VBComponents(i).Name = "Msupp" Then GoTo suite1 If .VBComponents(i).Type = vbext_ct_StdModule Then GoTo suite End If If ok = 3 Then If .VBComponents(i).Type = vbext_ct_ClassModule Then GoTo suite End If If ok = 4 Then If .VBComponents(i).Type = vbext_ct_MSForm Then GoTo suite If .VBComponents(i).Name = "Msupp" Then GoTo suite1 If .VBComponents(i).Type = vbext_ct_StdModule Then GoTo suite End If GoTo suite1 suite: .VBComponents.Remove .VBComponents(i) ' suppressiont l = 1 On Error Resume Next l = .VBComponents(i).codemodule.CountOfLines .VBComponents(i).codemodule.DeleteLines 1, l On Error GoTo 0 suite1: Next i End With suite2: Filesavenom = Application.GetSaveAsFilename(Fic, filefilter:="Classeur Microsoft Excel(*.xls),*.xls") If Filesavenom = False Then Exit Function ActiveWorkbook.Close Savechanges:=True, Filename:=Filesavenom End Function Function Majoutgroup() ActiveWorkbook.VBProject.VBComponents.Import "d:\Mgrdgr.bas" Application.Run "'" & Fic & "'!groupdegroup" End Function Function Majout() ActiveWorkbook.VBProject.VBComponents.Import "d:\Mfiche.bas" ActiveWorkbook.VBProject.VBComponents.Import "d:\Chargement.bas" ActiveWorkbook.VBProject.VBComponents.Import "d:\Eclate.bas" ActiveWorkbook.VBProject.VBComponents.Import "d:\Fermeture.bas" ActiveWorkbook.VBProject.VBComponents.Import "d:\Ouverture.bas" ActiveWorkbook.VBProject.VBComponents.Import "d:\Domaine.frm" ActiveWorkbook.VBProject.VBComponents.Import "d:\Financement.frm" ActiveWorkbook.VBProject.VBComponents.Import "d:\Impression.frm" ActiveWorkbook.VBProject.VBComponents.Import "d:\Typeact.frm" End Function Bonne journée

Ackby · Answer

Merci beaucoup, cordialement.

ôter les macros quand on suaveagarde un fichier

3 réponses

Votre réponse

Discussions similaires