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
| Option Explicit
'---------------------------------------------------------------------------------------
' https://msdn.microsoft.com/fr-fr/library/office/ff194373.aspx
' https://msdn.microsoft.com/fr-fr/library/office/ff192913.aspx
'---------------------------------------------------------------------------------------
'' API 64 bits:
'' https://answers.microsoft.com/en-us/msoffice/forum/all/copy-paste-in-access-64-bit/2712f77c-03ec-4221-b4fe-d330379a58a3
''---------------------------------------------------------------------------------------
#If Win64 Then
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
#Else
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
#End If
'---------------------------------------------------------------------------------------
Private Const CF_TEXT = 1
Private Const MAXSIZE = 65536
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
Public Function ClipBoard_GetData() As String
'---------------------------------------------------------------------------------------
Dim hClipMemory As Long
Dim lpClipMemory As Long
Dim MyString As String
Dim RetVal As Long
If OpenClipboard(0&) = 0 Then '"Cannot open Clipboard. Another app. may have it open"
Exit Function
End If
' Obtain the handle to the global memory block that is referencing the text.
hClipMemory = GetClipboardData(CF_TEXT)
If IsNull(hClipMemory) Then '"Could not allocate memory"
GoTo OutOfHere
End If
' Lock Clipboard memory so we can reference the actual data string.
lpClipMemory = GlobalLock(hClipMemory)
If Not IsNull(lpClipMemory) Then
MyString = Space$(MAXSIZE)
RetVal = lstrcpy(MyString, lpClipMemory)
RetVal = GlobalUnlock(hClipMemory)
' Gestion de la taille maximale du message à récupérer du clavier:
If InStr(1, MyString, Chr$(0), 0) = 0 Then ' "Chaîne trop grande"
Call CloseClipboard
ClipBoard_GetData = ""
Exit Function
End If
' Peel off the null terminating character.
MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
End If
OutOfHere:
RetVal = CloseClipboard()
ClipBoard_GetData = MyString
End Function
'---------------------------------------------------------------------------------------
Public Function ClipBoard_SetData(MyString As String) As Boolean
'---------------------------------------------------------------------------------------
'32-bit code by Microsoft: http://msdn.microsoft.com/en-us/library/office/ff192913.aspx
Dim hGlobalMemory As LongPtr, lpGlobalMemory As LongPtr
Dim hClipMemory As LongPtr, x As Long
' Gestion de la taille maximale du message a envoyer au clavier:
If Len(MyString) >= MAXSIZE Then ' "Chaîne trop grande"
Exit Function
End If
' Gestion des chaînes vides:
If MyString = "" Then Exit Function
' Allocate moveable global memory.
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
' Lock the block to get a far pointer to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
' Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
' Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then '"Could not unlock memory location. Copy aborted."
GoTo OutOfHere
End If
' Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then ' "Could not open the Clipboard. Copy aborted."
Exit Function
End If
' Clear the Clipboard.
x = EmptyClipboard()
' Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere:
If CloseClipboard() <> 0 Then
ClipBoard_SetData = True
End If
End Function
'---------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------- |
Problème sur presse papier
Répondre avec citation
Envoyé par jijie
: ça peut servir aux autres 
Partager