Discussion :

[kelom]

Bonjour tout le monde,

J'ai trouvé ce code sur internet, mais il ne marche pas
Mon but serait de créer un bouton qui me permettrai de faire une petite base de donnée.
C'est à dire, dès lors que je clique sur ce bouton :
Ma rangé ("A1:I52") s'enregistre et se créée dans une dossier souhaité et nommé automatiquement suivant une cellule (qui correspond tout simplement à ma limite de la feuille souhaitée (principe de la sélection/impression/sélection enregistrer sous...)).
Idéalement, après le clic du bouton, un dossier se créé sur un répertoire en portant le nom Clients : exemple "Cellule C5(sNomFichier)" enregistré dans (C:\Mes documents\Devis-commande-facture...\CLIENTS\(sNomFichier)... automatiquement, avec ça va de soit, ce type de principe Client yyyy-mm-dd h:m.xls .pdf
Idem pour Commande et Facture (peut être un autre sNomFichier(2) en correspondance avec la cellule C7 (qui peut être nommé Devis ou Commande ou Facture ??...) et qui s'enregistre en fonction de ce qui apparaît en Objet exemple C7 = Client ; Puis C7 = Commande et enfin C7=Facture (c'est moi qui designerai manuellement si devis, commande facture...) et qui aura cette forme (C:\Mes documents\sNomFichier(2)C7(cellule correspondante)\CLIENTS\(sNomFichier)(nom du client en C5)... automatiquement
Cette macro m'enregistre cette sélection A1:I52 sous .xls avec copie en .pdf
Dès fin de cette première manipulation, une fenêtre Thunderbird s'ouvre afin d'envoyer le .PDF qui se retrouve en PJ pour un envoi via mail en fonction d'une cellule pour destinataire (ex. F5 : adresse mail du client).

Je sais que c'est à peu tordu mais ce petit programme serait idéal pour moi et étant donné que je n'ai aucune formation et très peu de connaissance en VBA, ceci est assez compliqué...

Voila une partie du rendu que j'aimerai que nous développions ensemble.

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Private Sub CommandButton1_Click()

Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim SCheminFichier As String
Dim sNomPDF As String
Dim sCheminPDF As String
    ChDrive "C:\Mon dossier\"
    If Len(Dir("C:\Mon dossier\" & Range("E6"), vbDirectory)) = 0 Then 'exemple en E6...
    MkDir "C:\mondossier\" & Range("E6")
    End If
    SCheminFichier = "C:\Mon dossier\" & Range("E6")
    SNomFichier = SCheminFichier & "\" & Range("E5") & " " & Format(Now, "dd-mm-yyyy hh-mm") & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier

    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = "C:\mondossier\" & Range("E6")
   
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sCheminPDF & "\" & sNomPDF, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False

    Dim cell As Range
    Dim strto As String
    On Error Resume Next
    For Each cell In ThisWorkbook.Sheets("Sheet1") _
        .Range("K5").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    On Error GoTo 0
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
    
     Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1 
        Set Flds = iConf.Fields
            With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.monfai.fr"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With

    Set CdoMessage = New CDO.Message
    With CdoMessage
        .Subject = "monsujet "
        .From = "mon@adressemail.fr"
        .To = strto
        .CC = ""
        .BCC = ""
        .TextBody = "Bonjour, Veuillez trouver ci-joint la Feuille du " & Day(Date) & "." & Month(Date) & "." & Year(Date) & " a " & Hour(Time) & "H" & Minute(Time)
        .AddAttachment sCheminPDF & "\" & sNomPDF
        .Send
    End With

    Set CdoMessage = Nothing

End Sub



Je vous en remercie très fortement pour mon problème

[El_Titof]

Bonjour,

Et tu bloques où?

++

[kelom]

Bonjour El_Titof,

Merci de prêter une attention à ma question

Et comme je'ai noté sur mon intro, je cherche à essayer de comprendre le fonctionnement de VBA car je suis une bulle dans ce domaine.

Donc, je bloque à peu partout, c'est à dire que le code actuel enregistre bien en .xls dans le dossier qui se créé automatiquement sans écraser les autres portant le même nom.
Mais dès qu'il atteint le niveau .pdf, celui se bloque et stop la continuité de la macro

Mais également, j'aurais voulu l’enregistrer en fonction de son objet (devis, commande, facture), c'est à dire, que dès lors que c'est un devis, il s'enregistre dans le dossier devis.
Dès qu'il passera en commande, je le récupère du dossier, j'ouvre le .xls et je change l'objet qui lui aussi, une fois cliqué, s'enregistre dans le dossier Commande automatiquement...

L'objet sera énoncé en Cellule C7

Et c'est là que je bute complètement

Encore merci pour vos réponses et vos aides ou idées me permettant d'évoluer

[El_Titof]

Bonjour,

Voici une correction possible pour ton code:

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Private Sub CommandButton1_Click()
 
    Dim CdoMessage As CDO.Message
    Dim SNomFichier As String
    Dim SCheminFichier As String
    Dim sNomPDF As String
    Dim sCheminPDF As String
    Dim sRepertoire As String
 
    sRepertoire = "C:\MonEntreprise\"
    If Len(Dir(sRepertoire, vbDirectory)) = 0 Then _
        MkDir sRepertoire
    ChDrive sRepertoire
 
    If Len(Dir(sRepertoire & Range("E6"), vbDirectory)) = 0 Then 'exemple en E6...
    MkDir sRepertoire & Range("E6")
    End If
    SCheminFichier = sRepertoire & Range("E6")
    SNomFichier = SCheminFichier & "\" & Range("E5") & " " & Format(Now, "dd-mm-yyyy hh-mm") & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier
 
    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = sRepertoire & Range("E6")
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sCheminPDF & "\" & sNomPDF, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
 
    Dim cell As Range
    Dim strto As String
    On Error Resume Next
 
    For Each cell In ThisWorkbook.Sheets(1).Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    On Error GoTo 0
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
 
     Set iConf = CreateObject("CDO.Configuration")
 
    iConf.Load -1
        Set Flds = iConf.Fields
            With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.monfai.fr"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With
 
    Set CdoMessage = New CDO.Message
    With CdoMessage
        Set .Configuration = iConf
        .Subject = "monsujet"
        .From = "mon@adressemail.fr"
        .To = strto
        .CC = ""
        .BCC = ""
        .TextBody = "Bonjour, Veuillez trouver ci-joint la Feuille du " & Day(Date) & "." & Month(Date) & "." & Year(Date) & " a " & Hour(Time) & "H" & Minute(Time)
        .AddAttachment sCheminPDF & "\" & sNomPDF
        .Send
    End With
 
    Set CdoMessage = Nothing
 
End Sub

Bonne journée

El_Titof