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
| Private Declare Function GetTempFileNameA Lib "Kernel32" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long
Private Sub CommandButton1_Click()
CopiePhoto Cells(1, 1)
'CopiePhoto ActiveSheet.Shapes(1), 0, 0
End Sub
Sub CopiePhoto(Source As Variant, Optional transparency As Long = 1, Optional borders As Long = 0)
Dim FichTemp As String
FichTemp = Space(160)
GetTempFileNameA Environ("TMP"), "IMG", 0, FichTemp
FichTemp = Left$(FichTemp, InStr(FichTemp, vbNullChar) - 1)
'Debug.Print FichTemp
Source.Copy 'Picture
OpenClipboard 0
DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), FichTemp)
CloseClipboard
On Error Resume Next
With Me.Image1
.Picture = LoadPicture(FichTemp)
.BackStyle = transparency
.BorderStyle = 0
.Move .Left, .Top, Source.Width, Source.Height
End With
Kill FichTemp
End Sub |
