小评KAMIWOW (二)

接上文
WEB应用的特殊性,HTTP请求一般多为短连接,那么如果简单的访问网页来表示目前在线对于一个大量使用无刷新AJAX技术的网站来说显然是不可取的,因此KAMIWOW通过js的timeout功能定时请求ajax来keepon的方式来保持在线,但不知道为什么有人在房间以后就不会在在线列表显示了…这也造成了在线用户觉得偏少但决斗人数挺多的问题
组卡器
用过在线网页卡查的都知道,当结果非常多的时候,网页非常大非常慢,也不是很便于查看,目前我在WEBCARD中用分页来解决,再看KAMIWOW,会发现,当查询结果过多时会让你精确查询条件,于是组卡过程甚至比CGI还要流畅,可惜他的上传卡组功能我一直无法使用,不知道为啥,似乎很多人很正常的使用,当然,LV机制的引入使得用户等级越高能存的卡组越多,细节上相当细腻。当然,如果能有卡组导出就更好了(我是不是跑题了?)
房间功能
列表使用Ajax动态刷新,建立房间也相当友好,每个房间占用空间小,使得页面容量非常高(我该检讨我的设计了?)
比较特别的是房间类型的Matchtype设定很出众,不能设密码(但有看到密码房,也许因为我等级不够)
决斗盘
废话了半天,终于进入正题了,(其实我非常懒),当然,这段正题技术术语比较多,但大多比较基础,如果不懂可以看看百科
于是下面两个问题你有发现吗?
A.下载卡组?
看到这个经常去CGI的人都会觉得很奇怪,卡组为什么还要下载?下到哪里去了?
B.决斗很卡?
用惯NBX的你一定会觉得他决斗操作流畅度很低,是因为服务器太差吗?
详情下回分解!

解决一些.net 程序在 64位 系统下运行的问题

随着Windows 7和WinServer 2k8的推动,很多人都开始换上新系统,当然,也有不少朋友还是用上了64位的操作系统,但是问题也随之而来,本来Dotnet使用IL不需要考虑系统是多少位的,会自动根据系统DotNet框架来选择,但实际上并没有那么简单,于是乎一些.net开发的程序在x64下就开启不能了。
虽然AI_Player君说,没必要解决,但是昨天还是看了一下,了解了错误的类型,错误实际上是一个程序同时使用32位和64位造成的,也就是通过.net编写的程序,系统能够正常的把你使用64位运行,但是你如果你调用了控件,或者其他32位的组件,你的程序就会Crash。
解决思想:
虽然我们无法改变调用组件的类型,但是我们的程序可以强制告诉系统以32位运行(进程管理器中看到后面会标注x32),这样就不会出现在64位和32位同时存在的情况,于是问题解决。

解决方法:
[color=grey]0、确认你的系统是32位系统(是否必须未知)
[b]1、Visual Studio 打开你的项目
2、菜单-》生成-》配置管理器
3、活动解决方案平台下拉框-》新建
4、键入或选择新平台-》 x86-》确认
5、编译你的程序[/b]

[color=blue]特别注意:如此处理出来的程序,如果需要加壳,请确保壳支持x86模式,否则加完壳后此方法失效。
然后把你的程序拿到64位的系统上测试看看吧~
本方法由 SmdCn 在 Windows Server 2008 R2 下测试成功,其他系统暂时不了解
如果你也有遇到类似问题,或者发现本方法由什么问题,欢迎与我交流
Email: smdcn (at) qq.com (at=@)

转-腾讯QQ出现大规模掉线

因为自己的网络非常不好,因此把企鹅扭屁股认为是自己断网,但今天确发现网络没问题依然QQ不能用,于是去CNBETA发现如下信息
据众多热心网友爆料,腾讯QQ大规模掉线,目前仍旧有部分号段无法访问,疑是腾讯服务器出现问题,亦有可能是线路出现问题。目前各大论坛、社区等都有网友发帖称自己无法登陆QQ。腾讯公司尚未就此发表声明。另外有多名网友爆料称所在地区电信网络异常,腾讯QQ可能受此波及。

FilesNet V1.7 注册机

FilesNet是一个高效,简洁的基于.net 1.1 的在线文件管理器,然后只是基于.net 1.1 开发的,但是对于一般在线修改网站已经相当方便了。
这个程序有一段时间没更新了OTL。。
这个程序有一个特点,就是非注册版会在页面底部用Javascript重写标题栏之类的,当然,一般自己用也无所谓,如果你需要和别人一起使用时不喜欢这个,那么就试试这个工具吧,把附件文件传到Filesnet所使用的空间,用需要使用的Filesnet域名访问,
里面会显示FilesLicence,把FilesLicence后面的串(不包括| |)复制到FilesNet文件夹的web.config中即可。
FilesNet 1.7官方下载:http://www.spbdev.com/SiteMessageRead.aspx?id=15
注册工具:下载文件 点击下载此文件

DotNet 异步Socket的实例

在非Dotnet环境,直接使用Winsock的COM空间作这块,而最初在.net作相关开发的时候为了省事,也这么作,但是后来发现COM存在相当多问题,于是只要去研究.net自带的Socket模式,之前一直想写这个程序,但是查阅很多资料,细节都不是很清晰,于是只好自己研究完成了,当然,这边用了许多偷懒的方法,于是还请各位多多指教。
程序是一个一个类的形式完成的。
代码如下:
首先StateObject类,是用作异步信息传递用的,

这边声明了事件,是为了切合原先Winsock的使用习惯(Oh My God…..)
过程Connect,实现主动连接的部分。

监听的处理,这部分是使用同步模式。

开始接受和处理数据的部分

终于要到发送数据了,当然,这边只考虑了发送文本,如果发送文件,直接用文件流写到NetStream的缓冲区,注意一下大小就可以了。

然后补上一些小细节的代码:

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]6longint 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
相关的测试程序代码,贴在附件中。
下载文件