[XL-2007] Enregistrer image presse papier en format jpg ou bmp

[XceSs]

Bonjour, après avoir regarder un peu partout je n'arrive pas à enregistrer une image du presse papier directement en format jpg ou bmp sans la coller dans une feuille.

Merci de votre aide

[kiki29]

Salut, voir http://excel.developpez.com/faq/?pag...ImageClipBoard

[XceSs]

effectivement j'ai déjà consulter la FAQ le problème c'est que la méthode employé colle l'image dans une feuille excel et j'aimerais éviter cela et enregistrer directement si possible

[kiki29]

Re, à tester

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Option Explicit
 
Sub SaveClipboardBMP()
Dim File As Variant
Dim sFilter As String, lPicType As Long
Dim oPic As IPictureDisp
 
    On Error Resume Next
    Set oPic = PastePicture(xlBitmap)
    On Error GoTo 0
 
    If oPic Is Nothing Then
        MsgBox "pas d'image dans le presse papier"
    Else
        ChDir ThisWorkbook.Path & "\"
        sFilter = "Windows Bitmap (*.bmp),*.bmp"
        File = Application.GetSaveAsFilename(InitialFileName:="Test", filefilter:=sFilter)
        If File <> False Then
            SavePicture oPic, File
            ClearOfficeClipboard
        End If
    End If
End Sub

Dans un autre module standard

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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
Option Explicit
Option Compare Text
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
 
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
 
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
 
Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
 
    lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
    hPicAvail = IsClipboardFormatAvailable(lPicType)
 
    If hPicAvail <> 0 Then
        h = OpenClipboard(0&)
        If h > 0 Then
            hPtr = GetClipboardData(lPicType)
            If lPicType = CF_BITMAP Then
                hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Else
                hCopy = CopyEnhMetaFile(hPtr, vbNullString)
            End If
            h = CloseClipboard
            If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
        End If
    End If
End Function
 
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicinfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
 
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
 
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
        .hPic = hPic
        .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)
    End With
 
    r = OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic)
    If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
    Set CreatePicture = IPic
 
End Function
 
Private Function fnOLEError(lErrNum As Long) As String
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0
 
    Select Case lErrNum
        Case E_ABORT
            fnOLEError = " Aborted"
        Case E_ACCESSDENIED
            fnOLEError = " Access Denied"
        Case E_FAIL
            fnOLEError = " General Failure"
        Case E_HANDLE
            fnOLEError = " Bad/Missing Handle"
        Case E_INVALIDARG
            fnOLEError = " Invalid Argument"
        Case E_NOINTERFACE
            fnOLEError = " No Interface"
        Case E_NOTIMPL
            fnOLEError = " Not Implemented"
        Case E_OUTOFMEMORY
            fnOLEError = " Out of Memory"
        Case E_POINTER
            fnOLEError = " Invalid Pointer"
        Case E_UNEXPECTED
            fnOLEError = " Unknown Error"
        Case S_OK
            fnOLEError = " Success!"
    End Select
End Function

Dans un autre module standard

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
 
Private Declare Function FindWindowEx& Lib "user32.dll" _
                                       Alias "FindWindowExA" (ByVal hWnd1 As Long, _
                                                              ByVal hWnd2 As Long, ByVal lpsz1 As String, _
                                                              ByVal lpsz2 As String)
Private Declare Function PostMessage& Lib "user32.dll" _
                                      Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
                                                            ByVal wParam As Long, ByVal lParam As Long)
Const WM_LBUTTONDOWN As Long = &H201&
Const WM_LBUTTONUP As Long = &H202&
 
Sub ClearOfficeClipboard()
Dim CB As CommandBar
Dim Etat As Boolean
Dim hExcel2 As Long
Dim hWindow As Long
Dim hParent As Long
Dim hClip As Long
Dim coord As Long
    On Error GoTo Erreur
    Application.ScreenUpdating = False
    Set CB = Application.CommandBars("Task Pane")
    With CB
        .Position = msoBarRight
        Etat = .Visible
    End With
    If Not Etat Then Application.CommandBars(1).Controls(2).Controls(5).Execute
    hExcel2 = FindWindowEx(Application.hWnd, hExcel2, "EXCEL2", vbNullString)
    If hExcel2 = 0 Then Exit Sub
    hWindow = FindWindowEx(hExcel2, hWindow, "MsoCommandBar", CB.NameLocal)
    If hWindow Then
        hParent = hWindow
        hWindow = 0
        hWindow = FindWindowEx(hParent, hWindow, "MsoWorkPane", vbNullString)
        If hWindow Then
            hParent = hWindow
            hWindow = 0
            hClip = FindWindowEx(hParent, hWindow, "bosa_sdm_XL9", vbNullString)
        End If
    End If
    If hClip > 0 Then
        coord& = 25 * 65536 + 125
        PostMessage hClip, WM_LBUTTONDOWN, 0&, coord&
        PostMessage hClip, WM_LBUTTONUP, 0&, coord&
    End If
    If Not Etat Then CB.Visible = False
Erreur:
    Application.ScreenUpdating = True
End Sub

[XceSs]

Ca à l'air de fonctionner mais ça me demande ou je veux l'enregistrer j'aimerais ne pas avoir la fenêtre et ça enregistrer sur le bureau directement. Je vois pas ou modifier ça dans ton code.

J'ai modifié ça, apparemment c bon :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Option Explicit
 
Sub SaveClipboardBMP()
Dim File As Variant
Dim sFilter As String, lPicType As Long
Dim oPic As IPictureDisp
 
    On Error Resume Next
    Set oPic = PastePicture(xlBitmap)
    On Error GoTo 0
 
    If oPic Is Nothing Then
        MsgBox "pas d'image dans le presse papier"
    Else
        File = "C:\Users\fix\Desktop\Test.bmp"
        If File <> False Then
            SavePicture oPic, File
            ClearOfficeClipboard
        End If
    End If
End Sub

Par contre par moment soit il me dit pas d'image dans le presse papier ou sur les images ils manquent des éléments dessus comme les textes

Merci de ton aide kiki29

[XceSs]

Bonjour, par hasard il y aurait un moyen d'utiliser cette macro mais en enregistrant au format pdf ?

Merci