Microsoft 365 Créer un PDF avec input box pour donner un nom

[Mathisgodu]

Bonjour à tous,

Je rencontre un problème dans mon code, je peux exporter en pdf seulement quand j'ai rajouté Inputbox pour donner un nom. Le fichier ne s'exporte plus et n'apparaît pas dans le ficheir de desttination.

Voici le code :

Dim Aller As String
Dim Donnerunnom As Variant


Donnerunnom = InputBox("Donner le nom au fichier sélectionné") & Chr(13)
If Donnerunnom = "" Then Exit Sub

Aller = "C:\Users\mathis.godu\Documents\PDF chantier\FIC" & "\" & Donnerunnom & Format(Now, "yyyy_mm_dd_")

Workbooks(Workbooks.Count).ExportAsFixedFormat Type:=xlTypePDF, Filename:=Aller, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, OpenAfterPublish:=False

Si quelqu'un peut m'éclaircir sur le soucis dans mon code je suis preneur !

Bonne journée et merci d'avance

Cordialement,

Mathis GODU

 

[patricktoulon]

bonjour
et pourquoi non de dieu n'utiliserais tu pas le dialog getsaveasfilename ???????
tiens ma petite fonction perso (réutilisable a souhait )
si c'est pour la date a la fin c'est pas un problème on fait simplement un replace
tu a juste le nom a taper et la date se mettra toute seule
normalement le dialog s'ouvre sur ton dossier en question (si ce dossier existe sinon c'est les documents )
debloque ta ligne

Sub test()
Dim chemin As Variant
chemin = enregistrer_sous2("pdf", "C:\Users\mathis.godu\Documents\PDF chantier\FIC")
If chemin <> False Then
 chemin = Replace(chemin, "pdf", Format(Date, "yyyy_mm_dd_"".pdf"""))
 MsgBox chemin
 'Workbooks(Workbooks.Count).ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, OpenAfterPublish:=False
End If
End Sub
Function enregistrer_sous2(Ext, dossier) As Variant
    Dim fname As String
    enregistrer_sous2 = Application.GetSaveAsFilename(InitialFileName:=dossier, filefilter:="PDF Files (*." & Ext & "), *." & Ext, Title:="ENREGISTREMENT EN PDF")
End Function

 

[Mathisgodu]

Bonjour,

Merci patricktoulon pour ton aide, je n'ai pas totalement compris le code (Oui j'aime bien comprendre ce que je fais ^^').
Je ne vois pas trop l'utilité du If puisque dans tous les cas mon document devra avoir un nom, je l'aurai plutôt vu de la manière suivant

Je ne vois pas trop l'utilité du If puisque dans tous les cas mon document devra avoir un nom, je l'aurai plutôt vu de la manière suivant If 'J'ai donné un nom' on l'enregistre Else 'Merci de donner un nom au fichier'

N'y a-t-il pas moyen de donner la date d'une autre facon qu'un If Else avec la fonction replace ?
De plus, je ne comprend pas pourquoi on sort du sub pour ensuite réutiliser une fonction.

Merci !

Mathis GODU

 

[patricktoulon]

re
ben toi tu vois pas trop, moi je vois très bien
c'est au cas ou tu clique annuler de même qu'avec un imput box d'ailleurs
bloque le if et débloque ta ligne et laisse le msgbox et annule tu verra quel nom il va porter ton fichier
c'est le B a B a si oui faire et tu peux ajouter si non ne pas faire

le fait de sortir de la sub c'est par ce que c'est une fonction perso que tu peux réutiliser pour autre chose
et pour info on sort pas de la sub on appelle une fonction ouvrant un dialog
c'est la différence entre sub et function

maintenant si ça te convient pas reste avec ton imputbox ,je vais pas m'éterniser sur un exercice aussi simple

 

[Mathisgodu]

Je te remercie pour tes conseil, je ne cherchais en aucun cas à remettre en cause ton expérience mais justement m'en servir afin de comprendre ce que je fais pour aller plus loin dans l'apprentissage et la maîtrise de VBA (En effet, je suis étudiant alternant et je ne maîtrise pas du tout le code de base donc j'essaie d'apprendre sur le tas ). Mais merci pour ton aide précieuse !

 

[patricktoulon]

j'explique
dans une sub tu peux faire

sub test
 x=10
end sub

maintenant il arrive que le "10" doit etre calculé et cela plusieurs fois et donnant un résultat différent
par exemple avec plusieurs valeurs venant de diverses sources
exemple ici avec des cellules
ben tu va faire

sub test()
 dim x&
x = mafonctionperso( [A1],[G8])
 msgbox x
end sub

function mafonctionperso( cell1 as range ,cell2 as range )
mafonctionperso=val(cell1.value)+val(cell2.value)
end function

je te l'accorde c'est un exemple un peu simpliste mais l'idée c'est ça
la fonction renvoie une valeur (c'est pour ça qu'elle existe) sinon il n'y aurait que des SUB

et l'avantage d'une fonction c'est quelle est pluripotente de part ces arguments que tu lui injecte
si j'envoie de la sub x = mafonctionperso( [d3],J15] )j'aurais le résultat de ces cellule sans changer le code de la fonction

t' a pigé le truc ??

 

[Mathisgodu]

Je te remercie, je comprend mieux l'utilité des fonctions. Seul soucis maintenant (Désole de te prendre autant de temps), j'ai un sub avant donc j'ai essayé de fusionner celui d'avant avec le tient, le fichier à l'air enregistré mais quand je vais voir dans le dossier il n'y a rien ("Le document a été supprimé récemment....").

Sub ajouterFIC()

'Recherche de la Photo

Dim Retour As Variant
Dim Fichier As String
Dim Destination As String

Retour = Application.GetOpenFilename("All Files (*.*),*.*", Title:="Sélection du fichier", MultiSelect:=False)

    If Retour <> False Then

Fichier = Retour

Je te joins le fichier, cela sera peut être plus simple à comprendre...

ActiveCell.Value = Fichier


    Else

    End If
  
For Each xcell In Selection
    ActiveSheet.Hyperlinks.Add Anchor:=xcell, Address:=xcell.Formula
    Next xcell
  
'Ouvrir nouveau classeur

Workbooks.Add

'Insérer la photo

    Dim Emplacement As Range
    Dim Img As Object
    Dim ShapeObj As Shape
 
    'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Cible" Then ActiveSheet.Shapes("Cible").Delete
    Next ShapeObj
 
    If Application.Dialogs(xlDialogInsertPicture).Show Then
        'Définit l'emplacement de l'image
        Set Emplacement = Range("D3:E8")
 
        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
        With Img.ShapeRange
            'Nommer l'image insérée (Pour la supprimer plus facilement ensuite)
            .Name = "Cible"
            .LockAspectRatio = msoFalse
            .Left = Emplacement.Left
            .Top = Emplacement.Top
            .Height = Emplacement.Height
            .Width = Emplacement.Width
        End With
 
    Else
        MsgBox "Insertion d'image interrompue."
    End If
  
'Enregistrer le nouveau classeur en PDF

On Error GoTo 1 'Gestion des erreurs

Application.DisplayAlerts = False 'Gestion des messages d'alerte

'Enregistrer au format PDF

Dim chemin As Variant
chemin = enregistrer_sous2("pdf", "C:\Users\mathis.godu\Documents\PDF chantier\FIC")
If chemin <> False Then
 chemin = Replace(chemin, "pdf", Format(Date, "yyyy_mm_dd_"".pdf"""))
 MsgBox chemin
 'Workbooks(Workbooks.Count).ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, OpenAfterPublish:=False
End If

1
'Fermer le classeur actif sans enregistrer

ActiveWorkbook.Close

Savechanges = False

End Sub
Function enregistrer_sous2(Ext, dossier) As Variant
    Dim fname As String
    enregistrer_sous2 = Application.GetSaveAsFilename(InitialFileName:=dossier, filefilter:="PDF Files (*." & Ext & "), *." & Ext, Title:="ENREGISTREMENT EN PDF")
End Function

 

[patricktoulon]

re
débloque les deux dernière ligne de la sub

Sub ajouterFIC()
'Recherche de la Photo
    Dim Retour As Variant, Fichier$, Classeur As Workbook
    Retour = Application.GetOpenFilename("All Files (*.*),*.*", Title:="Sélection du fichier", MultiSelect:=False)

    If Retour <> False Then
        Fichier = Retour
        ActiveCell.Value = Fichier
    Else
        '...
    End If

    For Each xcell In Selection
        ActiveSheet.Hyperlinks.Add Anchor:=xcell, Address:=xcell.Formula
    Next xcell

    Set Classeur = Workbooks.Add   'Ouvrir nouveau classeur

    'Insérer la photo
    Dim rng As Range, fichierimage As Variant

    'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Cible" Then ShapeObj.Delete
    Next ShapeObj

    fichierimage = Application.GetOpenFilename(FileFilter:=" Images Files ( *.jpeg;*.jpg;*.png;*.gif), ( *.jpeg;*.jpg;*.png;*.gif), All Files, *.*", FilterIndex:=1)
    If fichierimage <> False Then
        Set rng = Range("D3:E8")    'Définit l'emplacement de l'image
        With ActiveSheet.Shapes.AddPicture(fichierimage, False, True, 0, 0, 0, 0)
            .Name = "cible"
            .LockAspectRatio = False
            .Left = rng.Left
            .Top = rng.Top
            .Width = rng.Width
            .Height = rng.Height
        End With
    Else
        MsgBox "Insertion d'image interrompue."
    End If

    'Enregistrer le nouveau classeur en PDF

    Application.DisplayAlerts = False    'Gestion des messages d'alerte
    'Enregistrer au format PDF
    Dim chemin As Variant
    chemin = enregistrer_sous2("pdf", "C:\Users\mathis.godu\Documents\PDF chantier\FIC")
    If chemin <> False Then
        chemin = Replace(chemin, ".pdf", Format(Date, "yyyy_mm_dd_"".pdf"""))
        MsgBox chemin
        'Classeur.ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, OpenAfterPublish:=False
        ' classeur.close
    End If
End Sub

Function enregistrer_sous2(Ext, dossier) As String
    Dim fname As Variant
    enregistrer_sous2 = Application.GetSaveAsFilename(InitialFileName:=dossier, FileFilter:="PDF Files (*." & Ext & "), *." & Ext, Title:="ENREGISTREMENT EN PDF")
End Function

@+ là je part jusqu’ à 16 heures

 

[Mathisgodu]

Je te remercie ! Cela fonctionne parfaitement et en plus de cela, je repars avec de nouvelles connaissances en VBA, emrci beaucoup !

 

[patricktoulon]

re
bon ben voilà çà ....c'est fait
ravi pour toi