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
| Option Explicit
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 CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) 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
Public WithEvents Image As MSForms.Image
Private Sub Image_Click()
Dim NomImage As String
NomImage = Image.Tag
If NomImage <> "" Then
Feuil1.Shapes(NomImage).Copy
ActiveSheet.Paste
Selection.OnAction = "Suppression"
Range("A1").Select
End If
Unload Image.Parent.Parent
End Sub
Private Sub PictureAdd(Usf As Object, i As Integer, ByVal N As Integer, Shp As Object, Gauch As Single, Haut As Single, ByVal L As Single, ByVal H As Single)
Dim Frm As MSForms.Frame
Dim Img As MSForms.Image
Set Frm = Usf.Frame1
Set Img = Frm.Controls.Add("forms.Image.1")
With Img
i = i + 1
.Tag = Shp.Name
.Left = Gauch
.Top = Haut
.Width = L
.Height = H
With Frm
If .Width < (N + 1) * L Then .Width = .Width + L + 10
.Height = Haut + H + 20
End With
If i Mod N = 0 Then
Haut = Haut + H + 10
Gauch = 0
Else
Gauch = Gauch + L + 10
End If
Shp.CopyPicture
.Picture = PastePicture
.PictureSizeMode = 3
ReDim Preserve Cls(1 To i)
Set Cls(i).Image = Img
End With
Set Frm = Nothing
End Sub
Sub Ajouter(Usf As Object, i As Integer, ByVal N As Integer, Gauch As Single, Haut As Single, ByVal L As Single, ByVal H As Single, ByVal Col As Integer)
Dim Shap As Shape
For Each Shap In Feuil1.Shapes
If Shap.Type = 13 Then
If Shap.TopLeftCell.Column = Col Then PictureAdd Usf, i, N, Shap, Gauch, Haut, L, H
End If
Next Shap
Usf.Width = Usf.Frame1.Width + 10
Usf.Height = Usf.Frame1.Height + 10
End Sub
Private Function PastePicture() As IPicture
Const lMETAFILE As Long = 14
Dim lPictureAvailable As Long
Dim lClipHandle As Long
Dim lPicHandle As Long
Dim lCopyHandle As Long
Dim uInterGUID As GUID
Dim uPictureInfo As uPicDesc
Dim lOLEHandle As Long
Dim iTempPicture As IPicture
lPictureAvailable = IsClipboardFormatAvailable(lMETAFILE)
If lPictureAvailable <> 0 Then
lClipHandle = OpenClipboard(0&)
If lClipHandle > 0 Then
lPicHandle = GetClipboardData(lMETAFILE)
lCopyHandle = CopyEnhMetaFile(lPicHandle, vbNullString)
lClipHandle = CloseClipboard
If lPicHandle <> 0 Then
With uInterGUID
.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 uPictureInfo
.Size = Len(uPictureInfo) ' Length of structure.
.Type = 4 ' Type of Picture = Metafile
.hPic = lCopyHandle ' Handle to image.
.hPal = 0 ' Handle to palette.
End With
lOLEHandle = OleCreatePictureIndirect(uPictureInfo, uInterGUID, True, iTempPicture)
If lOLEHandle = 0 Then Set PastePicture = iTempPicture
End If
End If
End If
End Function |
Partager