Bonjour à vous tous,

Voilà, je ne sais si c’est à cause de mes très fortes douleurs ou du à la morphine que je prends chaque jour, je ne m’en sort pas avec ce fichier, c’est pourquoi je sollicite votre aide qui sera très appréciée et pour laquelle je vous en remercie d’avance.
C’est vrai que j’y passe très peu de temps en ces moments difficiles pour moi.

Cette fiche sera envoyée chaque année à des milliers de personnes qui la retourneront par mail une fois renseignée (il peut y en avoir jusqu’à cinq par personne, en retour) au responsable.

Ce que je voudrais obtenir, après avoir cliqué sur : Valider saisie c’est retrouver la fiche sur le bureau (écran) enregistrée sous le nom (en A4) et prénom (K4) de la personne :
- Si une seule fiche :
Msgbox invitant à transmettre le fichier.
- Si plusieurs fiches :
Dans un dossier compressé.
Msgbox invitant à transmettre le dossier.
- Suppression du dossier non zippé avec son contenu.

Note :
La fiche non renseignée, le bouton :
- Valider saisie est visible.
Après clic sur ce bouton :
- C’est le bouton Maj Base qui devient visible.
Après clic sur ce bouton :
- C’est Fiche traitée qui est visible.
Les boutons se masquent automatiquement.

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Private Sub Btn_ValiderSaisie_Click()
Dim chDos$, Dos$, Fich$
'chDos = Environ("userprofile") & "\Desktop\"
Dim Obj As Object
Set Obj = CreateObject("WScript.Shell")
chDos = Obj.SpecialFolders("Desktop") & "\"
'création dossier NouvelFiche
Dos = "NouvelFiche"
If Dir(chDos & Dos, vbSystem + vbDirectory + vbHidden) = "" Then _
MkDir chDos & Dos
chDos = chDos & Dos & "\"
Fich = Me.Range("A4").Text & " " & Me.Range("K4").Text & ".xls"
Application.DisplayAlerts = False
'copie de la fiche sous identité
ThisWorkbook.SaveCopyAs chDos & Fich
If MsgBox("Autre fiche à établir ?", vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then
If MsgBox("Souhaitez-vous que les saisies antérieures soient effacées ?", _
vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then
EffacerFiche
End If
Else
If MsgBox("Voulez-vous que le dossier de fiches validées soit compressé ?", _
vbQuestion + vbYesNo, "Compression dossier") = vbYes Then
chDos = Left(chDos, Len(chDos) - 1)
CompresserNouvelFiche chDos, chDos & ".zip"
  bureau = CreateObject("Shell.Application").Namespace(0).Self.Path  'ajouté
EffacerFiche
End If
End If
CompresserNouvelFiche chDos, chDos & ".zip"
End Sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub CompresserNouvelFiche(ByVal DSrc, ByVal DDst)
    Const ForAppending = 8
    Dim Fso As Object, shApp As Object, Fld As Object, Dzip As Object, Hx, Bx, i%
    Hx = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
    For i = 0 To UBound(Hx)
        Bx = Bx & Chr(Hx(i))
    Next i
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Dzip = Fso.CreateTextFile(DDst, True)
    Dzip.Write Bx
    Dzip.Close
    Set shApp = CreateObject("Shell.Application")
    Set Fld = shApp.Namespace(DSrc)
    If Not Fld Is Nothing Then shApp.Namespace(DDst).copyhere Fld.Items
    Set Dzip = Nothing
    On Error Resume Next
    Do While Dzip Is Nothing
        Set Dzip = Fso.OpenTextFile(DDst, ForAppending, False)
        If Err.Number <> 0 Then Err.Clear
    Loop
MsgBox "Vous pouvez expédier le dossier compressé", vbInformation
End Sub
Pour verification
https://www.developpez.net/forums/d1...sion-dossiers/

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub SupDosFi()
Dim bureau$, dossier$, zip$, fichier$
    bureau = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\"
    dossier = bureau & "NouvelFiche\"
'   zip = bureau & "NouvelFiche.zip"
'   If Dir(zip, vbArchive) <> "" Then Kill zip
    If Dir(dossier, vbDirectory) <> "" Then
      fichier = Dir(dossier & "*.*")
      Do While fichier <> ""
        Kill dossier & fichier
        fichier = Dir
      Loop
      RmDir dossier
    End If
End Sub