Photo dans pdf
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
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
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
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
Ça me semble parfait
Merci beaucoup et bonne journée