AW: für bestimmten Bereich auschließlich kopieren erlaubt
20.08.2024 12:44:28
volti
Hallo R,
wenn ich das richtig sehe, verändert sich durch Deine Schutzeinstellung beim Kopieren nicht das Format, es ist so wie Du es wolltest.
Aber hier noch eine Idee:
Damit im ersten Bereich nichts verändert werden kann, kann (zwar nachträglich) die OnDo-Funktion verwendet werden. Das kommt Deinem Wunsche doch schon sehr nahe.
Des weiteren könnte man, bei jedem Feldwechsel (Selection.Change) und jedem Blattwechsel (Deactivate) meinen u.a. bereits empfohlenen Code einsetzen.
Der verhindert, dass sich andere Daten außer Text in der Zwischenablage befinden. Somit können keine Formate kopiert werden.
Hierbei ist dann kein Timer mehr nötig.
Schau mal, ob es so in Ordnung ist.
Code:
' ##### In ein allgemeines Modul #####
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 GlobalSize Lib "kernel32" ( _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" ( _
ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpy Lib "kernel32" ( _
ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" ( _
ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" ( _
ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Function KopiereZwischenablageDatenAlsText() As String
' Kopiert Daten in der Zwischenablage als Text
Dim hMem As LongPtr, lpGMem As LongPtr, sCliptext As String, i As Long
Const CF_TEXT As Long = 1
If IsClipboardFormatAvailable(CF_TEXT) > 0 Then ' Daten vorhanden?
For i = 1 To 2
OpenClipboard 0& ' Zwischenablage öffnen
If i = 1 Then hMem = GetClipboardData(CF_TEXT) ' TEXT aus Zwischenablage
If i = 2 Then hMem = GlobalAlloc(&H42, Len(sCliptext)) ' Speicher reservieren
If hMem > 0 Then
lpGMem = GlobalLock(hMem) ' Speicher blockieren
If i = 1 Then
sCliptext = Space(CLng(GlobalSize(hMem))) ' Platz reservieren
lstrcpy sCliptext, lpGMem ' Daten kopieren
GlobalUnlock hMem ' Speicher freigeben
EmptyClipboard ' Zwischenablage leeren
Else
lpGMem = lstrcpy(lpGMem, sCliptext) ' Daten kopieren
If GlobalUnlock(hMem) = 0 Then _
SetClipboardData CF_TEXT, hMem ' TEXT in Zwischenablage
End If
End If
CloseClipboard ' Zwischenablage schließen
Next i
End If
End Function
' ##### In das Tabellenblatt-Modul #####
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSect
With Application
Set iSect = .Intersect(Range("B10:B20"), Target)
If Not iSect Is Nothing Then
.EnableEvents = False
.Undo
.EnableEvents = True
End If
End With
End Sub
Private Sub Worksheet_Deactivate()
Call KopiereZwischenablageDatenAlsText
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call KopiereZwischenablageDatenAlsText
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz