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 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
|
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
#If VBA7 Then
Private Declare PtrSafe Function IsClipboardFormatAvailable& Lib "User32" (ByVal wFormat&)
Private Declare PtrSafe Function OpenClipboard& Lib "User32" (ByVal hWnd&)
Private Declare PtrSafe Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Private Declare PtrSafe Function CloseClipboard& Lib "User32" ()
Private Declare PtrSafe Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture)
Private Declare PtrSafe Function CopyEnhMetaFile& Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare PtrSafe Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
#Else
Private Declare Function IsClipboardFormatAvailable& Lib "User32" (ByVal wFormat&)
Private Declare Function OpenClipboard& Lib "User32" (ByVal hWnd&)
Private Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Private Declare Function CloseClipboard& Lib "User32" ()
Private Declare Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture)
Private Declare Function CopyEnhMetaFile& Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
#End If
Const CF_BITMAP = 2, CF_PALETTE = 9, CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0, LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1, PICTYPE_ENHMETAFILE = 4
Sub abababaabbaaabb(aabababababaa)
erk = 0
On Error GoTo boucle0
Dim Img As Shape
Dim Grph As Chart
Dim Curve As Worksheet
Set Curve = ThisWorkbook.Sheets("MYTCD")
If aabababababaa <> 4 And aabababababaa <> 5 Then
Set Grph = Curve.ChartObjects(aabababababaa).Chart
ElseIf aabababababaa = 4 Then
Set Grph = Sheets("Simulation").ChartObjects(2).Chart
ElseIf aabababababaa = 5 Then
Set Grph = Sheets("Simulation").ChartObjects(1).Chart
End If
Grph.CopyPicture
ThisWorkbook.Activate
Sheets("Graphiques").Activate
Sheets("Graphiques").Paste
Call waittime
On Error Resume Next
Set Img = Sheets("Graphiques").Shapes(aabababababaa)
On Error GoTo 0
If Not Img Is Nothing Then
Img.CopyPicture xlScreen, xlPicture
Select Case aabababababaa
Case 1
Set Graphs.Image1.Picture = babababababaa()
Case 4
Set Graphs.Image2.Picture = babababababaa()
Case 2
Set Graphs.Image3.Picture = babababababaa()
Case 3
Set Graphs.Image4.Picture = babababababaa()
Case 5
Set Graphs.Image5.Picture = babababababaa()
End Select
End If
Set Grph = Nothing
Exit Sub
boucle0:
If erk < 10 Then
Debug.Print "Erreur 0." & erk
Grph.CopyPicture
Resume Next
End If
End Sub
Function babababababaa(Optional lXlPicType& = xlPicture) As IPicture
Dim hPtr&, lPicType&, hCopy&
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
If IsClipboardFormatAvailable(lPicType) Then
If OpenClipboard(0&) > 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
CloseClipboard
If hPtr <> 0 Then Set babababababaa = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function
Private Function CreatePicture(hPic&, hPal&, lPicType&) As IPicture
Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
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
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set CreatePicture = IPic
End Function |