Discussion :

[jean30]

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

[EricDgn]

Bonjour,

Quelques observations qui pourraient éventuellement vous mettre sur la piste.

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
32
33
34
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
   '--- ? bonne structure if - else - end if
   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
         '--- bureau ? pourquoi pas aussi ici
         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"     '### A: ici \ retiré
         '--- bureau ?
         bureau = CreateObject("Shell.Application").Namespace(0).Self.Path  'ajouté
         EffacerFiche
      End If
   End If
   '### 2e CompresserNouvelFiche si accepté en A ?!
   CompresserNouvelFiche chDos, chDos & ".zip"           '### B: ici \ en fin
End Sub

Cordialement.

[jean30]

Bonjour Eric et merci à toi

Les codes ont été effectués par un ami hospitalisé.
Ne connaissant que très peu le Vba je ne sais comment modifier pour :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

   If MsgBox("Autre fiche à établir ?", vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then

Jusque là c’est correct.

Au Msgbox Si réponse Yes :
Retour sur la fiche pour une nouvelle saisie (il peut y en avoir 5 au maximum) et se retrouver toutes dans le dossier "NouvelFiche" se trouvant sur le bureau (écran).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
If MsgBox("Souhaitez-vous que les saisies antérieures soient effacées ?", _
                vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then

En te remerciant
Au Msgbox Si réponse No :
Compression du dossier "NouvelFiche" et de son contenu sur le bureau (écran).
Suppression du dossier "NouvelFiche" non compressé.

[EricDgn]

Bonjour,

Ce n'est toujours pas très clair pour moi, mais voici ce que je propose.

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
32
33
34
35
36
37
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 sur le bureau de la fiche sous identité
   ThisWorkbook.SaveCopyAs chDos & Fich
   '---
   If MsgBox("Autre fiche à établir ?", vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then
      '--- Yes: une autre fiche est à établir
      If MsgBox("Souhaitez-vous que les saisies antérieures soient effacées ?", _
                vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then
         '--- Yes: une autre fiche est à établir, supprimer les saisies antérieures = remplacer fiche antérieure par une autre
         EffacerFiche
      Else
         '--- No: une autre fiche est à établir, continuer
      End If
   Else
      '--- No: pas d'autre fiche à établir
      If MsgBox("Voulez-vous que le dossier de fiches validées soit compressé ?", _
                vbQuestion + vbYesNo, "Compression dossier") = vbYes Then
         '--- Yes: pas d'autre fiche à établir, compresser dossier puis effacer fiche
         chDos = Left(chDos, Len(chDos) - 1)
         CompresserNouvelFiche chDos, chDos & ".zip"
         EffacerFiche
      Else
         '--- No: pas d'autre fiche à établir, ne rien faire = continuer
      End If
   End If
End Sub

Cordialement.

[jean30]

Bonjour Éric

Je te remercie chaleureusement pour ton travail et ta patience envers moi, mais une dernière demande :
Il faudrait juste que le dossier non compressé "NouvelFiche" créé au début soit supprimé après la création du zip

En te souhaitant une bonne journée

[EricDgn]

Bonjour,

Vérifier si ceci convient, que cela n'efface pas aussi le fichier zip qui vient d'être créé.

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
32
33
34
35
36
37
38
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 sur le bureau de la fiche sous identité
   ThisWorkbook.SaveCopyAs chDos & Fich
   '---
   If MsgBox("Autre fiche à établir ?", vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then
      '--- Yes: une autre fiche est à établir
      If MsgBox("Souhaitez-vous que les saisies antérieures soient effacées ?", _
                vbQuestion + vbYesNo, "Saisie fiche") = vbYes Then
         '--- Yes: une autre fiche est à établir, supprimer les saisies antérieures = remplacer fiche antérieure par une autre
         EffacerFiche
      Else
         '--- No: une autre fiche est à établir, continuer
      End If
   Else
      '--- No: pas d'autre fiche à établir
      If MsgBox("Voulez-vous que le dossier de fiches validées soit compressé ?", _
                vbQuestion + vbYesNo, "Compression dossier") = vbYes Then
         '--- Yes: pas d'autre fiche à établir, compresser dossier puis effacer fiche
         chDos = Left(chDos, Len(chDos) - 1)
         CompresserNouvelFiche chDos, chDos & ".zip"
         EffacerFiche
         RmDir Left(chDos, Len(chDos) - 1)      '<<< supprime le dossier NouvelFiche
      Else
         '--- No: pas d'autre fiche à établir, ne rien faire = continuer
      End If
   End If
End Sub

Cordialement

[jean30]

Bonjour Eric
Merci pour le code communiqué, il y a problème pas facile à explique c'est pour quoi je met le fichier
Vois uniquement sur Valider Saisie
En te remerciant
https://www.cjoint.com/c/ICDmG7GgRr6

[EricDgn]

Bonjour,

Voilà, je suppose que c'est cela que vous cherchez à faire.
Je ne me suis pas occupé des 2 autres boutons.

Bonne continuation.

[jean30]

Bonjour Eric,
Tout mon cœur pour te remercier car sans toi je n'y serai pas parvenu
En plus tu as très compris mon désir
Je te souhaite le meilleur
Jean