Enregistrer un classeur sans écraser l'original - Enregistrer sous - desactiver

Question

Bonjour à tous,

Avant de poser mes questions, je tiens à remercier toutes les personnes qui se pencheront éventuellement sur mon problème.
Je suis débutant sur VBA et travaille sur Excel depuis une dizaine d'année, et après avoir répété les mêmes taches tous les jours pendant beaucoup trop longtemps... j'ai décidé « d'automatiser » tout ça et me suis lancé dans VBA. J'ai souvent fouillé sur le forum pour résoudre mes problèmes et je n'aurai jamais pu m'en sortir sans vous ... Un grand merci, donc, aux généreux participants de ce site que j'ose qualifier d'indispensable pour les gros neuneus comme moi !!!

Je travaille en Bureau d'Etude dans le BTP, et j'ai mis en place des macros me permettant de remplir des feuilles de calculs (numéro et nom de dossier, choix de département et de commune des travaux pour intégrer le coût de transport, etc.). Après avoir travaillé pour moi, on me demande aujourd'hui de partager mon travail avec d'autres utilisateurs. Mon but a donc été de rendre « invisible » l'ensemble des macros et des formules pour que, d'une part l'utilisateur trouve l'utilisation facile (nous sommes dans un secteur ou l'informatique n'est pas forcement accessible à tous), mais surtout pour qu'ils ne puissent pas les modifier.

Bref, excusez-moi pour tout ce blabla, tout ça pour dire que suis coincé entre laissé à l'utilisateur une grande liberté (le but est qu'il utilise excel comme il le souhaite) ET l'empêché de massacrer ma feuille de calcul ?

----------------------------------------------
Mes problèmes :

Visual Basic 6.3
Excel 2003 SP2

Je ne peux pas laisser le fichier en lecture seule et je souhaite qu'ils utilisent un « enregistrer sous » guidé avant la fermeture du fichier, sans modifier l'original ? De plus le nom du fichier et du dossier dans lequel ils doivent enregistrer est du type :
Répertoire : AAMMxxxx ? Nom de la Commune           - Date de réponse
Nom du fichier : Titre du dossier
Le fichier original doit se fermer sans etre modifier : ThisWorkbook.Saved = True ???
J'essaye de créer un repertoire sauf si il existe déjà (j'avais réussi à ouvrir la boite de dialogue Enregistrer sous MAIS je n'ai pas réussi à modifier le répertoire par défaut, qui reste celui de mon original)

Voilà ou j'en suis ? mais ça ne marche pas

Private Sub Workbook_BeforeClose(Cancel As Boolean)

'définit le nom du fichier et du répertoire

NomFichier = Affaire.Tb_NomAff.Text
NumDossier = Affaire.Tb_NumAff1.Text & Affaire.Tb_NumAff2.Text & Affaire.Tb_NumAff3.Text
Chemin = "\10.33.38.10\Utilisateurs$\NDELRIE\Mes documents\Nicolas\Etudes"

'Créé le repertoire si il n'existe pas sinon enregistre dedans

If Dir(Chemin & NumDossier & " -*") = "" _
    Then MkDir (Chemin & NumDossier & " - " & NomCommune)
    Else
End If

Application.Dialogs(xlDialogSaveAs).Show "Etude " & NomFichier & ".xls"

'ferme le fichier original sans enregister les modifications

ThisWorkbook.Saved = True

End Sub

P.S : Désolé de la longueur du message  ... j'ai encore énormement de probleme  
P.S 2 : j'espère avoir créé mon post au bon endroit ?!?

Ndelrieu · Answer

Je souhaiterais également désactiver les macros à la fermeture (sinon quand l'utilisateur ouvre le fichier à nouveau il efface toutes ces données)...

c148270 · Answer

Bonjour

Idée

Pour éviter une modification d'un classeur origine, il faut utiliser un modèle
changez l'extension xls en xlt
rajouter un module auto_close qui sera exécuté à la fermeture.
Créer un classeur application qui appellera ce modèle.

voici un exemple de suppression de modules excel

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 ' no VBComponents or protected VBProject
        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)
            ' delete the component
            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

Bien sur l'adapter à votre cas (par exemple remplacer la variable fic par le vrai nom du classeur
cette fonction, telle que décrite est dans un module nommé Msupp dans cet exemple.

Bonne journée

Ndelrieu · Answer

Merci de votre réponse ...
Je vais tester votre solution ... excusez moi pour le délai, mais je suis trop novice pour la comprendre "juste" en lisant le code ...

Mais j'ai cru voir une fonction permettantde désactiver els macros ??? : 
If i < 1 Then ' no VBComponents or protected VBProject 
MsgBox "The VBProject in " & ActiveWorkbook.Name & _ 
" is protected or has no components!", _ 
vbInformation, "Remove All Macros" 
Exit Function 

Je me permet de te montrer ou j'en étais ... j'essaye desepérement de tester la présence du répertoire d'enregistrement ... si il existe déjà je souhaite "juste" enregistrer le fichier dedans, dans le cas contraire ouvrir une boite de dialogue type "enregistrer sous" (module que j'ai récupéré sur internet mais qui me parrait bien compliqué) ... ca ne marche pas ... (ça me créé un nouveau répertoire même quand celui-ci existe ... je voudrais tester le début du nom du répertoire du type "AAMMXXXX -" je voulais utiliser "*" pour la fin du nom ... mais ça ne marche pas !!!

Private Sub Workbook_BeforeClose(Cancel As Boolean)

'définit le nom du fichier et du répertoire par défaut

Dim NomFichier As String
Dim Numdossier As String
Dim Repertoire As String

NomFichier = Affaire.Tb_NomAff.Text
Numdossier = Affaire.Tb_NumAff1.Text & Affaire.Tb_NumAff2.Text & Affaire.Tb_NumAff3.Text
Repertoire = "\MonChemin"

'Créé le repertoire si il n'existe pas

If Dir(Repertoire + "" + Numdossier + " - ") = "" Then
MkDir (Repertoire + "" + Numdossier + " - " + "")
ChDir (Repertoire + "" + Numdossier + " - " + "")
ActiveWorkbook.SaveAs ("Etude " & NomFichier & ".xls")
End If

'Lance le mode Enregistrer un fichier avec les données ci-dessus

MsgBox EnregistrerUnFichier("Enrégistrer votre Etude sans écraser l'original", "Etude " & NomFichier & ".xls", Repertoire)

'ferme le fichier original sans enregister les modifications

ThisWorkbook.Saved = True

End Sub

c148270 · Answer

Re

c'est vrai que le module que j'ai transmis fait parti d'une de mes appli boîte à outils qui me permet de "bricoler" des fichiers.

Voici le module tel que je l'ai inclus dans un classeur

Function Suppmodule()
' Suppression des modules pour ne pas exécuter à l'ouverture du classeur résultant
suite0:
    i = 0
    On Error Resume Next
    i = ActiveWorkbook.VBProject.VBComponents.Count
    On Error GoTo 0
    With ActiveWorkbook.VBProject
        For i = .VBComponents.Count To 1 Step -1
                If .VBComponents(i).Name = "Msupp" Then GoTo suite1
                If .VBComponents(i).Type = 1 Then GoTo suite
            GoTo suite1
suite:
            .VBComponents.Remove .VBComponents(i)
            ' delete the component
            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

End Function

Cette fonction est incluse dans un module Msupp.
A ne pas supprimer du classeur résultant

pour la deuxième question attendre un peu le chapitre suivant

Bonne journée

Ndelrieu · Answer

Oki merci ... je test tout ça !!!

Ndelrieu · Answer

Re c148270,

SI je ne me suis pas trompé dans la manipulation, ton code marche bien pour m'effacer les modules ... MAIS cela ne me désactive pas mes boites de dialogue qui se lancent à l'ouverture de mon fichier sauvegardé (et qui remmettent à zéro toutes les modifications apportées par l'utilisateur) ...
Pour etre plus clair ... cela m'efface bien les modules (les tiens et celui que j'avais téléchargé pour "enregistrer sous parametrable"), mais ne désactive pas les macros ... 

Ceci-dit, n'étant que novice je n'ai peut etre pas fait ce qu'il fallait ...

c148270 · Answer

Bonjour
Celà vient de l'instruction dans l'exemple :
If .VBComponents(i).Type = 1 Then GoTo suite 
qui ne prend que les modules standards.
Supprime ce test.

Pour info (que l'on peut trouver dans l'aide) :
type 1 = module standard
type 2 =module de classe
type 3 = msform
etc.

Bonne journée

c148270 · Answer

RE
Pour les répertoires
Attention à la syntaxe très rigide. Je ne suis pas sur que le $ soit accepté.

Un répertoire de départ paut être fourni a commondialog par initdir=

Bonne suite

Ndelrieu · Answer

Merci ...

je regarde ça au plus vite ...

Enregistrer un classeur sans écraser l'original - Enregistrer sous - desactiver

9 réponses

Votre réponse

Discussions similaires