Discussion :

[NODIX86]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[alidroos]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[NODIX86]

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

[alidroos]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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...

[alidroos]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Enregistrez le chemin du fichier dans lequel enregistrer l'image

[laurent_ott]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Le code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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