启动控制面板大全
启动控制面板大全 98-8-20
启动控制面板：
Dim x
x = Shell("rundll32.exe shell32.dll,Control_RunDLL")

启动辅助选项面板：
常规：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5")
显示：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3")
键盘：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1")
鼠标：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4")
声音：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2")

启动显示设置面板：
背景：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0")
外观：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2")
屏幕保护：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1")
设置：
x = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3")
启动日期和时间设置:
x = Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl")

98-7-04：打开拨号连接：
x= Shell("rundll32.exe rnaui.dll,RnaDial "  &  "连接_名称", 1)

98-8-20 : 打开 IE4 的设置窗口：
x= Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl")

乾隆WinnerPro数据解密

                       乾隆WinnerPro 数据解密

                中国建设银行湖北荆州玉桥支行- 黄国海

---- 朋友有一电脑, 装有乾隆WinnerPro V3.01a 股票分析软件, 可
是没有安装数据接受卡, 但能通过Internet 接到一些免费股市
行情, 问我能不能将其转换为WinnerPro 用数据.胜情难却, 于是,
我找人拷了点WinnerPro 历史数据装入电脑, 借助Ultraedit, 将几
个重要文件的数据结构分析清楚后, 编了个Visual Basic 小
程序, 试用,OK !

---- 通过此方法, 仅需付少许E_mail 的市话费, 鉴于Internet 及股
票的火爆, 将之公布于众, 与大家共享.

---- WinnerPro 有两类数据文件:

---- 1, 日行情数据:

---- 路径:

---- c:\ml30\data\shase\day( 沪市)

---- c:\ml30\data\sznse\day( 深市)

---- 文件名:

---- 股票代号+".day" 如:"500001.day","0021.day".

---- 数据结构: 每个记录由十个字段组成, 分别是:1, 日期2, 开
盘价3, 最高价4, 最低价5, 收盘价6, 成交金额7, 成交量8, 成
交笔数9, 零10, 股本. 每个字段为四字节的长整型, 其中: 日期
格式为YYYYMMDD, 如:19980507, 开盘价, 最高价, 最低价, 收盘价为实
际价格的1000 倍, 成交金额以千元为单位, 成交量以100 股为单
位.

---- 2, 代码库文件:

---- 文件名:

---- c:\ml30\data\shase\sse20a.dat( 债券)

---- c:\ml30\data\shase\sse21a.dat( 沪市)

---- c:\ml30\data\sznse\sse22a.dat( 深市)

---- 数据结构:

---- 每个记录由五个字段组成, 分别是:1, 标识1( 债券取字
符"0", 沪市取"1", 深市取"2") 2, 股票代码(6 个字符, 如:"500001"
,"0021 ") 3, 股票名称(8 个字符) 4, 标识2( 指数取字符"0", 股票则
取"1") 5, 标识3( 指数取2 字节的整型0, 股票取1)

---- 源数据可通过免费邮件获取, 订阅请发邮
件mailto:listserv@city.online.sh.cn 第一行写：subscribe s-fin 取消订
阅, 发信：mailto:qs-fin@city.online.sh.cn, 过去的数据可以在
ftp://ftp.city.online.sh.cn/s-fin/ 上获取.

---- VB 转换程序部分如下：

Private Type ssefile    ‘代码库文件数据结构
   bz1 As String * 1
   dh As String * 6
   mc As String * 8
   bz2 As String * 1
   bz3 As Integer
End Type
Dim sse0num As Integer
Dim sse0last As Long
Dim sse0posi As Long
Dim sse2num As Integer
Dim sse2last As Long
Dim sse2posi As Long
Dim sselen As Integer
Dim sse As ssefile

Private Type szsrc      ‘源数据数据结构
   mc As String * 8
   dh As String * 7
   zspj As String * 7
   kpj As String * 7
   zgj As String * 7
   zdj As String * 7
   zxj As String * 7
   sd As String * 8
   cjl As String * 9
   cjje As String * 10
   qt1 As String * 2
End Type
Dim srcnum As Integer
Dim srcposi As Long
Dim srclast As Long
Dim srclen As Integer

Private Type desfile            ' 日行情数据数据结构
   rq As Long
   kpj As Long
   zgj As Long
   zdj As Long
   spj As Long
   cjje As Long
   cjl As Long
   z1 As Long
   z2 As Long
   z3 As Long
End Type
Dim desrec As desfile
Dim desnum As Integer
Dim desposi As Long
Dim deslast As Long
Dim deslen As Integer

Dim fname As String
Dim srq As String * 8
Dim startrq As Long
Dim findok As Integer
Dim dhnum As Long
Dim coun As Long
Dim Default As String * 1
Dim tmpnum As Integer
Dim posi As Long

Private Sub Command1_Click()
' 转换深股
   Dim srcrec As szsrc
       srclen = Len(srcrec)
   deslen = Len(desrec)
   sselen = Len(sse)
   desrec.z1 = 0
   desrec.z2 = 0
   desrec.z3 = 0
   coun = 0
   Default = "Y"
   Text1.Text = Text1.Text + File1.filename + Chr(13) + Chr(10)
    srq = "19" + Left(File1.filename, 6)
  startrq = Val(srq)
If UCase(InputBox(" 日期:" + srq + Chr(13) + Chr(10)
+ " 请确认(y/n)?", , Default, 50, 50)) <> "Y" Then
       Text1.Text = Text1.Text + " 日期错!" + Chr(13) + Chr(10)
       Exit Sub
   End If
   Text1.Text = " "
   Text1.Text = Text1.Text + Str(startrq) + Chr(13) + Chr(10)
   If Len(srq) <> 8 Or startrq < 19980119 Then
       Text1.Text = Text1.Text + " 日期错!" + Chr(13) + Chr(10)
       Exit Sub
   End If
   Text1.Text = " 正在转换深股..." + Chr(13) + Chr(10)
   srcnum = FreeFile
   ChDrive (Drive1.Drive)
   ChDir (Dir1.Path)
   Open File1.filename For Random As srcnum Len = srclen
   srclast = LOF(srcnum) / srclen
   sse2num = FreeFile
   ChDrive ("d:")
   ChDir ("d:\ml30\data\sznse")
   Open "d:\ml30\data\sznse\sse22a.dat" For Random As sse2num Len = sselen
   sse2posi = 1
   For srcposi = 1 To srclast
       Get srcnum, srcposi, srcrec
       dhnum = Val(srcrec.dh)
       If dhnum < 9000 Then
           sse.bz2 = "1"
           sse.bz3 = 1
           Else
               sse.bz2 = "0"
               sse.bz3 = 0
        End If
If dhnum > 4000 Or dhnum < 1000 Then
       sse.bz1 = "2"
       sse.dh = Right("0000" + Trim(Str(dhnum)), 4) + "  "
       sse.mc = Trim(srcrec.mc)
       Put sse2num, sse2posi, sse
       sse2posi = sse2posi + 1
       fname = "d:\ml30\data\sznse\day\" + Trim(sse.dh) + ".day"
       desnum = FreeFile
       ChDrive ("d:")
       ChDir ("d:\ml30\data\sznse\day")
       Open fname For Random As desnum Len = deslen
       deslast = LOF(desnum) / deslen
       If deslast > 0 Then
           Get desnum, deslast, desrec
       End If
       desrec.spj = CLng(CCur(srcrec.zxj) * 1000)
       desrec.zgj = CLng(CCur(srcrec.zgj) * 1000)
       desrec.zdj = CLng(CCur(srcrec.zdj) * 1000)
       desrec.kpj = CLng(CCur(srcrec.kpj) * 1000)
       desrec.cjl = CLng(srcrec.cjl)
       desrec.cjje = CLng(srcrec.cjje) * 10
   If desrec.zgj <> 0 And (deslast < 1 Or desrec.rq < startrq) Then
       desrec.rq = startrq
       deslast = deslast + 1
       Put desnum, deslast, desrec
       coun = coun + 1
       Text1.Text = " 正在转换深股" + Chr(13) + Chr(10)
       Text1.Text = Text1.Text + Right(fname, 8) + Chr(13) + Chr(10)
   End If
   Close desnum
End If
   Next
   Close srcnum
   Close sse2num
   ChDrive (Drive1.Drive)
   ChDir (Dir1.Path)
   Name File1.filename As Trim(File1.filename) + ".bak"
   Text1.Text = File1.filename + " 转换完毕!" + Chr(13) + Chr(10)
Text1.Text = Text1.Text + " 转换了" + Str(coun) +
" 条记录" + Chr(13) + Chr(10)
End Sub

清除字符串中指定的字符
清除字符串中指定的字符
该函数在字符串 s 中清除 Search（注意：如果 s 为 AAABBB，Search   为 AB。如何？） ：

Function StringCleaner(s As String, Search As String) As String
Dim i As Integer, res As String
res = s
Do While InStr(res, Search)
i = InStr(res, Search)
res = Left(res, i - 1) & Mid(res, i + 1)
Loop
StringCleaner = res
End Function

取得 WAV 文件信息
取得 WAV 文件信息 98-7-04
WAV 文件基本信息包括如是否立体声，采样频率等。
声明：
Public Const RIFF_ID = 1179011410
Public Const RIFF_WAVE = 1163280727
Public Const RIFF_FMT = 544501094
'Typical header of a simple RIFF WAVE file
Public Type WAVInfo
 Riff_Format As Long
 chunk_size As Long
 ChunkID As Long fmt As Long
 Wave_Format As Integer
 Channels As Integer '0 = 单声道, 1 = 立体声
 SamplesPerSecond As Long
 AverageBytesPerSecond As Long '11.025kHz, 22.05kHz, 等
 BlockAlign As Integer 'Size of blocks for low level playback
End Type
函数：
Public Function GetWaveInfo(Byval filename As String, Byref w As WAVInfo) _
As Boolean

Dim ff As Integer
ff = FreeFile

On Error GoTo ehandler
Open filename For Binary Access Read As #ff

On Error GoTo ehandler_fo
Get #ff, , w
Close #ff

On Error GoTo ehandler

If w.Riff_Format = RIFF_ID And w.ChunkID = _
RIFF_WAVE And w.fmt = RIFF_FMT Then

GetWaveInfo = True
Else
GetWaveInfo = False
End If

Exit Function

ehandler_fo:
Close #ff
ehandler:
GetWaveInfo = False
End Function

取得并设置双击间隔时间
取得并设置双击间隔时间 98-7-05
取得双击间隔时间：
Declare Function GetDoubleClickTime Lib "user32" Alias "GetDoubleClickTime" () As Long
使用：
返回千分之一秒的时间间隔数。
设置双击间隔时间：
Declare Function SetDoubleClickTime Lib "user32" Alias "SetDoubleClickTime" (ByVal wCount As Long) As Long
使用：
wCount 为千分之一秒的时间间隔数

取得长文件名
取得长文件名
Public Function GetLongFilename (ByVal sShortName As String) As String

Dim sLongName As String
Dim sTemp As String
Dim iSlashPos As Integer

'Add \ to short name to prevent Instr from failing
sShortName = sShortName & "\"

'Start from 4 to ignore the "[Drive Letter]:\" characters
iSlashPos = InStr(4, sShortName, "\")

'Pull out each string between \ character for conversion
While iSlashPos
sTemp = Dir(Left$(sShortName, iSlashPos - 1), _
vbNormal + vbHidden + vbSystem + vbDirectory)
If sTemp = "" Then
'Error 52 - Bad File Name or Number
GetLongFilename = ""
Exit Function
End If
sLongName = sLongName & "\" & sTemp
iSlashPos = InStr(iSlashPos + 1, sShortName, "\")
Wend

'Prefix with the drive letter
GetLongFilename = Left$(sShortName, 2) & sLongName

End Function

取得磁盘序列号、卷标和文件系统类型
取得磁盘序列号、卷标和文件系统类型 98-6-30
磁盘序列号在每次软盘或硬盘格式化后都重新生成，并且不回重复。许多程序员用此加密。其实也可以修改该函数，可以得到磁盘卷标和文件系统类型信息。

声明：
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA"     (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize  As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags  As Long, ByVal lpFileSystemNameBuffer As String,  ByVal nFileSystemNameSize As Long) As Long

代码：

Function GetSerialNumber(sRoot As String) As Long
   Dim lSerialNum As Long
   Dim R As Long
   Dim sTemp1 As String, sTemp2 As String
   strLabel = String$(255, Chr$(0))
 '  磁盘卷标
   strType = String$(255, Chr$(0))
 ' 文件系统类型 一般为 FAT
   R = GetVolumeInformation(sRoot, strLabel, Len(strLabel), lSerialNum, 0, 0, strType, Len(strType))
   GetSerialNumber = lSerialNum
 '在 strLabel 中为 磁盘卷标
 '在 strType  中为 文件系统类型
End Function

用法：

当驱动器不存在时，函数返回 0。如果是个非根目录，也将返回 0：

lSerial = GetSerialNumber("c:\")

取得短文件名
取得短文件名
如果要传递文件到老的不支持长文件名的应用，以下的函数可以派上用场：
Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String,  ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Function ShortName(LongPath As String) As String
   Dim ShortPath As String
   Const MAX_PATH = 260
   Dim ret&
   ShortPath = Space$(MAX_PATH)
   ret& = GetShortPathName(LongPath, ShortPath, MAX_PATH)
   If ret& Then
       ShortName = Left$(ShortPath, ret&)
   End If
End Function

取得汉字的拼音首字
取得汉字的拼音首字 98-7-31
用以下的函数可以得到汉字的拼音首字字符，注意：对 噢、杞、
嘌、呤 是个例外。
对很多汉字无法正确的实现转换，
原因是在该程序根据汉字在编码表中的位置来判断的，
而部分的汉字所在的位置有误，所以 。。。。
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

取得和设置系统颜色
取得和设置系统颜色 98-7-07
声明：
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))
'把标题设置为红色