|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
类模块中内容，注意是类模块！！！！！
Option Explicit
'/锁定内存中指定的内存块,并返回一个地址值,令其指向内存块的起始处
Private Declare PtrSafe Function GlobalLock _
Lib "kernel32" ( _
ByVal hMem As Long) _
As Long
'/解锁先前被锁定的内存,使得指向内存块的指针无效
Private Declare PtrSafe Function GlobalUnlock _
Lib "kernel32" ( _
ByVal hMem As Long) _
As Long
'/得到的是内存块的大小
Private Declare PtrSafe Function GlobalSize _
Lib "kernel32" ( _
ByVal hMem As Long) _
As Long
'/打开剪切板
Private Declare PtrSafe Function OpenClipboard _
Lib "user32" ( _
ByVal hwnd As Long) _
As Long
'/关闭剪切板
Private Declare PtrSafe Function CloseClipboard _
Lib "user32" () _
As Long
'/获取剪切板数据
Private Declare PtrSafe Function GetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long) _
As Long
'/将一块内存的数据从一个位置复制到另一个位置
Private Declare PtrSafe Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
'//--------------------------------------------------------------------------------------//
'//-----用于取得处于复制或者剪切状态的单元格区域的函数------//
'//--------------------------------------------------------------------------------------//
Public Function CutCopyRange() As Range
On Error GoTo Hanlder
Dim bytData() As Byte, hMem As Long, nClipsize As Long, lpData As Long
Dim sSource As String, sTemp() As String
Dim sWorkbook As String, sSheet As String, sRange As String
'/打开剪切板
OpenClipboard 0&
'/取得剪切板中有关Excel单元格复制的信息数据
hMem = GetClipboardData(49154)
'/假如存在数据
If CBool(hMem) Then
'/取得数据内存的大小
nClipsize = GlobalSize(hMem)
'/锁定此内存块，并返回内存块的起始地址
lpData = GlobalLock(hMem)
If lpData <> 0 Then
'/从新定义数组大小
ReDim bytData(0 To nClipsize - 1) As Byte
'/将内存复制到数组中
CopyMemory bytData(0), ByVal lpData, nClipsize
'/将二进制数组转换成字符串
sSource = StrConv(bytData, vbUnicode)
'/拆分字符串
sTemp = Split(sSource, Chr(0))
'/假使在拆分得到的字符串2中找到""（即工作薄已经保存）
If InStr(sTemp(1), "") Then
'/取得工作薄的名称
sWorkbook = Mid(sTemp(1), InStrRev(sTemp(1), "") + 1)
Else
'/取得工作薄的名称
sWorkbook = sTemp(1)
End If
'/取得工作表的名称
sSheet = Left(sTemp(2), InStr(sTemp(2), "!") - 1)
'/取得单元格区域的地址
sRange = R1C1_To_A1(Mid(sTemp(2), InStr(sTemp(2), "!") + 1))
'/取得处于剪切或者复制状态的单元格
Set CutCopyRange = Workbooks(sWorkbook).Sheets(sSheet).Range(sRange)
End If
'/解锁 内存
GlobalUnlock hMem
'/假如未处于复制或者剪切状态
Else
Set CutCopyRange = Nothing
End If
'/关闭剪切板
CloseClipboard
Exit Function
Hanlder:
Debug.Print err.Number & err.Description
End Function
'//--------------------------------------------------------------------------
'//----用于将单元格的R1C1引用样式转换为A1样式------
'//--------------------------------------------------------------------------
Private Function R1C1_To_A1(RgStr As String) As String
Dim sTemp() As String
If InStr(RgStr, ":") Then
sTemp = Split(RgStr, ":")
R1C1_To_A1 = R1C1_To_A1(sTemp(0)) & ":" & R1C1_To_A1(sTemp(1))
Else
RgStr = Mid(RgStr, 2)
sTemp = Split(RgStr, "C")
R1C1_To_A1 = Chr(64 + sTemp(1)) & sTemp(0)
End If
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo err
'/错误处理，发生异常时转到err
Dim rngCutCopy As Range
Dim iCutCopymode As Integer
If CutCopyMode Then
Set rngCutCopy = CutCopyRange
Else
Set rngCutCopy = Nothing
End If
iCutCopymode = CutCopyMode
自己代码
If iCutCopymode = xlCopy Then
rngCutCopy.Copy
ElseIf iCutCopymode = xlCut Then
rngCutCopy.Cut
End If
err:
'/异常时不做任何处理，只是为了屏蔽对话框
End Sub
|
|
楼主: yylucke
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-8-2 16:47
