LotusScript ClipBoard Code für 32/64 Bit

[eknori]

Hier gab es schon ein paar Einträge, dass der "alte" Clipboard Code unter 64 Bit teilweise nicht mehr funktioniert. Gestern gab es in einem anderen Forum ebenfalls die gleiche Diskussion.
Ich habe mir das heute einmal näher angesehen.

Hier eine funktionierende Variante

Code

%REM
	Library lib_clipboard32-64
	Created Mar 4, 2024 by francesco@marzolo.com
	Modified Mar 5, 2024 by Ulrich Krause
	Description: Allows 64-32 bitness clipboard managing
%END REM
Option Public
Option Declare

Const CF_UNICODETEXT = 13
Const CF_TEXT = 1
Const OS_TRANSLATE_UNICODE_TO_LMBCS = 23

Const LSI_THREAD_PROC=1
Const LSI_THREAD_CALLPROC=10

Public Const GHND = &H42

'** 32-bit API calls
Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32.dll" () As Long
Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long

Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long 
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long

Declare Function OSTranslateFromPtr Lib "nnotes.dll" Alias "OSTranslate" ( _
	ByVal mode As Integer, _
	ByVal strIn As Long, _
	ByVal lenIn As Integer, _
	ByVal strOut As LMBCS String, _
	ByVal lenOut As Integer ) As Integer

'** 64-bit API calls
Declare Function OpenClipboard_64 Lib "user32.dll" Alias "OpenClipboard" (ByVal hwnd As double) As Long	'** hwnd is a window handle 
Declare Function GetClipboardData_64 Lib "user32.dll" Alias "GetClipboardData" (ByVal wFormat As Long) As Double	'** returns a memory handle
Declare Function CloseClipboard_64 Lib "user32.dll" Alias "CloseClipboard" () As Long

Declare Function GlobalLock_64 Lib "kernel32.dll" Alias "GlobalLock" (ByVal hMem As Double) As Double	'** hMem is a memory handle, returns a pointer
Declare Function GlobalUnlock_64 Lib "kernel32.dll" Alias "GlobalUnlock" (ByVal hMem As Double) As Long	'** hMem is a memory handle, returns a BOOL 
Declare Function GlobalSize_64 Lib "kernel32.dll" Alias "GlobalSize" (ByVal hMem As Double) As Long	'** hMem is a memory handle, returns a size

Declare Function OSTranslateFromPtr_64 Lib "nnotes.dll" Alias "OSTranslate" ( _
	ByVal mode As Integer, _
	ByVal strIn As Double,	_ '** strIn is a string pointer
	ByVal lenIn As Integer, _
	ByVal strOut As LMBCS String, _
	ByVal lenOut As Integer ) As Integer
	
	
'to set clipboard
Private Const GMEM_MOVEABLE = &H40
Private Const GMEM_ZEROINIT = &H2
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function IsClipboardFormatAvailable Lib "user32"  (ByVal wFormat As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long	'** returns a memory handle
Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As String) As Long
Declare Function GlobalAlloc_64 Lib "kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As Long) As Double	'** returns a memory handle

Declare Function NEMGetCurrentSubprogramWindow Lib "nnotesws.dll" () As Long

Declare Function SetClipboardData_64 Lib "user32" Alias "SetClipboardData" (ByVal wFormat As Long, ByVal hMem As Double) As Long




Sub Initialize
	
End Sub
Sub Terminate
	
End Sub




Public Function GetClipboard() As String
	Dim session As New NotesSession
	If (session.Platform = "Windows/64") Then
		GetClipboard = GetClipboard64()
		Exit Function
	End If
	

	Dim glbHandle As Long 
	Dim cbPointer As Long
	Dim cbPointerLen As Long 
	Dim cbString As String

	If OpenClipboard(0) Then
		glbHandle = GetClipboardData(CF_UNICODETEXT) 
		cbPointer = GlobalLock(glbHandle) 
		cbPointerLen = GlobalSize(glbHandle)

		cbString = Space(cbPointerLen)
		Call OSTranslateFromPtr( OS_TRANSLATE_UNICODE_TO_LMBCS, _
		cbPointer, cbPointerLen, cbString, cbPointerLen ) 
		cbString = StrLeft(cbString, Chr(0))

		Call GlobalUnlock(glbHandle) 
		Call CloseClipboard()
	End If

	GetClipboard = cbString
End Function
Public Sub SetClipboard(txt As String)
	Dim session As New NotesSession
	If (session.Platform = "Windows/64") Then
		SetClipboard64(txt)
		Exit Sub
	End If
	
	Dim hwnd As Long
	Dim hGlobalMemory As Long
	Dim lpGlobalMemory As Long
	Dim ret As Long
	
	On Error GoTo error_handler
	
' Get a handle to current window
	hwnd = NEMGetCurrentSubProgramWindow()
	If hwnd Then
' Allocate memory
		hGlobalMemory = GlobalAlloc(CLng(GMEM_MOVEABLE Or GMEM_ZEROINIT),CLng(Len(txt)+1))
		If hGlobalMemory Then
			lpGlobalMemory = GlobalLock(hGlobalMemory)
			If lpGlobalMemory Then
				ret = lstrcpy(lpGlobalMemory, txt)
				Call GlobalUnlock(hGlobalMemory)
				If OpenClipboard(hwnd) Then
					ret = EmptyClipboard()
					ret = SetClipboardData(CF_TEXT, hGlobalMemory)
					ret = CloseClipboard()
				End If
			Else
				MsgBox "Can't allocated global memory pointer.", 32, "Error"
			End If
		Else
			MsgBox "Can't allocated global memory handle.", 32, "Error"
		End If
	Else
		MsgBox "Can't get window handle.", 32, "Error"
	End If
	Exit Sub
error_handler:
	Print "Error: " + Error$(Err)
	Resume Next
End Sub

Function describeError() As String
	describeError=Error & " (at row " & Erl & " of " & GetThreadInfo(LSI_THREAD_CALLPROC) & ")"
End Function


Function GetClipboard64() As String
	On Error GoTo sbreng
	Dim session As New NotesSession
	session.UseDoubleAsPointer = True
	Dim glbHandle_64 As Double
	Dim cbPointer_64 As Double
	Dim cbPointerLen As Long
	Dim cbString As String

	If OpenClipboard_64(0) Then
		glbHandle_64 = GetClipboardData_64(CF_UNICODETEXT) 
		cbPointer_64 = GlobalLock_64(glbHandle_64) 
		cbPointerLen = GlobalSize_64(glbHandle_64)

		cbString = Space(cbPointerLen)
		Call OSTranslateFromPtr_64( OS_TRANSLATE_UNICODE_TO_LMBCS, cbPointer_64, cbPointerLen, cbString, cbPointerLen ) 
		cbString = StrLeft(cbString, Chr(0))

		Call GlobalUnlock_64(glbHandle_64)
		Call CloseClipboard_64()
	End If
	GetClipboard64=cbString
	
endop:
	session.UseDoubleAsPointer = False
	Exit Function
sbreng:
	Dim errmsg$
	errmsg$="Error: " & Err & ", call stack: " &  describeerror()
	Print errmsg
	'ensure you execute anyway useDoubleAsPointer=False
	Resume endop
End Function
Function SetClipboard64(txt As String)

	Dim session As New NotesSession
	session.UseDoubleAsPointer = True
	
	Dim hGlobalMemory As Long
	Dim lpGlobalMemory As Long
	Dim hClipMemory As Long
	Dim X As Long
	
	hGlobalMemory = GlobalAlloc(GHND, Len(txt) + 1)
	lpGlobalMemory = GlobalLock(hGlobalMemory)
	lpGlobalMemory = lstrcpy(lpGlobalMemory, txt)
	
	If GlobalUnlock(hGlobalMemory) <> 0 Then
		MsgBox "Could not unlock memory location. Copy aborted."
		GoTo OutOfHere2
	End If
	
	If OpenClipboard(0&) = 0 Then
		MsgBox "Could not open the Clipboard. Copy aborted."
		Exit Function
	End If
	
	X = EmptyClipboard()
	hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
	
OutOfHere2:
	If CloseClipboard() = 0 Then
		MsgBox "Could not close Clipboard."
	End If
	session.UseDoubleAsPointer = False
End Function

[Tode]

Fantastisch, danke Ulrich! Thomas Bahn hatte das im HCL Support Forum auch gefragt, habe die Lösung von dort aber nie ausprobiert...

[eknori]

Die Lösung von Thomas unter https://support.hcltechsw.com/community?id=community_question&sys_id=6d7817641be3b59cddcd75d4cc4bcb9b&anchor=answer_0da2f4871b6b3958534c4159cc4bcb20&view_source=searchResult
funktioniert auch