在win7下可以运行在win10下导致excel崩溃的代码

[water2]

下面的代码，是在excel中限制粘贴为数值的代码，在win7下运行正常，在win10下无法运行，找不到原因，求教各位大师。





'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>\\\\\\\\\\\\\\\\\\\\\\\ API函数定义开始 /////////////////////////<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

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 Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardOwner Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem 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 GlobalAlloc Lib "kernel32" (ByVal flags As Long, ByVal Size As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetClipboardFormatName Lib "user32.dll" Alias "GetClipboardFormatNameW" (ByVal wFormat As Long, ByVal lpString As Long, ByVal nMaxCount As Long) As Long

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>\\\\\\\\\\\\\\\\\\\\\\\ API函数定义结束 /////////////////////////<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Private Type DataArray
bData() As Byte
fID As Long
End Type

Private Const MAX_PATH As Long = 260

Public Sub CheckClipboard()
Dim Format As Long
Dim hMem As Long
Dim mSize As Long
Dim mPtr As Long
Dim nFormats As Long
Dim ClipboardData() As DataArray

nFormats = 0
OpenClipboard (0)
Format = EnumClipboardFormats(0)

On Error Resume Next

If (Format <> 0) Then
Do
If IsClipboardFormatAvailable(Format) Then
If Format > &HC000& Then
Select Case GetFormatName(Format)
Case "Csv", "Rich Text Format", "HTML Format", "XML Spreadsheet"
Case Else: GoTo DoLOOP01
End Select
End If
hMem = GetClipboardData(Format)
mSize = GlobalSize(hMem)
mPtr = GlobalLock(hMem)

If mSize > 0 Then
nFormats = nFormats + 1

ReDim Preserve ClipboardData(0 To nFormats)
ReDim ClipboardData(nFormats - 1).bData(0 To mSize - 1)
CopyMemory ClipboardData(nFormats - 1).bData(0), ByVal mPtr, mSize
ClipboardData(nFormats - 1).fID = Format
End If
GlobalUnlock hMem
End If
DoLOOP01:
Format = EnumClipboardFormats(Format)
Loop While (Format <> 0)
End If
EmptyClipboard
Do While nFormats > 0
mSize = UBound(ClipboardData(nFormats - 1).bData) - LBound(ClipboardData(nFormats - 1).bData) + 1
hMem = GlobalAlloc(0, mSize)

If hMem <> 0 Then
mPtr = GlobalLock(hMem)
CopyMemory ByVal mPtr, ClipboardData(nFormats - 1).bData(0), mSize
GlobalUnlock hMem
SetClipboardData ClipboardData(nFormats - 1).fID, hMem
End If
nFormats = nFormats - 1
Loop
CloseClipboard
End Sub

Private Function GetFormatName(ByVal lngFormat As Long) As String
Dim strTemp As String
Dim lngRet As Long
strTemp = String(MAX_PATH, vbNullChar)
If GetClipboardFormatName(lngFormat, StrPtr(strTemp), MAX_PATH) Then
GetFormatName = strTemp
lngRet = InStr(strTemp, vbNullChar)
If lngRet Then
GetFormatName = Left$(strTemp, lngRet - 1)
Else
GetFormatName = strTemp
End If
End If
End Function




然后在需要些功能的工作表SelectionChange事件中添加调用代码：


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
CheckClipboard
End Sub