EXPORT plage en image

Version imprimable

1 pièce(s) jointe(s)

Bonjour,
j'ai une plage de cellules de A1 à Y25 avec du texte et deux photos je voudrais exporter cette plage au format JPG et la renommer suivant la cellule A1 et si c'est possible en cellule E23 c'est inscrire le chemin ou ce trouve la photo
J'ai ce code mais je ne sais pas comment le modifier et en plus il créer un nouveau classeur
Merci
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub CopiePlageDeCelluleEtExporterImage() Application.ScreenUpdating = False With Sheets("feuil1") .Activate Workbooks.Add .Range("A1:Y25").CopyPicture With ActiveSheet .Paste With .ChartObjects.Add(0, 0, _ Selection.Width, Selection.Height).Chart .Paste .ChartArea.Border.LineStyle = 0 End With With .ChartObjects(1) .Top = 0 .Left = 0 .Chart.Export "C:\Users\Jean-Paul. Masson\Pictures\photo mer.jpg", "jpg" End With End With End With End Sub

Bonjour,

Une solution possible :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub TestCreationImage()
 
Dim Sh As Worksheet
 
    Set Sh = Sheets("Feuil1")
    CopiePlageDeCelluleEtExporterImage Sh, Sh.Range("A1:Y25"), "photo mer.jpg", "C:\Users\Jean-Paul. Masson\Pictures\", Sh.Range("E33")
    Set Sh = Nothing
 
End Sub
 
Sub CopiePlageDeCelluleEtExporterImage(ByVal FeuilleImage As Worksheet, ByVal AireImage As Range, ByVal NomDeLImage As String, ByVal RepertoireImage As String, ByVal CelluleLien As Range)
 
Dim ShChObj As ChartObject
 
    With FeuilleImage
         AireImage.CopyPicture
         Set ShChObj = .ChartObjects.Add(0, 0, AireImage.Width, AireImage.Height)
         With ShChObj
                .Chart.Paste
                .Chart.Export RepertoireImage & NomDeLImage, "jpg"
                .Delete
         End With
         CelluleLien.ClearContents
         .Hyperlinks.Add Anchor:=CelluleLien, Address:=RepertoireImage & NomDeLImage, TextToDisplay:=NomDeLImage
         Set ShChObj = Nothing
    End With
 
End Sub

Le libellé du lien hypertexte est le nom de l'image et non le chemin. Si c'est le chemin qu'il faut, remplacer NomDeLImage par RepertoireImage dans TextToDisplay

Cordialement.

01/10/2016, 08h21
JIPE59552

Bonjour
j'ai une erreur de compilation sub ou function non définie

Citation:

Le libellé du lien hypertexte est le nom de l'image et non le chemin. Si c'est le chemin qu'il faut, remplacer NomDeLImage par RepertoireImage dans TextToDisplay

moi c'est le nom du chemin en E23 comme ceci

Code:

.Hyperlinks.Add Anchor:=CelluleLien, Address:=RepertoireImage & NomDeLImage, TextToDisplay:=RepertoireImage
01/10/2016, 08h38
Invité

Citation:

Envoyé par JIPE59552

j'ai une erreur de compilation sub ou function non définie

Le code que j'ai mis en ligne fonctionne correctement chez moi.
Avez-vous vérifié la présence du \ à la fin du chemin dans "C:\Users\Jean-Paul. Masson\Pictures\" ?

Sinon, sans votre code on ne peut deviner.

Citation:

moi c'est le nom du chemin en E23 comme ceci

Vous aurez compris que c'est vous qui définissez les paramètres dans la procédure TestCreationImage

Cordialement.
01/10/2016, 08h50
JIPE59552

Oui il y a le \ avec ou sans même problème et comme mes connaissance sont faible
01/10/2016, 09h01
Invité

Citation:

Envoyé par JIPE59552

Oui il y a le \ avec ou sans même problème

Quelle est l'extension du fichier Excel : .xls, .xlsx, .xlsm ?

Le fichier zip joint contient le fichier .xlsm avec son code. Si vous avez toujours un problème, modifiez le répertoire de destination et arrangez-vous pour qu'il ne contienne pas de "."

Pièce jointe 221642

Cordialement.
01/10/2016, 09h31
JIPE59552

l'extension est xlsm
J'ai recopié le code du dernier poste c'est ok je n'ai pas trouvé ou est le changement entre les deux codes
si c'est possible j'aimerais que la photo soit renommé comme la cellule A1 le lien hypertexte ne me sert pas c'est juste le chemin ou ce trouve la photo comme la photo est ensuite imprimé ca facilite ou elle ce trouve

Citation:

Envoyé par JIPE59552

J'ai recopié le code du dernier poste c'est ok je n'ai pas trouvé ou est le changement entre les deux codes

Il vous faut mettre votre code en ligne sinon personne ne pourra vous dépanner.

Citation:

Envoyé par JIPE59552

si c'est possible j'aimerais que la photo soit renommé comme la cellule A1 le lien hypertexte ne me sert pas c'est juste le chemin ou ce trouve la photo comme la photo est ensuite imprimé ca facilite ou elle ce trouve

Si le nom de l'image en A1 contient l'extension ex : XXXX.jpg, alors il suffit de modifier TestCreationImage comme ci-dessous. Sinon il faut remplacer Sh.Range("A1") par Sh.Range("A1") & ".jpg".

Pour le répertoire, j'ai modifié CopiePlageDeCelluleEtExporterImage
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 Sub TestCreationImage() Dim Sh As Worksheet Set Sh = Sheets("Feuil1") CopiePlageDeCelluleEtExporterImage Sh, Sh.Range("A1:Y25"), Sh.Range("A1"), "C:\Users\Jean-Paul. Masson\Pictures\", Sh.Range("E23") Set Sh = Nothing End Sub Sub CopiePlageDeCelluleEtExporterImage(ByVal FeuilleImage As Worksheet, ByVal AireImage As Range, ByVal NomDeLImage As String, ByVal RepertoireImage As String, ByVal CelluleLien As Range) Dim ShChObj As ChartObject With FeuilleImage With CelluleLien .ClearContents .WrapText = True .HorizontalAlignment = xlLeft .Value = RepertoireImage End With AireImage.CopyPicture Set ShChObj = .ChartObjects.Add(0, 0, AireImage.Width, AireImage.Height) With ShChObj .Chart.Paste .Chart.Export RepertoireImage & NomDeLImage, "jpg" .Delete End With '.Hyperlinks.Add Anchor:=CelluleLien, Address:=RepertoireImage & NomDeLImage, TextToDisplay:=RepertoireImage Set ShChObj = Nothing End With End Sub
Cordialement.

Bonjour des exemple il y en a des tas

en faisant une recherche tu en aurais trouvé quelque uns

basé sur ma contribution "cliché d'un range" que tu trouvera dans les contributions voici un code épuré utilisant quelques apis a adapter en 64 bit si excel 64 bits

la qualité de l'image s'en ressent par rapport a l'export d'un graph

remplace selection par range(.....) et le chemin par ta cellule dans la sub test

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Option Explicit
Public Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(8) As Byte
End Type
Public Type PICTDESC
  cbSize As Long
  picType As Long
  hImage As Long
End Type
Public Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Public Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Declare Function CloseClipboard& Lib "user32" ()
Public Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
 Sub VidePP()
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub
  Sub test()
 'capture en image de la selection en cours remplacer selection par un range
 save_range_to_image Selection, "C:\Users\" & Environ("UserName") & "\Desktop\img.jpeg" ' ala place du chemin met sheets(X).range(xy) adapte le chemin de ta cellule
 End Sub
Function save_range_to_image(plage As Range, chemin)
Dim NOM_IMAGE As Variant
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret As Long
    'On copie la selection dans le clipboard
    plage.Copy 'Picture xlScreen, xlBitmap 'Copie la selection dans le clipboard
    'Prend l'image dans le cliboard
    Dim hCopy&: OpenClipboard 0&
    hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H8)
    CloseClipboard
    If hCopy = 0 Then Exit Function
      Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
    If Ret Then Exit Function
    With tPICTDEST: .cbSize = Len(tPICTDEST): .picType = 1: .hImage = hCopy: End With
    Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
    If Ret Then Exit Function
     SavePicture iPic, chemin
    Set iPic = Nothing
    VidePP
    MsgBox "capture sauvegardée sous :" & vbCrLf & chemin
End Function