Photo dans pdf

Le 13/03/2018 à 09:10

Bonjour

Dans le fichier joint, je souhaiterai, lorsqu'au clic sur le bouton du formulaire, insérer dans le pdf (issu de la feuille "Fiche Indiv") la photo dont le chemin est appelé pour mémoire dans la textbox4

Dans l'idéal, il serait souhaitable que la photo s'adapte à la taille de la cellule E3 …

Au cas, où je me suis mal fait comprendre, ce n'est pas dans le classeur excel que je souhaite afficher la photo, mais dans le pdf ! Sinon, après plusieurs dizaines d'appels de photos différentes , le fichier s'alourdirai considérablement (il me semble en tout cas).

Merci d'avance

30ficheindiv-amp-photo.xlsm (26.40 Ko)
Le 13/03/2018 à 10:58

Bonjour Boby63

Je n'ai pas effectuer les tests mais voici ton code modifié pour le formulaire.

Private Sub CommandButton1_Click()
Dim nom As String
Dim Nom_Image As String
Dim Repertoire_Photo
With Sheets(3)
    .Cells(3, 2) = Me.ComboBox1
    .Cells(4, 2) = Me.TextBox1
    .Cells(5, 2) = Me.TextBox2
    .Cells(15, 2) = Me.TextBox3

Repertoire_Photo = "\\ReseauInterne\Inventairemat\Photos\" ' Chemin de l'image"
Nom_Image = TextBox4.Value
Set c = .Range("E3").MergeArea
.Pictures.Insert(répertoirePhosto & nom & ".jpg").Name = nom
.Shapes(nom).Left = c.Left
.Shapes(nom).Top = c.Top
.Shapes(nom).LockAspectRatio = msoFalse
.Shapes(nom).Height = c.Height
.Shapes(nom).Width = c.Width

End With

On Error GoTo errorHandler
Sheets(3).Select
nom = ActiveSheet.Name
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nom _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
Unload Me
Sheets(1).Select
Exit Sub

errorHandler:
MsgBox ("Fichier " & nom & ".pdf déjà ouvert ! Veuillez le fermer avant de tenter d'en générer un autre de nouveau")
Unload Me
Sheets(1).Select
End Sub

Private Sub UserForm_Initialize()

With Sheets(1)
    Set PlageMatos = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With
ComboBox1.List = PlageMatos.Value

End Sub

Private Sub ComboBox1_Change()
'RechV des infos liées au choix fait
Lignerecherch = Sheets(1).[A:A].Find(ComboBox1, lookat:=xlWhole).Row
For i = 1 To 4
    Me.Controls("TextBox" & i) = Sheets(1).Cells(Lignerecherch, i + 1)
Next i

End Sub
Le 13/03/2018 à 12:11

Tout d'abord merci et1000lio

Aucune image n'est visiblement chargée (ni dans la feuille, ni dans le pdf) lorsque je lance l'export.

Du coup, j'essaie de bidouiller ton code pour voir ce qui cloche et, en testant, j'ai modifié la ligne

.Shapes(nom).LockAspectRatio = msoFalse

par

.Shapes(nom).LockAspectRatio = msoTrue

Et là, la photo s'affiche !!! Pas à la bonne taille du coup bien sûr, donc c'est un problème d'affichage ....

Donc le reste du code fonctionne très bien. Merci encore. Je continue à gratter de mon côté, mais si tu as la solution, suis preneur.

Merci

Le 13/03/2018 à 12:30

J'ai testé et modifié le code.... et il fonctionne sauf pour la mise hauteur automatique par rapport à la cellule.

Par contre pas de mention .jpg dans la colonne E de l'onglet BD

Private Sub CommandButton1_Click()
Dim nom As String
Dim Nom_Image
Dim Repertoire_Photo
With Sheets(3)
    .Cells(3, 2) = Me.ComboBox1
    .Cells(4, 2) = Me.TextBox1
    .Cells(5, 2) = Me.TextBox2
    .Cells(15, 2) = Me.TextBox3

Repertoire_Photo = "\\ReseauInterne\Inventairemat\Photos\" ' Chemin de l'image"
Nom_Image = TextBox4.Value 'Donne le nom du shapes (Image) à insérer
Set c = .Range("E3").MergeArea

.Pictures.Insert(Repertoire_Photo & Nom_Image & ".jpg").Name = Nom_Image 'Insère l'image dans le shapes
.Shapes(Nom_Image).Left = c.Left
.Shapes(Nom_Image).Top = c.Top
.Shapes(Nom_Image).Height = c.Height
.Shapes(Nom_Image).Width = c.Width

End With

On Error GoTo errorHandler
Sheets(3).Select
nom = ActiveSheet.Name
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nom _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
Unload Me
Sheets(1).Select
Exit Sub

errorHandler:
MsgBox ("Fichier " & nom & ".pdf déjà ouvert ! Veuillez le fermer avant de tenter d'en générer un autre de nouveau")
Unload Me
Sheets(1).Select
End Sub

Private Sub UserForm_Initialize()

With Sheets(1)
    Set PlageMatos = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With
ComboBox1.List = PlageMatos.Value

End Sub

Private Sub ComboBox1_Change()
'RechV des infos liées au choix fait
Lignerecherch = Sheets(1).[A:A].Find(ComboBox1, lookat:=xlWhole).Row
For i = 1 To 4
    Me.Controls("TextBox" & i) = Sheets(1).Cells(Lignerecherch, i + 1)
Next i

End Sub
Le 13/03/2018 à 14:23

Ça me semble parfait

Merci beaucoup et bonne journée

Rechercher des sujets similaires à "photo pdf"