在非Dotnet环境，直接使用Winsock的COM空间作这块，而最初在.net作相关开发的时候为了省事，也这么作，但是后来发现COM存在相当多问题，于是只要去研究.net自带的Socket模式，之前一直想写这个程序，但是查阅很多资料，细节都不是很清晰，于是只好自己研究完成了，当然，这边用了许多偷懒的方法，于是还请各位多多指教。
程序是一个一个类的形式完成的。
代码如下：
首先StateObject类，是用作异步信息传递用的，
这边声明了事件，是为了切合原先Winsock的使用习惯（Oh My God…..）
过程Connect，实现主动连接的部分。
监听的处理，这部分是使用同步模式。
开始接受和处理数据的部分
终于要到发送数据了，当然，这边只考虑了发送文本，如果发送文件，直接用文件流写到NetStream的缓冲区，注意一下大小就可以了。
然后补上一些小细节的代码：
分类： Dev&Maintance
Live SDK,想说爱你不容易
都说比尔时代的微软不懂互联网，目前微软开始在互联网Live起来，也云起来（目前微软云系统CTP已经发布）开始学做web2.0的公司，也开始OPENAPI起来
于是目前微软的LIVE或多或少开发SDK，网络上也多出关于借此敲板腾迅的文章。当然，经过酱油党确认，恩，这真的“影响不大”，确实，微软与此相关的英文SDK在MSDN上可以找到了，当然，这是在微软多次修改地址，让我们碰上404之后找到，在LIVE ID和SEARCH上下足公夫，虽然不能说完美，但很便利的可以直接使用，对于MESSAGE部分，已经可以看到完善的SOAP,JS api已经2.5版了，MSDN重点都在提这个，而忽视了WINFORM开发者，虽然也有给CLASSLIBRARY，但SDK等相关文档确不多，当然也可能我没找到，然而相比之下，第三方开源的DotMsn虽然是基于微软协议的作品，但易用性上却很好，当然，本文仅代表个人愚见。LIVE&DOTNET路还很长，我们有理由相信，将来一切都会更好！
关于我与NBX
很久没更新了，最近确实很忙，于是还是抽空写些，加之之前看了“删除单纯”写的NB系列的历史的帖子，加之近期一些朋友问我一些问题，于是我就说说我的历史问题- –
部分内容会与之前所述之贴有所重复，但为了完整，我还是一一说来，orz。。
Begining
于是，这是一个夏天的故事。。。。这段时间发生两件大事
1、中中因为Code遗失问题，暂停卡查更新
也许这就是我开始关注游戏王相关开发的原因，其实很早就接触VB的我，一直没有相像的作品，长期涉及ASP开发也没有成熟，于是那段时间，我在信息组训练，某人让我做出了关于开发卡查的决定，也就是那时，MC在NW发布时用的名字，cx24，应该从初中到目前的高中，他都一直与我一起，玩牌，编程，测试软件，可以说，he is my best friend and partner，自然我第一进行数据库开放的作品，便是MiniCard。
2、冰伦NB的发布
也基本是在差不多的时候，在NW上我们注意到了NB，便下载下来玩，因为在同一个局域网，连接自然不是难事，但我们产生许多神奇的问题，他的卡片资料在哪里？他是如何对战的？于是最后测试得出结论，所有卡片效果都要手动实现。于是便与冰伦取得联系，合作开发，那时，为了方便对战时的卡组构成，我对 MiniCard进行改进，便提出了当时看似无聊，现在许多人都在做的——组卡，由于冰伦长期比较忙，因此NB的更新缓慢，所以我也专注与MC的设计和 NB的数据结构处理。当然，这也是我目前都热衷Socket模式对战的原因
PS：需要注意，当时NB的开发之初便是全场的，因此当初NB设计已经相当不简单了- –
暂时的离开
也就是在那时，MC的开发停止了3个月左右，因为中考，所以只能选择了离开，而就在这时，应该就是NBQ的时代，这段时间的故事，炎更了解，从他那听来许多，于是我只能简单说说
1、为什么有NBQ
NBQ是基于QQ进行信息传输的，这也是之前NBX的模式，他自然是由冰伦首先提出这个概念，但由于他的处理方式不够完善，因此稳定性不是很好。
2、DK与炎的加入
传说中的炎创建了这个团队，当然DK也基本随炎加入，而我的加入则是在中考结束之后了。当然，他们的加入给NBQ带来的影响就是稳定性更好（orz）界面更美观，当然，这也和炎用了另外一种（也就是目前NBX在用的）截取QQ消息的方式，当然，这次的更新，使得NBQ火爆起来，于是这个团队也便有所名目出来。
在工作室成立的日子里 Legend
关于NBQ全场版与NBX。
当然，此时开始对于NBQ就需要区分炎版和冰版了（因为冰版确实还在更新），当然炎的版本更为大家所知。
自然也是冰首先做出全场版，于是“NBQ全场版”就诞生了，但依然原先的处理方式的稳定性缘故，所以有些不便（当然目前稳定性好了许多）
NBX的计划来源与DK的NB，NBQ大综合的方案，当然，这个名字被炎采用，于是便产生了，炎的全场版NBX。于是很神奇的，原先的计划就那么被无视了- –
[Pascal]Move 在程序设计时的应用
System单元的move过程用来把指定内存段的数据整块复制到另一内存段中，它通常用来成批移动数组元素，使用move进行移动，往往比For一遍来得快些（个人感觉）Move的格式是 move(var Source, Dest; Count: Word)，Source是数据源，Dest是目标内存段，Count是复制的字节数。你不必担心源内存段会和目标内存段重叠或者重合，在这种情况下move仍然能够正确工作，参考下面的样例：
非常感谢AI_Player介绍这种方法，copymem movemem在C语言中非常常见，其实其在Pascal中也很好用
var:
I: Integer;
P: array[0..9] of Longint;
begin
for I := 0 to 9 do P[I] := I;
move(P[4], P[2], 4 * 6); ‘从P[2]移6个longint 到P[4]
for I := 0 to 9 do Writeln(P[I]: 4);
0123456789
0145678989
值得注意的是Count的大小，这与identifier的类型(所占字节数)有关，以下给出参考
|
byte,shortint |
1 |
|
word,integer |
2 |
|
longint |
4 |
|
|
|
|
single |
4 |
|
real |
6 |
|
double,comp |
8 |
|
extended |
10 |
|
|
|
|
char |
1 |
|
boolean |
1 |
|
string |
1(per char)* |
\n
\n
*例 Var a:string ''a:=''12345''; move(a[4],a[1],2); a="45345"
\n
另外，所占字节数不同不能move(不是数组，Count选字节数大的，有时也是可以的)，不同类型不能move，否则会搞得乱七八糟，而往往因move错误地使用造成的 答案错误、死循环 很难发现！
[常用API收藏] 注册表编辑
这几天整理注册表相关的，于是收藏了此模块，相当完善的编辑方法。
标准模块代码:
Option Explicit
Option Compare Text
'---------------------------------------------------------------
'- 注册表 API 声明...
'---------------------------------------------------------------
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPriv As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long 'Used to adjust your program's security privileges, can't restore without it!
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, ByVal lpName As String, lpLuid As LUID) As Long 'Returns a valid LUID which is important when making security changes in NT.
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
'---------------------------------------------------------------
'- 注册表 Api 常数...
'---------------------------------------------------------------
' 注册表创建类型值...
Const REG_OPTION_NON_VOLATILE = 0 ' 当系统重新启动时，关键字被保留
' 注册表关键字安全选项...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_Create_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_Create_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_Create_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_Create_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_Create_LINK + READ_CONTROL
' 返回值...
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0
' 有关导入/导出的常量
Const REG_FORCE_RESTORE As Long = 8&
Const TOKEN_QUERY As Long = &H8&
Const TOKEN_ADJUST_PRIVILEGES As Long = &H20&
Const SE_PRIVILEGE_ENABLED As Long = &H2
Const SE_RESTORE_NAME = "SeRestorePrivilege"
Const SE_BACKUP_NAME = "SeBackupPrivilege"
'---------------------------------------------------------------
'- 注册表类型...
'---------------------------------------------------------------
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type LUID
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges As LUID_AND_ATTRIBUTES
End Type
'---------------------------------------------------------------
'- 自定义枚举类型...
'---------------------------------------------------------------
' 注册表数据类型...
Public Enum ValueType
REG_SZ = 1 ' 字符串值
REG_EXPAND_SZ = 2 ' 可扩充字符串值
REG_BINARY = 3 ' 二进制值
REG_DWORD = 4 ' DWORD值
REG_MULTI_SZ = 7 ' 多字符串值
End Enum
' 注册表关键字根类型...
Public Enum KeyRoot
HKEY_CLASSES_ROOT =\n&H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
Private hKey As Long ' 注册表打开项的句柄
Private i As Long, j As Long ' 循环变量
Private Success As Long ' API函数的返回值, 判断函数调用是否成功
'-------------------------------------------------------------------------------------------------------------
'- 新建注册表关键字并设置注册表关键字的值...
'- 如果 ValueName 和 Value 都缺省, 则只新建 KeyName 空项, 无子键...
'- 如果只缺省 ValueName 则将设置指定 KeyName 的默认值
'- 参数说明: KeyRoot--根类型, KeyName--子项名称, ValueName--值项名称, Value--值项数据, ValueType--值项类型
'-------------------------------------------------------------------------------------------------------------
Public Function SetKeyValue(KeyRoot As KeyRoot, KeyName As String, Optional ValueName As String, Optional Value As Variant = "", Optional ValueType As ValueType = REG_SZ) As Boolean
Dim lpAttr As SECURITY_ATTRIBUTES ' 注册表安全类型
lpAttr.nLength = 50 ' 设置安全属性为缺省值...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
' 新建注册表关键字...
Success = RegCreateKeyEx(KeyRoot, KeyName, 0, ValueType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, hKey, 0)
If Success <> ERROR_SUCCESS Then SetKeyValue = False: RegCloseKey hKey: Exit Function
' 设置注册表关键字的值...
If IsMissing(ValueName) = False Then
Select Case ValueType
Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
Success = RegSetValueEx(hKey, ValueName, 0, ValueType, ByVal CStr(Value), LenB(StrConv(Value, vbFromUnicode)) + 1)
Case REG_DWORD
If CDbl(Value) < = 4294967295# And CDbl(Value) >= 0 Then
Dim sValue As String
sValue = DoubleToHex(Value)
Dim dValue(3) As Byte
dValue(0) = Format("&h" & Mid(sValue, 7, 2))
dValue(1) = Format("&h" & Mid(sValue, 5, 2))
dValue(2) = Format("&h" & Mid(sValue, 3, 2))
dValue(3) = Format("&h" & Mid(sValue, 1, 2))
Success = RegSetValueEx(hKey, ValueName, 0, ValueType, dValue(0), 4)
Else
Success = ERROR_BADKEY
End If
Case REG_BINARY
On Error Resume Next
Success = 1 ' 假设调用API不成功(成功返回0)
ReDim tmpValue(UBound(Value)) As Byte
For i = 0 To UBound(tmpValue)
tmpValue(i) = Value(i)
Next i
Success = RegSetValueEx(hKey, ValueName, 0, ValueType, tmpValue(0), UBound(Value) + 1)
End Select
End If
If Success <> ERROR_SUCCESS Then SetKeyValue = False: RegCloseKey hKey: Exit Function
' 关闭注册表关键字...
RegCloseKey hKey
SetKeyValue = True ' 返回函数值
End Function
'-------------------------------------------------------------------------------------------------------------
'- 获得已存在的注册表关键字的值...
'- 如果 ValueName="" 则返回 KeyName 项的默认值...
'- 如果指定的注册表关键字不存在, 则返回空串...
'- 参数说明: KeyRoot--根类型, KeyName--子项名称, ValueName--值项名称, ValueType--值项类型
'-------------------------------------------------------------------------------------------------------------
Public Function GetKeyValue(KeyRoot As KeyRoot, KeyName As String, ValueName As String, Optional ValueType As Long) As String
Dim TempValue As String &nbs\np; ' 注册表关键字的临时值
Dim Value As String ' 注册表关键字的值
Dim ValueSize As Long ' 注册表关键字的值的实际长度
TempValue = Space(1024) ' 存储注册表关键字的临时值的缓冲区
ValueSize = 1024 ' 设置注册表关键字的值的默认长度
' 打开一个已存在的注册表关键字...
RegOpenKeyEx KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey
' 获得已打开的注册表关键字的值...
RegQueryValueEx hKey, ValueName, 0, ValueType, ByVal TempValue, ValueSize
' 返回注册表关键字的的值...
Select Case ValueType ' 通过判断关键字的类型, 进行处理
Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
TempValue = Left$(TempValue, ValueSize - 1) ' 去掉TempValue尾部空格
Value = TempValue
Case REG_DWORD
ReDim dValue(3) As Byte
RegQueryValueEx hKey, ValueName, 0, REG_DWORD, dValue(0), ValueSize
For i = 3 To 0 Step -1
Value = Value + String(2 - Len(Hex(dValue(i))), "0") + Hex(dValue(i)) ' 生成长度为8的十六进制字符串
Next i
If CDbl("&H" & Value) < 0 Then ' 将十六进制的 Value 转换为十进制
Value = 2 ^ 32 + CDbl("&H" & Value)
Else
Value = CDbl("&H" & Value)
End If
Case REG_BINARY
If ValueSize > 0 Then
ReDim bValue(ValueSize - 1) As Byte ' 存储 REG_BINARY 值的临时数组
RegQueryValueEx hKey, ValueName, 0, REG_BINARY, bValue(0), ValueSize
For i = 0 To ValueSize - 1
Value = Value + String(2 - Len(Hex(bValue(i))), "0") + Hex(bValue(i)) + " " ' 将数组转换成字符串
Next i
End If
End Select
' 关闭注册表关键字...
RegCloseKey hKey
GetKeyValue = Trim(Value) ' 返回函数值
End Function
'-------------------------------------------------------------------------------------------------------------
'- 删除已存在的注册表关键字的值...
'- 如果指定的注册表关键字不存在, 则不做任何操作...
'- 参数说明: KeyRoot--根类型, KeyName--子项名称, ValueName--值项名称
'-------------------------------------------------------------------------------------------------------------
Public Function DeleteKey(KeyRoot As KeyRoot, KeyName As String, Optional ValueName As String) As Boolean
Dim tmpKeyName As String ' 注册表关键字的临时子项名称
Dim tmpValueName As String ' 注册表关键字的临时子键名称
' 打开一个已存在的注册表关键字...
Success = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
If Success <> ERROR_SUCCESS Then DeleteKey = False: RegCloseKey hKey: Exit Function
' 删除已打开的注册表关键字...
tmpKeyName = ""
tmpValueName = KeyName
If ValueName = "" Then &\nnbsp; ' 判断ValueName是否缺省, 如缺省作相应处理
If InStrRev(KeyName, "\\") > 1 Then
tmpValueName = Right(KeyName, InStrRev(KeyName, "\\") + 1)
tmpKeyName = Left(KeyName, InStrRev(KeyName, "\\") - 1)
End If
Success = RegOpenKeyEx(KeyRoot, tmpKeyName, 0, KEY_ALL_ACCESS, hKey)
Success = RegDeleteKey(hKey, tmpValueName)
Else
Success = RegDeleteValue(hKey, ValueName)
End If
If Success <> ERROR_SUCCESS Then DeleteKey = False: RegCloseKey hKey: Exit Function
' 关闭注册表关键字...
RegCloseKey hKey
DeleteKey = True ' 返回函数值
End Function
'-------------------------------------------------------------------------------------------------------------
'- 获得注册表关键字的一些信息...
'- SubKeyName() 注册表关键字的所有子项的名称(注意:最小下标为0)
'- ValueName() 注册表关键字的所有子键的名称(注意:最小下标为0)
'- ValueType() 注册表关键字的所有子键的类型(注意:最小下标为0)
'- CountKey 注册表关键字的子项数量
'- CountValue 注册表关键字的子键数量
'- MaxLenKey 注册表关键字的子项名称的最大长度
'- MaxLenValue 注册表关键字的子键名称的最大长度
'-------------------------------------------------------------------------------------------------------------
Public Function GetKeyInfo(KeyRoot As KeyRoot, KeyName As String, SubKeyName() As String, ValueName() As String, ValueType() As ValueType, Optional CountKey As Long, Optional CountValue As Long, Optional MaxLenKey As Long, Optional MaxLenValue As Long) As Boolean
Dim f As FILETIME
Dim l As Long, s As String
' 打开一个已存在的注册表关键字...
Success = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)
If Success <> ERROR_SUCCESS Then GetKeyInfo = False: RegCloseKey hKey: Exit Function
' 获得一个已打开的注册表关键字的信息...
Success = RegQueryInfoKey(hKey, vbNullString, ByVal 0&, ByVal 0&, CountKey, MaxLenKey, ByVal 0&, CountValue, MaxLenValue, ByVal 0&, ByVal 0&, f)
If Success <> ERROR_SUCCESS Then GetKeyInfo = False: RegCloseKey hKey: Exit Function
If CountKey <> 0 Then
ReDim SubKeyName(CountKey - 1) As String ' 重新定义数组, 使用数组大小与注册表关键字的子项数量匹配
For i = 0 To CountKey - 1
SubKeyName(i) = Space(255)
l = 255
RegEnumKeyEx hKey, i, ByVal SubKeyName(i), l, 0, vbNullString, ByVal 0&, f
SubKeyName(i) = Left(SubKeyName(i), l)
Next i
' 下面的二重循环对字符串数组进行冒泡排序
For i = 0 To UBound(SubKeyName)
For j = i + 1 To UBound(SubKeyName)
If SubKeyName(i) > SubKeyName(j) Then
s = SubKeyName(i)
SubKeyName(i) = SubKeyName(j)
SubKeyName(j) = s
End If
Next j
Next i
End If
If CountValue <> 0 Then
ReDim ValueName(CountValue - 1) As String ' 重新定义数组, 使用数组大小与注册表关键字的子键数量匹配
ReDim ValueType(CountValue - 1) As Long ' 重新定义数组, 使用数组大小与注册表关键字的子键数量匹配
For i = 0 To CountValue - 1
ValueName(i) = Space(255)
l = 255
RegEnumValue hKey, i, ByVal ValueName(i), l, 0, ValueType(i), ByVal 0&, ByVal 0&
ValueName(i) = Left(ValueName(i), l)
Next i
' 下面的二重循环对字符串数组进行冒泡排序
For i = 0 To UBound(ValueName)
For j = i + 1 To UBound(ValueName)
If ValueName(i) > ValueName(j) Then
s = ValueName(i)
ValueName(i) = ValueName(j)
ValueName(j) = s
End If
&\nnbsp; Next j
Next i
End If
' 关闭注册表关键字...
RegCloseKey hKey
GetKeyInfo = True ' 返回函数值
End Function
'-------------------------------------------------------------------------------------------------------------
'- 导出注册表关键字的值
'- 参数说明: KeyRoot--根类型, KeyName--子项名称, FileName--导出的文件路径及文件名(原始数据库格式)
'-------------------------------------------------------------------------------------------------------------
Public Function SaveKey(KeyRoot As KeyRoot, KeyName As String, FileName As String) As Boolean
On Error Resume Next
Dim lpAttr As SECURITY_ATTRIBUTES ' 注册表安全类型
lpAttr.nLength = 50 ' 设置安全属性为缺省值...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
If EnablePrivilege(SE_BACKUP_NAME) = False Then
SaveKey = False
Exit Function
End If
Success = RegOpenKeyEx(KeyRoot, KeyName, 0&, KEY_ALL_ACCESS, hKey)
If Success <> 0 Then
SaveKey = False
Success = RegCloseKey(hKey)
Exit Function
End If
Success = RegSaveKey(hKey, FileName, lpAttr)
If Success = 0 Then SaveKey = True Else SaveKey = False
Success = RegCloseKey(hKey)
End Function
'-------------------------------------------------------------------------------------------------------------
'- 导入注册表关键字的值
'- 参数说明: KeyRoot--根类型, KeyName--子项名称, FileName--导入的文件路径及文件名(原始数据库格式)
'-------------------------------------------------------------------------------------------------------------
Public Function RestoreKey(KeyRoot As KeyRoot, KeyName As String, FileName As String) As Boolean
On Error Resume Next
If EnablePrivilege(SE_RESTORE_NAME) = False Then
RestoreKey = False
Exit Function
End If
Success = RegOpenKeyEx(KeyRoot, KeyName, 0&, KEY_ALL_ACCESS, hKey)
If Success <> 0 Then
RestoreKey = False
Success = RegCloseKey(hKey)
Exit Function
End If
Success = RegRestoreKey(hKey, FileName, REG_FORCE_RESTORE)
If Success = 0 Then RestoreKey = True Else RestoreKey = False
Success = RegCloseKey(hKey)
End Function
'-------------------------------------------------------------------------------------------------------------
'- 使注册表允许导入/导出
'-------------------------------------------------------------------------------------------------------------
Private Function EnablePrivilege(seName As String) As Boolean
On Error Resume Next
Dim p_lngRtn As Long
Dim p_lngToken As Long
Dim p_lngBufferLen As Long
Dim p_typLUID As LUID
Dim p_typTokenPriv As TOKEN_PRIVILEGES
Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
p_lngRtn = OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, p_lngToken)
If p_lngRtn = 0 Then
EnablePrivilege = False
Exit Function
End If
If Err.LastDllError <> 0 Then
EnablePrivilege = False
Exit Function
End If
p_lngRtn = LookupPrivilegeValue(0&, seName, p_typLUID)
If p_lngRtn = 0 Then
EnablePrivilege = False
Exit Function
End If
p_typTokenPriv.PrivilegeCount = 1
p_typTokenPriv.Privileges.Attributes = SE_PRIVILEGE_ENABLED
p_typTokenPriv.Privileges.pLuid = p_typLUID
EnablePrivilege = (AdjustTokenPrivileges(p_lngToken, False, p_typTokenPriv, Len(p_typPrevTokenPriv), p_typPrevTokenPriv, p_lngBufferLen) <> 0)
End Function
'-------------------------------------------------------------------------------------------------------------
'- 将 Double 型( 限制在 0--2^32-1 )的数字转换为十六进制并在前面补零
'- 参数说明: Number--要转换的 Double 型数字
'-------------------------------------------------------------------------------------------------------------
Private Function DoubleToHex(ByVal Number As Double) As String
Dim strHex As String
strHex = Space(8)
For i = 1 To 8
Select Case Number - Int(Number / 16) * 16
Case 10
Mid(strHex, 9 - i, 1) = "A"
Case 11
Mid(strHex, 9 - i, 1) = "B"
Case 12
Mid(strHex, 9 - i, 1) = "C"
&nbs\np; Case 13
Mid(strHex, 9 - i, 1) = "D"
Case 14
Mid(strHex, 9 - i, 1) = "E"
Case 15
Mid(strHex, 9 - i, 1) = "F"
Case Else
Mid(strHex, 9 - i, 1) = CStr(Number - Int(Number / 16) * 16)
End Select
Number = Int(Number / 16)
Next i
DoubleToHex = strHex
End Function
[常用API]一个不含在通用对话框控件中的常用对话框
选择文件夹对话框，在安装程序和软件设置中经常用到，但是神奇的是，如此常用的对话框，却不包含在VB的通用对话框控件中，这也导致了很多人手工设计这个对话框。今天在翻看别人程序的时候，发现他们用到了这个API，于是就写出来分享。
此API在Vista下也测试成功，所以可以正常使用。
API如下：
程序代码 程序代码
Private Declare Function SHBrowseForFolder Lib “shell32.dll” Alias “SHBrowseForFolderA” (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib “shell32.dll” Alias “SHGetPathFromIDListA” (ByVal pidl As Long, ByVal pszPath As String) As Long
相关的测试程序代码，贴在附件中。
下载文件
UTF-8的一些处理
由于一些平台对UTF-8的支持不够，导致程序开发上的一些困难，于是查到一些资料，还是很有意义的。发出来参考一下
支持常见的ANSI、UTF-8、UTF-16LE、UTF-16BE这几种编码文本
Option Explicit 'mTextUTF.bas '模块：UTF文本文件访问 '作者：zyl910 '版本：1.0 '日期：2006-1-23 '== 说明 =================================================== '支持Unicode编码的文本文件读写。暂时支持ANSI、UTF-8、UTF-16LE、UTF-16BE这几种编码文本 '== 更新记录 =============================================== '[V1.0] 2006-1-23 '1.支持最常见的ANSI、UTF-8、UTF-16LE、UTF-16BE这几种编码文本 '## 编译预处理常数 ######################################### '== 全局常数 =============================================== 'IncludeAPILib：引用了API库，此时不需要手动写API声明 '## API #################################################### #If IncludeAPILib = 0 Then '== File =================================================== Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long Private Const INVALID_HANDLE_VALUE = -1 Private Const GENERIC_READ = &H80000000 Private Const GENERIC_WRITE = &H40000000 Private Const FILE_SHARE_READ = &H1 Private Const FILE_SHARE_WRITE = &H2 Private Const Create_NEW = 1 Private Const Create_ALWAYS = 2 Private Const OPEN_EXISTING = 3 Private Const OPEN_ALWAYS = 4 Private Const TRUNCATE_EXISTING = 5 Private Const FILE_ATTRIBUTE_NORMAL = &H80 Private Const FILE_BEGIN = 0 Private Const FILE_CURRENT = 1 Private Const FILE_END = 2 '== Unicode ================================================ Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByRef lpWideCharStr As Any, ByVal cchWideChar As Long) As Long Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpWideCharStr As Any, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByRef lpDefaultChar As Any, ByVal lpUsedDefaultChar As Long) As Long Private Const CP_UTF8 As Long = 65001 #End If '########################################################### 'Unicode编码格式 Public Enum UnicodeEncodeFormat UEF_ANSI = 0 'ANSI+DBCS UEF_UTF8 'UTF-8 UEF_UTF16LE 'UTF-16LE UEF_UTF16BE 'UTF-16BE UEF_UTF32LE 'UTF-32LE UEF_UTF32BE 'UTF-32BE UEF_Auto = -1 '自动识别编码 '隐藏项目 [_UEF_Min] = UEF_ANSI [_UEF_Max] = UEF_UTF32BE End Enum 'ANSI+DBCS方式的文本所使用的代码页。默认为0，表示使用系统当前代码页。可以利用该参数实现读取其他代码编码的文本，比如想在 简体中文平台下 读取 繁体中文平台生成的txt，就将它设为950 Public UEFCodePage As Long '判断BOM '返回值：BOM所占字节 'dwFirst：[in]文件最开始的4个字节 'fmt：[out]返回编码类型 Public Function UEFCheckBOM(ByVal dwFirst As Long, ByRef fmt As UnicodeEncodeFormat) As Long If dwFirst = &HFEFF& Then fmt = UEF_UTF32LE UEFCheckBOM = 4 ElseIf dwFirst = &HFFFE0000 Then fmt = UEF_UTF32BE UEFCheckBOM = 4 ElseIf (dwFirst And &HFFFF&) = &HFEFF& Then fmt = UEF_UTF16LE UEFCheckBOM = 2 ElseIf (dwFirst And &HFFFF&) = &HFFFE& Then fmt = UEF_UTF16BE UEFCheckBOM = 2 ElseIf (dwFirst And &HFFFFFF) = &HBFBBEF Then fmt = UEF_UTF8 UEFCheckBOM = 3 Else fmt = UEF_ANSI UEFCheckBOM = 0 End If End Function '生成BOM '返回值：BOM所占字节 'fmt：[in]编码类型 'dwFirst：[out]文件最开始的4个字节 Public Function UEFMakeBOM(ByVal fmt As UnicodeEncodeFormat, ByRef dwFirst As Long) As Long Select Case fmt Case UEF_UTF8 dwFirst = &HBFBBEF UEFMakeBOM = 3 Case UEF_UTF16LE dwFirst = &HFEFF& UEFMakeBOM = 2 Case UEF_UTF16BE dwFirst = &HFFFE& UEFMakeBOM = 2 Case UEF_UTF32LE dwFirst = &HFEFF& UEFMakeBOM = 4 Case UEF_UTF32BE dwFirst = &HFFFE0000 UEFMakeBOM = 4 Case Else dwFirst = 0 UEFMakeBOM = 0 End Select End Function '判断文本文件的编码类型 '返回值：编码类型。文件无法打开时，返回UEF_Auto 'FileName：文件名 Public Function UEFCheckTextFileFormat(ByVal FileName As String) As UnicodeEncodeFormat Dim hFile As Long Dim dwFirst As Long Dim nNumRead As Long '打开文件 hFile = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, ByVal 0&) If INVALID_HANDLE_VALUE = hFile Then '文件无法打开 UEFCheckTextFileFormat = UEF_Auto Exit Function End If '判断BOM dwFirst = 0 Call ReadFile(hFile, dwFirst, 4, nNumRead, ByVal 0&) nNumRead = UEFCheckBOM(dwFirst, UEFCheckTextFileFormat) 'Debug.Print nNumRead '关闭文件 Call CloseHandle(hFile) End Function '读取文本文件 '返回值：读取的文本。返回vbNullString表示文件无法打开 'FileName：[in]文件名 'fmt：[in,out]使用何种文本编码格式来读取文本。为UEF_Auto时表示自动判断，且在fmt参数返回文本所用编码格式 Public Function UEFLoadTextFile(ByVal FileName As String, Optional ByRef fmt As UnicodeEncodeFormat = UEF_Auto) As String Dim hFile As Long Dim nFileSize As Long Dim nNumRead As Long Dim dwFirst As Long Dim CurFmt As UnicodeEncodeFormat Dim cbBOM As Long Dim cbTextData As Long Dim CurCP As Long Dim byBuf() As Byte Dim cchStr As Long Dim I As Long Dim byTemp As Byte '判断fmt范围 If fmt <> UEF_Auto Then If fmt < [_UEF_Min] or fmt > [_UEF_Max] Then GoTo FunEnd End If End If '打开文件 hFile = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, ByVal 0&) If INVALID_HANDLE_VALUE = hFile Then '文件无法打开 GoTo FunEnd End If '判断文件大小 nFileSize = GetFileSize(hFile, nNumRead) If nNumRead <> 0 Then '超过4GB GoTo FreeHandle End If If nFileSize < 0 Then &#\n39;超过2GB GoTo FreeHandle End If '判断BOM dwFirst = 0 Call ReadFile(hFile, dwFirst, 4, nNumRead, ByVal 0&) cbBOM = UEFCheckBOM(dwFirst, CurFmt) '恢复文件指针 If fmt = UEF_Auto Then '自动判断 fmt = CurFmt 'cbBOM = cbBOM Else '手动设置编码 If fmt = CurFmt Then '若编码相同，则忽略BOM标记 'cbBOM = cbBOM Else '编码不同，那么都是数据 cbBOM = 0 End If End If Call SetFilePointer(hFile, cbBOM, ByVal 0&, FILE_BEGIN) cbTextData = nFileSize - cbBOM '读取数据 UEFLoadTextFile = "" Select Case fmt Case UEF_ANSI, UEF_UTF8 '判断应使用的CodePage CurCP = IIf(fmt = UEF_UTF8, CP_UTF8, UEFCodePage) '分配缓冲区 On Error GoTo FreeHandle ReDim byBuf(0 To cbTextData - 1) On Error GoTo 0 '读取数据 nNumRead = 0 Call ReadFile(hFile, byBuf(0), cbTextData, nNumRead, ByVal 0&) '取得Unicode文本长度 cchStr = MultiByteToWideChar(CurCP, 0, byBuf(0), nNumRead, ByVal 0&, ByVal 0&) If cchStr > 0 Then '分配字符串空间 On Error GoTo FreeHandle UEFLoadTextFile = String$(cchStr, 0) On Error GoTo 0 '取得文本 cchStr = MultiByteToWideChar(CurCP, 0, byBuf(0), nNumRead, ByVal StrPtr(UEFLoadTextFile), cchStr + 1) End If Case UEF_UTF16LE cchStr = (cbTextData + 1) \\ 2 '分配字符串空间 On Error GoTo FreeHandle UEFLoadTextFile = String$(cchStr, 0) On Error GoTo 0 '取得文本 nNumRead = 0 Call ReadFile(hFile, ByVal StrPtr(UEFLoadTextFile), cbTextData, nNumRead, ByVal 0&) '修正文本长度 cchStr = (nNumRead + 1) \\ 2 If cchStr > 0 Then If Len(UEFLoadTextFile) > cchStr Then UEFLoadTextFile = Left$(UEFLoadTextFile, cchStr) End If Else UEFLoadTextFile = "" End If Case UEF_UTF16BE '分配缓冲区 On Error GoTo FreeHandle ReDim byBuf(0 To cbTextData - 1) On Error GoTo 0 '读取数据 nNumRead = 0 Call ReadFile(hFile, byBuf(0), cbTextData, nNumRead, ByVal 0&) If nNumRead > 0 Then '隔两字节翻转相邻字节 For I = 0 To nNumRead - 1 - 1 Step 2 '再-1是为了避免最后多出的那个字节 byTemp = byBuf(I) byBuf(I) = byBuf(I + 1) byBuf(I + 1) = byTemp Next I '取得文本 UEFLoadTextFile = byBuf 'VB允许String中的字符串数据与Byte数组直接转换 End If Case UEF_UTF32LE UEFLoadTextFile = vbNullString '暂时不支持 Case UEF_UTF32BE UEFLoadTextFile = vbNullString '暂时不支持 Case Else Debug.Assert False End Select FreeHandle: '关闭文件 Call CloseHandle(hFile) FunEnd: End Function '保存文本文件 '返回值：是否成功 'FileName：[in]文件名 'sText：[in]欲输出的文本 'IsAppend：[in]是否是添加方式 'fmt：[in,out]使用何种文本编码格式来存储文本。当IsAppend=True时允许UEF_Auto自动判断，且在fmt参数返回文本所用编码格式 'DefFmt：[in]当使用添加模式时，若文件不存在且fmt = UEF_Auto时应使用的编码格式 Public Function UEFSaveTextFile(ByVal FileName As String, _ ByRef sText As String, Optional ByVal IsAppend As Boolean = False, _ Optional ByRef fmt As UnicodeEncodeFormat = UEF_Auto, Optional ByVal DefFmt As UnicodeEncodeFormat = UEF_ANSI) As Boolean Dim hFile As Long Dim nFileSize As Long Dim nNumRead As Long Dim dwFirst As Long Dim cbBOM As Long Dim CurCP As Long Dim byBuf() As Byte Dim cbBuf As Long Dim I As Long Dim byTemp As Byte '判断fmt范围 If IsAppend And (fmt = UEF_Auto) Then Else If fmt < [_UEF_Min] or fmt > [_UEF_Max] Then GoTo FunEnd End If End If '打开文件 hFile = CreateFile(FileName, GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, ByVal 0&, IIf(IsAppend, OPEN_ALWAYS, Create_ALWAYS), FILE_ATTRIBUTE_NORMAL, ByVal 0&) If INVALID_HANDLE_VALUE = hFile Then '文件无法打开 GoTo FunEnd End If '判断文件大小 nFileSize = GetFileSize(hFile, nNumRead) If nFileSize = 0 And nNumRead = 0 Then '文件大小为0字节 IsAppend = False '此时需要写BOM标志 If fmt = UEF_Auto Then fmt = DefFmt End If '判断BOM If IsAppend And (fmt = UEF_Auto) Then dwFirst = 0 Call ReadFile(hFile, dwFirst, 4, nNumRead, ByVal 0&) cbBOM = UEFCheckBOM(dwFirst, fmt) ElseIf IsAppend = False Then cbBOM = UEFMakeBOM(fmt, dwFirst) End If '文件指针定位 Call SetFilePointer(hFile, 0, ByVal 0&, IIf(IsAppend, FILE_END, FILE_BEGIN)) '写BOM If IsAppend = False Then If cbBOM > 0 Then Call WriteFile(hFile, dwFirst, cbBOM, nNumRead, ByVal 0&) End If End If '写文本数据 If Len(sText) > 0 Then Select Case fmt Case UEF_ANSI, UEF_UTF8 '判断应使用的CodePage CurCP = IIf(fmt = UEF_UTF8, CP_UTF8, UEFCodePage) '取得缓冲区大小 cbBuf = WideCharToMultiByte(CurCP, 0, ByVal StrPtr(sText), Len(sText), ByVal 0&, 0, ByVal 0&, ByVal 0&) If cbBuf > 0 Then '分配缓冲区 On Error GoTo FreeHandle ReDim byBuf(0 To cbBuf) On Error GoTo 0 '转换文本 cbBuf = WideCharToMultiByte(CurCP, 0, ByVal StrPtr(sText), Len(sText), byBuf(0), cbBuf + 1, ByVal 0&, ByVal 0&) '写文件 Call WriteFile(hFile, byBuf(0), cbBuf, nNumRead, ByVal 0&) UEFSaveTextFile = True End If Case UEF_UTF16LE '写文件 Call WriteFile(hFile, ByVal StrPtr(sText), LenB(sText), nNumRead, ByVal 0&) UEFSaveTextFile = True Case UEF_UTF16BE '将字符串中的数据复制到byBuf On Error GoTo FreeHandle byBuf = sText On Error GoTo 0 cbBuf = UBound(byBuf) - LBound(byBuf) + 1 '隔两字节翻转相邻字节 For I = 0 To cbBuf - 1 - 1 Step 2 '再-1是为了避免最后多出的那个字节 byTemp = byBuf(I) byBuf(I) = byBuf(I + 1) byBuf(I + 1) = byTemp Next I '写文件 Call WriteFile(hFile, byBuf(0), cbBuf, nNumRead, ByVal 0&) UEFSaveTextFile = True Case UEF_UTF32LE UEFSaveTextFile = False '暂时不支持 Case UEF_UTF32BE UEFSaveTextFile = False '暂时不支持 Case Else Debug.Assert False End Select Else UEFSaveTextFile = True End If FreeHandle: '关闭文件 Call CloseHandle(hFile) FunEnd: End Function