Image importer via VBA n'est qu'un lien
F
Bonjour je suis en train de réaliser une macro qui devrait me permet d’insérer une image dans mon document excel.
Met lorsque j'insère l'image est que j'envoie mon fichier excel le destinataire ne peuvent plus avoir accès au image.
Donc pour que l'image reste même lors d'un envoi par mail j'ai lu que je devait utiliser add.picture, j'insere donc ma photo avec shapes.Inser Pour avoir les dimension je la supprime et la réinsére une deuxième fois avec l'autre fonction
Voici mes code Pouvez vous m'aider svp ?
Sub INSERTION_PHOTO_MATERIEL_1()
'DEPROTECTION
ActiveSheet.Unprotect "xxxx"
'SUPPRIMER LA DERNIERE PHOTO CREE
If Range("BE6") <> "" Then
PHOTO1 = Range("BE6").Value
ActiveSheet.Shape(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
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
Picture_W = .Width
Picture_H = .Height
Picture_L = .Left
Picture_T = .Top 'Sauvergarde les ratios
PHOTO2 = .Name
End With
'ENREGISTRER LE NOM DE L'IMAGE
'ENREGISTREMENT DE L'IMAGE DANS LE DOCUMENT
Shape.AddPicture (IMPORTATION), False, True, Picture_L, Picture_T, Picture_W, Picture_H
'REDIMENSIONNEMENT DE L'IMAGE AU CELLULE
With Selection.ShapeRange
If Picture_H < CellH And Picture_W < CellW Then
'l'image < cellule
RatioHz = Picture_H / CellH
RatioVt = Picture_W / CellW
If RatioVt < RatioHz Then 'adapter en hauteur
HT = CellH: Lg = Picture_W * (HT / Picture_H)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = Picture_H * (CellW / Picture_W)
L = 0: T = (CellH - HT) / 2
End If
ElseIf Picture_H > CellH And Picture_W > CellW Then
'l'image > cellule
RatioHz = CellH / Picture_H
RatioVt = CellW / Picture_W
If RatioVt > RatioHz Then 'adapter en hauteur
HT = CellH: Lg = Picture_W * (HT / Picture_H)
T = 0: L = (CellW - Lg) / 2
Else 'adapter en largeur
Lg = CellW: HT = Picture_H * (Lg / Picture_W)
L = 0: T = (CellH - HT) / 2
End If
ElseIf Picture_H > CellH And Picture_W < CellW Then
'adapter en hauteur
HT = CellH: Lg = Picture_W * (HT / Picture_H)
T = 0: L = (CellW - Lg) / 2
ElseIf Picture_H < CellH And Picture_W > CellW Then
'adapter en largeur
Lg = CellW: HT = Picture_H * (Lg / Picture_W)
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
PHOTO3 = Selection.ShapeRange.Name
Range("BE6").Value = PHOTO3
'SUPRESSION DE LA PHOTO 2
ActiveSheet.Shapes(PHOTO2).Delete
'SELECTIONER UNE CELLULE
[BF17].Select
'PROTECTION
'ActiveSheet.Protect "xxxx"
End Sub
F
Résolu
Sub INSERTION_PHOTO_MATERIEL_1()
'DEPROTECTION
ActiveSheet.Unprotect "lesage"
'SUPPRIMER LA DERNIERE PHOTO CREE
If Range("BE6") <> "" Then
PHOTO = Range("BE6").Value
'MESSAGE D'AVERTISSEMENT
Dim Msg_Sup, Style, Title, response
Msg_Sup = "Etes vous sûr de vouloir insérer une nouvelle image ? " & vbCrLf & "Aucun retour en arrière ne sera possible" & vbCrLf & " L'image sera detruite du document Excel"
Style = vbYesNo + vbQuestion + vbDefaultButton2 ' Définit les boutons.
Title = "Importation d'une nouvelle image" ' Définit le titre.
response = MsgBox(Msg_Sup, Style, Title) ' Affiche le message.
'SI NON AU MESSAGE
If response = vbNo Then ' L'utilisateur a choisi Non.
MyString = "Non" ' Effectue une action.
[BF17].Select
ActiveSheet.Protect "lesage"
Exit Sub
ElseIf response = vbYes Then
ActiveSheet.Shapes(PHOTO).Delete
End If
Else
End If
'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 "lesage"
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
'SELECTIONER UNE CELLULE
[BF17].Select
'PROTECTION
ActiveSheet.Protect "lesage"
End Sub