Import export d'image
Bonjour à tous
C'est la toute première fois que je pose une question sur un forum
Je suis embêter, car je réalise un document Excel pour mon apprentissage et je suis bloqué a la dernière étape, j'ai deux points à éclaircir.
Je souhaite faire un document ou les commerciaux de mon entreprise puise remplir la description du matériel, jusque-là je ne m'en suis pas trop mal sorti. Mais pour finir le document, je dois faire en sorte que les commerciaux puise déposer leurs photos sur le document excel, et que le responsable puise les télécharger sur son Pc.
- Arrive le premier hic : Actuellement ma macro sélectionne une photo en ouvrant la fenêtre parcourir et les commerciaux choisissent l'image qu'il souhaite, le problème est que ce n'est qu'un lien est que dès lors que l'on envoie le document par mail, il s'affiche un message d'erreur à la place de l'image (je souhaiterais donc que l'image soit dans le document Excel est que ce ne soit pas uniquement un lien).
- Ensuite, mon deuxième problème intervient lors de l'export de l'image déposée auparavant avec la macro précédente. La fenêtre "enregistrée sous" s'ouvre, mais l'image ne s'enregistre pas
J’espère que j'ai bien expliquer mon problème, si oui, Y a t'il quelqu'un peu m'aider s'il vous plaît ?
Merci d'avance.
PS Je mets le document en fichier joint.
Bonjour,
Je n'ouvre pas par défaut les pièces jointes quand je peux aider sans !
Tu peux utiliser un contrôle ImageList et un contrôle Image, le contrôle ImageList contient l'image (de cette façon, elle suivra le classeur) qui va être chargée dan le contrôle Image.
Pour ajouter par code (tu peux le faire manuellement à la création du contrôle ImageList) une image, voici un code, une boite s'ouvre pour choisir l'image sur le disque :
Sub ChargerImageDansListe()
Dim Fichier As String
Me.ImageList1.ListImages.Clear
'ajoute l'image choisie à la liste d'image...
With Application.FileDialog(3)
If .Show <> -1 Then Exit Sub
Fichier = .SelectedItems(1)
End With
Me.ImageList1.ListImages.Add , "Photo1", LoadPicture(Fichier)
End Sub
Là, le code pour affecter l'image au contrôle Image :
Sub InstallerImage()
'installe l'image dans le contrôle...
Image1.Picture = ImageList1.ListImages(1).Picture
End Sub
et ici, le code pour exporter l'image (l'enregistrer sur le disque) :
Sub Exporter()
Dim Chemin As String
Dim NomPhoto As String
'exporte l'image contenue dans la liste d'image sur le disque...
With Application.FileDialog(4)
If .Show <> -1 Then Exit Sub
Chemin = .SelectedItems(1)
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
End With
NomPhoto = "Photo.jpg"
SavePicture ImageList1.ListImages(1).Picture, Chemin & NomPhoto
End Sub
Bonjour merci pour votre implication
Voici mes deux macro, vue que vous ne pouvez pas ouvrir la pièce jointe
Les macro que vous me proposez ne peuvent aller chercher qu'une photo ? elle n'ouvre pas la fenêtre parcourir ?
Sub INSERTION_PHOTO_MATERIEL_1()
'DEPROTECTION
ActiveSheet.Unprotect ""
'SUPPRIMER LA DERNIERE PHOTO CREE
If Range("BE6") <> "" Then
PHOTO1 = Range("BE6").Value
ActiveSheet.Shapes(PHOTO1).Delete
End If
'SELECTIONER LES CELLULES FUSIONNEES
Range("BF6:CB16").Select 'emplacement des cellules fusionnées ou la photo sera affiché
Ad = Selection.Address
CellH = Selection.Height
CellW = Selection.Width
'EXTRACTION DE L'IMAGE
On Error Resume Next
Application.ScreenUpdating = False
IMPORTATION = Application.GetOpenFilename("Toutes les images (*.jpg;*.bmp;*.tiff;*.tif;*.gif;*.jpeg;*.png;*.jpe;*.jfif),*.jpg;*.bmp;*.tif;*.tiff;*.gif;*.jpeg;*.png;*.jpe;*.jfif", , "Choisissez l'image") ' choix nom du fichier
If IMPORTATION = "Faux" Then
MsgBox "Operation annulée" & vbCrLf & "Attention, veuillez renouveler l'action !", vbExclamation
'SUPRESSION DU NOM DE L'IMAGE PRECEDENTE
Range("BE6").Select
Selection.ClearContents
'SELECTIONER UNE CELLULE
[BF17].Select
'PROTECTION
ActiveSheet.Protect "lesage"
Exit Sub
End If
ActiveSheet.Pictures.Insert(IMPORTATION).Select ' insertion
With Selection.ShapeRange
MemW = .Width: MemH = .Height
'adapte les ratio
If MemH < CellH And MemW < CellW Then
'l'image < cellule
RatioHz = MemH / CellH
RatioVt = MemW / CellW
If RatioVt < RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (CellW / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW > CellW Then
'l'image > cellule
RatioHz = CellH / MemH
RatioVt = CellW / MemW
If RatioVt > RatioHz Then 'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
End If
ElseIf MemH > CellH And MemW < CellW Then
'adapter en hauteur
HT = CellH: Lg = MemW * (HT / MemH)
T = 0: L = (CellW - Lg) / 2
ElseIf MemH < CellH And MemW > CellW Then
'adapter en largeur
Lg = CellW: HT = MemH * (Lg / MemW)
L = 0: T = (CellH - HT) / 2
Else
Stop ' pas prévu ?
End If
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = Range(Ad).Top + T ' haut de la cellule
.Left = Range(Ad).Left + L ' gauche de la cellule
.Height = HT
.Width = Lg ' largeur des cellules fusionnées
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
'ENREGISTRER LE NOM DE L'IMAGE DANS LA CELLULE A GAUCHE
PHOTO2 = Selection.ShapeRange.Name
Range("BE6").Value = PHOTO2
'SELECTIONER UNE CELLULE
[BF17].Select
'PROTECTION
'ActiveSheet.Protect ""
End Sub
Sub g()
Nom = ActiveWorkbook.ActiveSheet.Name & Range("O12").Value & Range("X6").Value
'DEPROTECTION
ActiveSheet.Unprotect ""
If Range("BE6") <> "" Then
PHOTO = Range("BE6").Value
ActiveSheet.Shapes(PHOTO).Select
Else
MsgBox "Opération impossible." & vbCrLf & "Aucune image trouvée." & vbCrLf & "Si vous pensez que l'opération aurai du aboutir, envoyer moi un mail via la page d'accueil.", vbExclamation
ActiveSheet.Protect "lesage"
Range("BE6").Select
Exit Sub
End If
Export = Application.GetSaveAsFilename(Nom)
If Export = "Faux" Then '"Faux"
MsgBox "Operation annulée" & vbCrLf & "Attention, veuillez renouveler l'action !", vbExclamation
Else
Activeshats.Export ("C:\Users\Flavien\OneDrive\FLC Lesage\1 Compte rendue des reunions\4 Reunion - Modification de document\1 Modification des documents\2 Fiche expertise")
End If
End Sub
J'ai trouvé comment faire, juste désormais le nom de la photo est image xx, alors que lorsque je demande par macro de noté le nom de l'image dans la casse il me dit picture xx
'SELECTIONER LES CELLULES FUSIONNEES
Range("BF6:CB16").Select 'emplacement des cellules fusionnées ou la photo sera affiché
With Selection
Picture_W = .Width
Picture_H = .Height
Picture_L = .Left
Picture_T = .Top
End With
'EXTRACTION DE L'IMAGE
IMPORTATION = Application.GetOpenFilename("Toutes les images (*.jpg;*.bmp;*.tiff;*.tif;*.gif;*.jpeg;*.png;*.jpe;*.jfif),*.jpg;*.bmp;*.tif;*.tiff;*.gif;*.jpeg;*.png;*.jpe;*.jfif", , "Choisissez l'image") ' choix nom du fichier
If IMPORTATION = "Faux" Then
MsgBox "Operation annulée" & vbCrLf & "Attention, veuillez renouveler l'action !", vbExclamation
'SUPRESSION DU NOM DE L'IMAGE PRECEDENTE
Range("BE6").Select
Selection.ClearContents
'SELECTIONER UNE CELLULE
[BF17].Select
'PROTECTION
ActiveSheet.Protect ""
Exit Sub
End If
'ENREGISTREMENT DE L'IMAGE DANS LE DOCUMENT
Set pict = LoadPicture(IMPORTATION)
Set IMG = ActiveSheet.Shapes.AddPicture(IMPORTATION, False, True, Picture_L, Picture_T, Picture_W, Picture_H) 'on l'insere une deuxieme fois pour l'enregistrer dans le document
IMG.Select
'PHOTO2 = IMG.Name
'ENREGISTRER LE NOM DE L'IMAGE DANS LA CELLULE A GAUCHE
PHOTO2 = Selection.ShapeRange.Name
Range("BE6").Value = PHOTO2