Exporter une image Excel dans un dossier

Version imprimable

02/06/2020, 19h53
NODIX86

Exporter une image Excel dans un dossier
Bonjour tous le monde,
dans un document excel j'utilise une macro assignée à un bouton de commande pour prendre une photo d'une partie de ma feuille et la coller un peu plus loin sur cette même feuille. Puis je copie l'image ainsi créée, la colle dans Paint, puis l'enregistre dans un dossier de mon ordinateur.

cependant, j'aimerai pouvoir réaliser cela sans devoir passer par l'étape Paint.

Du coup j'aimerai créer un deuxième bouton de commande qui exportera cette image dans un dossier bien défini avec un nom bien défini.
Ou encore mieux, avoir une macro qui pourra créer une image et l'exporter en une seule action.

ci-dessous ma macro actuelle qui crée l'image:
Code:

1 2 3 4 5 6 7 8 9 Private Sub bouton1_Click() Dim sh As Shape Range("V62").Select Worksheets("SB fold").Range("A62:T75").CopyPicture Worksheets("SB fold").Paste End Sub
Merci de votre aide

:ccool:

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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Option Explicit
Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(8) As Byte
End Type
Type PICTDESC
  cbSize As Long
  picType As Long
  hImage As Long
End Type
#If VBA7 Then
Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String _
, ByRef lpiid As GUID) As Long
Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" _
 (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long
#Else
Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Declare Function CloseClipboard& Lib "user32" ()
Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String _
, ByRef lpiid As GUID) As Long
Declare Function OleCreatePictureIndirect Lib "olepro32" _
 (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long
#End If
Private Sub DoTheWork(nPic As String)
On Error GoTo 1
  Dim hCopy&
  OpenClipboard 0&
  hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
  CloseClipboard
  If hCopy = 0 Then Exit Sub
  Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
  Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
  Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
  If Ret Then Exit Sub
  With tPICTDEST
    .cbSize = Len(tPICTDEST)
    .picType = 1
    .hImage = hCopy
  End With
  Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
  If Ret Then Exit Sub
  SavePicture iPic, nPic
  Set iPic = Nothing
1:
End Sub
Sub Pic_My()
Dim P As String
Dim Rng As Range
    Set Rng = Range("D5:K20")
    P = ActiveWorkbook.Path & "\" & "Test" & ".JPEG"
    Rng.CopyPicture xlScreen, xlBitmap
    Call DoTheWork(P)
Set Rng = Nothing
End Sub

02/06/2020, 22h44
NODIX86

Merci mais cette macro est ultra longue et je suis perdu, j'ai essayé et ça ne fonctionne pas

:pc:

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 Pic_My()
    Dim Rng As Range, P As String
    Set Rng = Range("D5:K20")
    P = ActiveWorkbook.Path & "\" & "Test" & ".JPEG"
    Exp_Rng Rng, P
End Sub
Sub Exp_Rng(Rng As Range, sPath As String)
    Dim CP_A, S_A
    Rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set CP_A = Rng.Parent.ChartObjects.Add(10, 10, 200, 200)
    Set S_A = CP_A.Chart.SeriesCollection
    Do While S_A.Count > 0
        S_A(1).Delete
    Loop
    With CP_A
        .ShapeRange.Line.Visible = msoFalse
        .Height = Rng.Height
        .Width = Rng.Width
        .Chart.Paste
        .Chart.Export Filename:=sPath, Filtername:="BMP"
        .Delete
    End With
End Sub

03/06/2020, 00h58
NODIX86

je ne comprends rien, je ne vois même pas ou je dois mettre le dossier de mon ordi ou excel doit sauvegarder l'image...
03/06/2020, 13h57
alidroos

Code:

P = ActiveWorkbook.Path & "\" & "Test" & ".JPEG"

Enregistrez le chemin du fichier dans lequel enregistrer l'image

Citation:

Envoyé par NODIX86

je ne comprends rien, je ne vois même pas ou je dois mettre le dossier de mon ordi ou excel doit sauvegarder l'image...

J'ai repris le code qui a été proposé, en apportant des commentaires pour qu'il puisse être mieux compris.

Dans ton cas pour exporter en BMP une partie des cellules de ton classeur en BMP dans le même répertoire ça donnerait :

Code:

Call Exporte_RangeEnBMP(Range("A62:T75"), ThisWorkbook.Path & "\MonFichier")

Le code:

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
'----------------------------------------------------------------------------------------
Public Function Exporte_RangeEnBMP(Rng As Range, StrFilename As String) As Boolean
'----------------------------------------------------------------------------------------
' Exporte une plage d'une feuille de calcul en fichier image BMP.
' Rng : la plage concernée
' StrFilename : le chemin et le nom du fichier (sans l'extention .BMP)
' Retourne : Vrai si tout c'est bien passé ou Faux en cas d'erreur.
' Source:
' https://www.developpez.net/forums/d2080964/logiciels/microsoft-office/excel/macros-vba-excel/exporter-image-excel-dossier/
' Exemple d'appel :
' Call Exporte_RangeEnBMP(Range("B3:H29"), ThisWorkbook.Path & "\MonFichier")
'----------------------------------------------------------------------------------------
' Gestion des erreurs:
Err.Clear
On Error GoTo Gest_Err
 
' Copie les cellules dans le Presse-papiers en tant qu'image:
Rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
 
' Création d'un objet image (de petite taille mais elle sera ajustée):
Dim ObjPicture
Set ObjPicture = Rng.Parent.ChartObjects.Add(10, 10, 10, 10)
With ObjPicture
    .ShapeRange.Line.Visible = msoFalse                     ' Masque l'objet.
    .Height = Rng.Height                                    ' Ajuste la hauteur.
    .Width = Rng.Width                                      ' Ajuste la largeur.
    .Chart.Paste                                            ' Colle le presse-papiers
    .Chart.Export Filename:=StrFilename & ".bmp", _
                  Filtername:="BMP"                         ' Exporte l'image en .bmp
    .Delete                                                 ' Supprime l'objet.
End With
 
Exporte_RangeEnBMP = True
 
' S'il y a une erreur alors supprime l'objet (s'il a été créé) et affiche un message:
Gest_Err:
If Err.Number <> 0 Then
    If Not ObjPicture Is Nothing Then ObjPicture.Delete
    MsgBox "Erreur: " & Err.Number & " - " & Err.Description, vbCritical + vbOKOnly
    Err.Clear
End If
 
End Function