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
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
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
Re, à tester
Dans un autre module standard
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 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 : 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
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
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 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
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 :
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
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 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
Merci de ton aide kiki29
Bonjour, par hasard il y aurait un moyen d'utiliser cette macro mais en enregistrant au format pdf ?
Merci
Salut, il te suffit d'adapter le lien donné plus haut Comment récupérer l'image contenue dans le presse papier pour l'enregistrer sur le PC
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 Option Explicit Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Sub Image_ClipBoard2Pdf() Dim x As Long Dim Sh As Shape x = ActiveSheet.Shapes.Count Application.ScreenUpdating = False With ActiveSheet .Range("A1").Select .Paste End With If x = ActiveSheet.Shapes.Count Then Application.ScreenUpdating = True MsgBox "Opération annulée" Exit Sub Else With ActiveSheet Set Sh = .Shapes(.Shapes.Count) .ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart.Paste .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ ThisWorkbook.Path & "\" & "ClipBoard2Pdf.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False .ChartObjects(.ChartObjects.Count).Delete .Shapes(.Shapes.Count).Delete End With Application.ScreenUpdating = True End If End Sub
Ok merci de ton aide :]
par contre peut on le faire sans copier le presse papier sur le classeur ?
Vous avez un bloqueur de publicités installé.
Le Club Developpez.com n'affiche que des publicités IT, discrètes et non intrusives.
Afin que nous puissions continuer à vous fournir gratuitement du contenu de qualité, merci de nous soutenir en désactivant votre bloqueur de publicités sur Developpez.com.
Partager