vérification et modification codes

Version imprimable

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:

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:

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:

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

Bonjour,

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

Code:

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.

28/03/2019, 08h04
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:

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:

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é.

Bonjour,

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

Code:

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.

29/03/2019, 07h51
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

Bonjour,

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

Code:

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

29/03/2019, 13h35
jean30

1 pièce(s) jointe(s)

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
30/03/2019, 10h57
EricDgn

1 pièce(s) jointe(s)

Bonjour,

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

Bonne continuation.
30/03/2019, 13h26
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