首页->技巧->系统->详细内容
发现剪帖板的秘密

概述
Windows 中的Ctrl+C 和Ctrl+V 大家应该很熟悉了， 但是您知道剪帖板里有啥？ 举个例子， 在 IE4中选一段东东，按Ctrl+C， 然后在FrontPage 中按Ctrl+V， 您选的东东完整地拷贝到了FrontPage 中， 字体， 颜色等等。 明显， 剪帖板中一定包含了Html 信息， 而如果我们在编程也要得到这些信息， 该怎么办呢？

本文提供了两种技巧， 一是如何得到关于剪贴格式的名称， 一是如何用文本格式显示剪贴版中特定剪贴格式内容。

在我们的第一个演示中， 利用一个很笨的方法来得到 Html 剪贴格式的名称。 GetClipboardFormatName 可以由剪贴板的ID 得到该格式的名称， 于是用一个循环来查找所有包含Html 文字的格式。

在第二个例子中， 我们使用了在例子一中得到的名称， 把在 IE4 中剪贴的Html 内容合并到一个 TextBox 中， 好让我们知道里面有什么样的信息。

实现步骤
例子一 得到剪贴格式的名称
1 新建一个工程。

2 在工程中增加一个命令按钮(Command1)。

3 增加下面的代码：

Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long

Private Sub Command1_Click()
Dim FormatID As Long
Dim BufferLen As Long
Dim Buffer As String * 80
For FormatID = 50000 To 60000 '一般有效的 ID 在该区内
BufferLen = GetClipboardFormatName(FormatID, Buffer, 80)
If BufferLen > 0 Then
If InStr(UCase(Left(Buffer, BufferLen)), "HTML") > 0 Then MsgBox FormatID & ":" & Buffer
End If
Next
End Sub


4 运行该程序， 可以发现多个带 Html 的格式名称， 经过测试，HTML Format是我们要找的。 注意： 没有 IE4 的话， 可以使用 RTF 进行查询， 以查看 RichText 的剪贴内容。

例子二 得到 IE4 的剪贴内容
1 新建一个工程。

2 在工程中增加一个命令按钮(Command1)， 一个TextBox(Text1)， 允许多行显示。

3 增加下面的代码：

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 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 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)

Public Function GetClipboardIDForCustomFormat(ByVal sName As String) As Long
Dim wFormat As Long
wFormat = RegisterClipboardFormat(sName & Chr$(0))
If (wFormat > &HC000&) Then
GetClipboardIDForCustomFormat = wFormat
End If
End Function

Public Function GetClipboardDataAsString(ByVal hWndOwner As Long, ByVal lFormatID As Long) As String
Dim bData() As Byte
Dim hMem As Long
Dim lSize As Long
Dim lPtr As Long

If (OpenClipboard(hWndOwner)) 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

GetClipboardDataAsString = StrConv(bData, vbUnicode)

End If
End If
End If
End If
CloseClipboard
End If

End Function


Private Sub Command1_Click()
Dim lID As Long
Dim sText As String

' 如果没有 IE4，可以使用 "RTF Format"
lID = GetClipboardIDForCustomFormat("HTML Format")
If (lID <> 0) Then
sText = GetClipboardDataAsString(Me.hWnd, lID)
Text1.Text = sText
End If

End Sub

4 运行该程序。 在IE4 中选任意的东东， 按Ctrl+C， 然后按 Command1， 可以在Text1 中看到如下的内容， 汉字显示问题与 GetClipboardDataAsString = StrConv(bData, vbUnicode) 有关：

Version:1.0
StartHTML:000000213
EndHTML:000000863
StartFragment:000000758
EndFragment:000000772
StartSelection:000000758
EndSelection:000000772
SourceURL:file://G:\FrontPage Webs\Content\vbtt\download.htm
<!DOCTYPE HTML PUBLIC "-//W3C//DTD W3 HTML//EN">
... ...
返回

取得 DOS 环境变量

使用 Environ 函数：
Dim x As Integer
Dim Env As String
x = 1
Env = Environ(x)
Do Until Env = ""
Env = Environ(x)
Debug.Print Env
x = x + 1
Loop
返回

取得汉字的拼音首字

用以下的函数可以得到汉字的拼音首字字符，注意：对 噢、杞、
嘌、呤 是个例外。
对很多汉字无法正确的实现转换，
原因是在该程序根据汉字在编码表中的位置来判断的，
而部分的汉字所在的位置有误，所以 。。。。
Public Function GetPY(a1 As String) As String
Dim t1 As String
If Asc(a1) < 0 Then
t1 = Left(a1, 1)
If Asc(t1) < Asc("啊") Then
GetPY = "0"
Exit Function
End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPY = "A"
Exit Function
End If
If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
GetPY = "B"
Exit Function
End If
If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
GetPY = "C"
Exit Function
End If
If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
GetPY = "D"
Exit Function
End If
If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
GetPY = "E"
Exit Function
End If
If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
GetPY = "F"
Exit Function
End If
If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
GetPY = "G"
Exit Function
End If
If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
GetPY = "H"
Exit Function
End If
If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
GetPY = "J"
Exit Function
End If
If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
GetPY = "K"
Exit Function
End If
If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
GetPY = "L"
Exit Function
End If
If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
GetPY = "M"
Exit Function
End If
If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
GetPY = "N"
Exit Function
End If
If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
GetPY = "O"
Exit Function
End If
If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
GetPY = "P"
Exit Function
End If
If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
GetPY = "Q"
Exit Function
End If
If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
GetPY = "R"
Exit Function
End If
If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
GetPY = "S"
Exit Function
End If
If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
GetPY = "T"
Exit Function
End If
If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
GetPY = "W"
Exit Function
End If
If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
GetPY = "X"
Exit Function
End If
If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
GetPY = "Y"
Exit Function
End If
If Asc(t1) >= Asc("匝") Then
GetPY = "Z"
Exit Function
End If
Else
If UCase(a1) <= "Z" And UCase(a1) >= "A" Then
GetPY = UCase(Left(a1, 1))
Else
GetPY = "0"
End If
End If
End Function
返回

不定个数的参数

如果要传递不定个数的参数给过程，该过程应如下定义：

Sub MySub( ParamArray P() ) '参数定义为一个数组

以下的可能的调用：

MySub "ABC"
MySub 1, 3, 9, 988, 776, 234
MySub 123, "abc", Date()

可用以下的方法来读每个参数：

For i = 0 To UBound(P)
' P(i) 为第 i 个参数
Next
返回

取得应用所在的目录

使用 App.Path 可以得到应用所在的目录。不过得注意，当在根目录下时，Path 的返回值最右字符为 “\” ，如“c:\”，而如果不在根目录，则最右字符非 “\”，如“c:\vb5”。所以在使用 Path 做连接时，应使用以下的代码：

Dim FileName as string
Dim fullpath As String
If Right(App.Path, 1) = "\" Then
fullpath = App.Path + FileName
Else
fullpath = App.Path + "\" + FileName
End If
或者：
pth$ = app.Path & IIf(Len(app.Path) > 3, "\", "")
返回

修改屏幕保护的口令

声明：
Private Declare Function PwdChangePassword Lib "mpr" Alias "PwdChangePasswordA" _
(ByVal lpcRegkeyname As String, ByVal hwnd As Long, ByVal uiReserved1 As _
Long, ByVal uiReserved2 As Long) As Long
使用：
' 出现修改屏幕保护口令的窗口
Call PwdChangePassword("SCRSAVE", Me.hwnd, 0, 0)
返回

使用 API 开始屏幕保护

声明：
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg _
As Long, ByVal wParam As Long, ByVal lParam As Long) _
As Long
Const WM_SYSCOMMAND = &H112&
Const SC_SCREENSAVE = &HF140&
代码：
Dim result As Long
result = SendMessage(Form1.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
返回

取得和设置系统颜色

声明：
Public Const COLOR_SCROLLBAR = 0 '滚动条
Public Const COLOR_BACKGROUND = 1 '桌面背景
Public Const COLOR_ACTIVECAPTION = 2 '活动窗口标题
Public Const COLOR_INACTIVECAPTION = 3 '非活动窗口标题
Public Const COLOR_MENU = 4 '菜单
Public Const COLOR_WINDOW = 5 '窗口背景
Public Const COLOR_WINDOWFRAME = 6 '窗口框
Public Const COLOR_MENUTEXT = 7 '窗口文字
Public Const COLOR_WINDOWTEXT = 8 '3D 阴影 (Win95)
Public Const COLOR_CAPTIONTEXT = 9 '标题文字
Public Const COLOR_ACTIVEBORDER = 10 '活动窗口边框
Public Const COLOR_INACTIVEBORDER = 11 '非活动窗口边框
Public Const COLOR_APPWORKSPACE = 12 'MDI 窗口背景
Public Const COLOR_HIGHLIGHT = 13 '选择条背景
Public Const COLOR_HIGHLIGHTTEXT = 14 '选择条文字
Public Const COLOR_BTNFACE = 15 '按钮
Public Const COLOR_BTNSHADOW = 16 '3D 按钮阴影
Public Const COLOR_GRAYTEXT = 17 '灰度文字
Public Const COLOR_BTNTEXT = 18 '按钮文字
Public Const COLOR_INACTIVECAPTIONTEXT = 19 '非活动窗口文字
Public Const COLOR_BTNHIGHLIGHT = 20 '3D 选择按钮

Declare Function SetSysColors Lib "user32" Alias "SetSysColors" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
Declare Function GetSysColor Lib "user32" Alias "GetSysColor" (ByVal nIndex As Long) As Long
使用：
i =GetSysColors(COLOR_ACTIVECAPTION)
'i 是 RGB 值
i = SetSysColors(1, COLOR_ACTIVECAPTION, RGB(255,0,0))
'把标题设置为红色
返回

改变墙纸

声明：
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
用法：
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, BMP名称, SPIF_UPDATEINIFILE)
例子：
' 1. 把桌面图片设为 c:\windows\setup.bmp
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "c:\windows\setup.bmp", SPIF_UPDATEINIFILE)
' 2. 将桌面图片清除
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "", SPIF_UPDATEINIFILE)
返回

动态改变屏幕设置

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function _
ChangeDisplaySettings Lib _
"User32" Alias "ChangeDisplaySettingsA" (_
ByVal lpDevMode As Long, _
ByVal dwflags As Long) As Long
'函数
Public Function SetDisplayMode(Width As _
Integer,Height As Integer, Color As _
Integer) As Long
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_BITSPERPEL = &H40000
Dim NewDevMode As DEVMODE
Dim pDevmode As Long
With NewDevMode
.dmSize = 122
If Color = -1 Then
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
Else
.dmFields = DM_PELSWIDTH Or _
DM_PELSHEIGHT Or DM_BITSPERPEL
End If
.dmPelsWidth = Width
.dmPelsHeight = Height

If Color <> -1 Then
.dmBitsPerPel = Color
End If
End With
pDevmode = lstrcpy(NewDevMode, NewDevMode)
SetDisplayMode = ChangeDisplaySettings(pDevmode, 0)
End Function
例子调用：改变为 640x480x24位：
i = SetDisplayMode(640, 480, 24)
如果成功返回 0 。参见：X059 改变屏幕到16位彩色的演示
返回

桌面的大小

Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Const SPI_GETWORKAREA = 48

Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Sub Command1_Click()

Dim lRet As Long
Dim apiRECT As RECT

lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, apiRECT, 0)

If lRet Then
Print "Left: " & apiRECT.Left
Print "Top: " & apiRECT.Top
Print "Width: " & apiRECT.Right - apiRECT.Left
Print "Height: " & apiRECT.Bottom - apiRECT.Top
Else
Print "调用 SystemParametersInfo 失败"
End If

End Sub

更新 其他方法：
Sub Command1_Click ()
CR$ = Chr$(13) + Chr$(10)
TWidth% = screen.Width \ screen.TwipsPerPixelX
THeight% = screen.Height \ screen.TwipsPerPixelY

MsgBox "屏幕大小为" + CR$ + CR$ + Str$(TWidth%) + " x" + Str$(THeight%), 64, "Info"
End Sub
返回

Back to top