对Worksheet_SelectionChange事件写入代码后影响Excel剪切、复制粘贴的修正

当在Excel的WorkSheet的 SelectionChange事件中写入代码后有可能会影响到Excel的复制、剪切和粘贴功能。有可能会使此功能无效。最近在网上看到一段代码很有帮助，可以解决此问题，对代码进行了一些修改和注释。放到这里大家共享。
Worksheet中的代码：

Private   Sub  Worksheet_SelectionChange( ByVal  Target  As  Range)
     Dim  rngCutCopy  As  Range
     Dim  iCutCopymode  As   Integer
     If  Application.CutCopyMode  Then
         Set  rngCutCopy  =  CutCopyRange
     Else
         Set  rngCutCopy  =   Nothing
     End   If
    iCutCopymode  =  Application.CutCopyMode
    Target.Interior.ColorIndex  =   34   ' //这里写入你原来要写的代码
     If  iCutCopymode  =  xlCopy  Then
        rngCutCopy.Copy
     ElseIf  iCutCopymode  =  xlCut  Then
        rngCutCopy.Cut
     End   If
End Sub

模块中的代码：

Option   Explicit
' /锁定内存中指定的内存块,并返回一个地址值,令其指向内存块的起始处
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  GlobalSize _
     Lib   " kernel32 "  ( _
         ByVal  hMem  As   Long ) _
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  wFormat  As   Long ) _
As   Long
' /将一块内存的数据从一个位置复制到另一个位置
Private   Declare   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

详见附件：
点击下载

转载于:https://www.cnblogs.com/wangminbai/archive/2008/04/08/1142109.html