VB 剪切板应用

VB 剪切板应用
今天发现了一个不错的剪贴板的应用可以让VB 写出一个不错的个性
以下是转载文字
有时候大家看到在某些程序复制出的东西不能被粘贴在其他的地方（粘贴为灰色）。

在VB中也可以实现这种效果。

即使用自己的剪切板格式
刚才翻墙找到了一段读剪切板的代码。

于是我仿照着写出了写剪切板的代码。

用法如下：
SetClipboardIDForCustomFormat Lyer's
'双引号中字符串为你定义的剪切板格式说明
写剪切板：
SetCBData 往剪切板中写啥呢？
读剪切板：
Lyer=GetCBData
判断剪切板中是否有自己格式的数据：
if IsCBMyFormat then
'.......
end if
'======================================================
' Lyer[Ryuu.U]
'- Aug 07,2010 -
'======================================================
'lyerblogitemfd6d9313f543168d6538dba3.html
Private Declare Function OpenClipboard Lib user32 (ByVal hWnd As Long) As Long Private Declare Function SetClipboardData Lib user32 (ByVal wFormat As Long, ByVal hMem 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 IsClipboardFormatAvailable Lib user32 (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib user32 Alias
RegisterClipboardFormatA (ByVal lpString As String) As Long
Private Declare Function GlobalAlloc Lib kernel32 (ByVal wFlags As Long, ByVal dwBytes 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 GlobalSize Lib kernel32 (ByVal hMem As Long) As Long Private Declare Sub CopyMemory Lib kernel32 Alias RtlMoveMemory ( lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function EmptyClipboard Lib user32 () As Long
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Public lFormatID As Long
Public Sub SetClipboardIDForCustomFormat(ByVal sName As String) 'As Long
Dim wFormat As Long
wFormat = RegisterClipboardFormat(sName & Chr$(0))
If (wFormat &HC000&) Then
lFormatID = wFormat
End If
End Sub
Public Function GetCBData() As String
Dim bData() As Byte
Dim hMem As Long
Dim lSize As Long
Dim lPtr As Long
If (OpenClipboard(0)) Then
If (IsClipboardFormatAvailable(lFormatID) 0) Then
hMem = GetClipboardData(lFormatID)
If (hMem 0) Then
lSize = GlobalSize(hMem)
If (lSize 0) Then
lPtr = GlobalLock(hMem)
If (lPtr 0) Then
ReDim bData(0 To lSize - 1) As Byte
CopyMemory bData(0), ByVal lPtr, lSize
GlobalUnlock hMem
GetCBData = StrConv(bData, vbUnicode)
End If
End If
End If
End If
CloseClipboard
End If
End Function
Public Function IsCBMyFormat() As Boolean
Dim hMem As Long
Dim lSize As Long
Dim lPtr As Long
If (OpenClipboard(0)) Then
If (IsClipboardFormatAvailable(lFormatID) 0) Then
hMem = GetClipboardData(lFormatID)
If (hMem 0) Then
IsCBMyFormat = True
End If
End If
CloseClipboard
End If
End Function
Public Sub SetCBData(ByVal CBText As String)
Dim bData() As Byte
Dim hMem As Long
Dim lSize As Long
Dim lPtr As Long
If (OpenClipboard(0)) Then
bData() = StrConv(CBText & Chr(0), vbFromUnicode)
lSize = GlobalAlloc(GHND, UBound(bData))
If lSize 0 Then
lPtr = GlobalLock(lSize)
CopyMemory ByVal lPtr, bData(0), UBound(bData)
EmptyClipboard '这一句去掉可以使原剪切板中数据保留，自己的数据写入后，并不一定互相影响。

SetClipboardData lFormatID, lPtr
GlobalUnlock lSize
End If
CloseClipboard
End If
End Sub。