收藏优快云发的贴子中有的一些代码_public function calcstringex(byval numstr)-优快云博客

本文链接：https://blog.youkuaiyun.com/lang_csdn/article/details/133740

模块声明
Option Explicit
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const CB_RESETCONTENT = &H14B
Public Const CB_SHOWDROPDOWN = &H14F
Public Const CB_LIMITTEXT = &H141
Public Const LB_RESETCONTENT = &H184
'添加check,combo,list,2个按钮
'功能:快速清除,combo自动下拉,限定combo输入字符的长度
Const fast_clear = 1
Const slow_clear = 2
Dim m_iamount As Integer

Private Sub command1_Click()
clearlists (fast_clear)
populatelists
End Sub

Private Sub command2_Click()
clearlists (slow_clear)
populatelists
End Sub
'比较了快速清除和慢速清除
Private Function clearlists(intspeed)
Dim istart As Long
Dim iend As Long
Dim ielapsed As Long
Dim icomboelapsed As Long
Dim ilistelapsed As Long
Dim intret As Integer
Dim intlistcount As Integer
Dim intcounter As Integer

Me.MousePointer = vbHourglass
Select Case intspeed
Case fast_clear
    istart = Timer
    intret = SendMessage(Combo1.hwnd, CB_RESETCONTENT, 1, ByVal 0&)
    iend = Timer
    icomboelapsed = iend - istart


    istart = Timer
    intret = SendMessage(List1.hwnd, LB_RESETCONTENT, 1, ByVal 0&)
    iend = Timer
    ilistelapsed = iend - istart

Case slow_clear
    istart = GetTickCount
    intlistcount = Combo1.ListCount
    For icounter = 0 To intlistcount - 1
        Combo1.RemoveItem intcounter
    Next
    iend = GetTickCount
    icomboelapsed = iend - istart

    istart = GetTickCount
    intlistcount = List1.ListCount
    For icounter = 0 To intlistcount - 1
        List1.RemoveItem intcounter
    Next
    iend = GetTickCount
    ilistelapsed = iend - istart
End Select
Me.MousePointer = vbDefault
MsgBox "清除combo所用的时间: " + Str$(icomboelapsed) + " millsecond"
MsgBox "清除list所用的时间: " + Str$(ilistelapsed) + " millsecond"
End Function
'限定长度
Private Sub check1_Click()
intret = SendMessage(Combo1.hwnd, CB_LIMITTEXT, 10, ByVal 0&)
End Sub
'当获得焦点的时候，combo自动下拉
Private Sub Combo1_GotFocus()
Dim intret As Long
intret = SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&)
End Sub

Private Sub Form_Load()
m_iamount = 500
populatelists
End Sub

Private Sub populatelists()
populatecombo
populitelistbox
End Sub

Private Sub populitelistbox()
Dim icounter As Integer

For icounter = 0 To m_iamount
List1.AddItem "item " + Str$(icounter)
Next
Me.MousePointer = vbDefault
List1.ListIndex = 0
End Sub

Private Sub populatecombo()
Dim icounter As Integer

For icounter = 0 To m_iamount
Combo1.AddItem "item " + Str$(icounter)
Next
Me.MousePointer = vbDefault
Combo1.ListIndex = 0
End Sub

数据库信息
表：test
字段:bh(主键，文本),bb(文本)
数据：
101，2001
102，2001
103，2001
104，2002
105，2002
106，2002
107，2003
107，2003

下面两个按钮分别演示了2种方法从数据库提取信息填充到treeview中
引用microsoft activex data objects 2.x library
Dim nddata As Node
Dim cnn As ADODB.Connection
Dim rs1 As New ADODB.Recordset
Dim rs2 As New ADODB.Recordset

Private Sub Command1_Click()

On Error Resume Next

Set nddata = TreeView1.Nodes.Add(, , "db", "班级信息")
nddata.Expanded = True

Dim intcount As Integer
Dim inttable As Integer
Dim intfield As Integer
Dim intfn As Integer
Dim mtable, fld

rs1.Open "select bb from test group by bb", cnn, 1, 3
inttable = rs1.RecordCount

Do While inttable <> intcount
        Set nddata = TreeView1.Nodes.Add("db", tvwChild, "F" & rs1.Fields("bb"), rs1.Fields("bb"))
        rs2.Open "select bh,bb from test where bb='" & rs1.Fields("bb") & "'", cnn, 1, 3
        intfield = rs2.RecordCount
            If intfield <> 0 Then
                intfn = 0
                    Do While intfield <> intfn
                        Set nddata = TreeView1.Nodes.Add("F" & rs1.Fields("bb"), tvwChild, "S" & rs2.Fields("bh"), rs2.Fields("bh"))
                        rs2.MoveNext
                        intfn = intfn + 1
                    Loop
            End If
            rs2.Close
    rs1.MoveNext
    intcount = intcount + 1
Loop
rs1.Close
End Sub

Private Sub Command2_Click()
On Error Resume Next

Set nddata = TreeView1.Nodes.Add(, , "db", "班级信息")
nddata.Expanded = True

Dim intcount As Integer
Dim inttable As Integer
Dim intfield As Integer
Dim intfn As Integer
Dim mtable, fld
Dim ca As String

rs1.Open "select * from test", cnn, 1, 3
inttable = rs1.RecordCount

Do While Not rs1.EOF
        If ca <> rs1.Fields("bb") Then
        Set nddata = TreeView1.Nodes.Add("db", tvwChild, "F" & rs1.Fields("bb"), rs1.Fields("bb"))
        ca = rs1.Fields("bb")
        End If

        Set nddata = TreeView1.Nodes.Add("F" & rs1.Fields("bb"), tvwChild, "S" & rs1.Fields("bh"), rs1.Fields("bh"))
    rs1.MoveNext
Loop
rs1.Close
End Sub

Private Sub Form_Load()
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=F:/csdn_vb/database/treeview的节点添加/1/article.mdb"

End Sub

Private Sub Form_Unload(Cancel As Integer)
Set con = Nothing
End Sub
经典VBS代码

注销/重起/关闭本地Windows NT/2000 计算机

Sub ShutDown()
Dim Connection, WQL, SystemClass, System

Get connection To local wmi
Set Connection = GetObject("winmgmts:root/cimv2")

Get Win32_OperatingSystem objects - only one object In the collection
WQL = "Select Name From Win32_OperatingSystem"
Set SystemClass = Connection.ExecQuery(WQL)

Get one system object
I think there is no way To get the object using URL?
For Each System In SystemClass
System.Win32ShutDown (2)
Next
End Sub

注销/重起/关闭远程Windows NT/2000 计算机

Sub ShutDownEx(Server, User, Password) Dim Connection, WQL, SystemClass, System Get connection To remote wmi Dim Locator Set Locator = CreateObject("WbemScripting.SWbemLocator") Set Connection = Locator.ConnectServer(Server, "root/cimv2", User, Password) Get Win32_OperatingSystem objects - only one object In the collection WQL = "Select Name From Win32_OperatingSystem" Set SystemClass = Connection.ExecQuery(WQL) Get one system object I think there is no way To get the object using URL? For Each System In SystemClass System.Win32ShutDown (2) NextEnd Sub

上面两段代码都用到了WMI中Win32_OperationSystem的方法Win32ShutDown,Win32ShutDown(flag)中flag的参数可以是下表中的任意一种: 值描述
0 注销
0 + 4 强制注销
1 关机
1 + 4 强制关机
2 重起
2 + 4 强制重起
8 关闭电源
8 + 4 强制关闭电源

使用ADODB.Stream对象写二进制文件

Function SaveBinaryData(FileName, ByteArray)
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2

Create Stream object
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")

Specify stream type - we want To save binary data.
BinaryStream.Type = adTypeBinary

Open the stream And write binary data To the object
BinaryStream.Open
BinaryStream.Write ByteArray

Save binary data To disk
BinaryStream.SaveToFile FileName, adSaveCreateOverWrite
End Function

使用ADODB.Stream对象写文本文件

Function SaveTextData(FileName, Text, CharSet)
Const adTypeText = 2
Const adSaveCreateOverWrite = 2

Create Stream object
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")

Specify stream type - we want To save text/string data.
BinaryStream.Type = adTypeText

Specify charset For the source text (unicode) data.
If Len(CharSet) > 0 Then
BinaryStream.CharSet = CharSet
End If

Open the stream And write binary data To the object
BinaryStream.Open
BinaryStream.WriteText Text

Save binary data To disk
BinaryStream.SaveToFile FileName, adSaveCreateOverWrite
End Function

使用ADODB.Stream对象读二进制文件

Function ReadBinaryFile(FileName)
Const adTypeBinary = 1

Create Stream object
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")

Specify stream type - we want To get binary data.
BinaryStream.Type = adTypeBinary

Open the stream
BinaryStream.Open

Load the file data from disk To stream object
BinaryStream.LoadFromFile FileName

Open the stream And get binary data from the object
ReadBinaryFile = BinaryStream.Read
End Function

使用ADODB.Stream对象读文本文件

Function ReadTextFile(FileName, CharSet)
Const adTypeText = 2

Create Stream object
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")

Specify stream type - we want To get binary data.
BinaryStream.Type = adTypeText

Specify charset For the source text (unicode) data.
If Len(CharSet) > 0 Then
BinaryStream.CharSet = CharSet
End If

Open the stream
BinaryStream.Open

Load the file data from disk To stream object
BinaryStream.LoadFromFile FileName

Open the stream And get binary data from the object
ReadTextFile = BinaryStream.ReadText
End Function

使用FileSystemObject对象写文件

Function SaveBinaryDataTextStream(FileName, ByteArray)
Create FileSystemObject object
Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")

Create text stream object
Dim TextStream
Set TextStream = FS.CreateTextFile(FileName)

Convert binary data To text And write them To the file
TextStream.Write BinaryToString(ByteArray)
End Function
读取和写入Windows的INI文件

Sub WriteINIStringVirtual(Section, KeyName, Value, FileName)
WriteINIString Section, KeyName, Value, _
Server.MapPath(FileName)
End Sub
Function GetINIStringVirtual(Section, KeyName, Default, FileName)
GetINIStringVirtual = GetINIString(Section, KeyName, Default, _
Server.MapPath(FileName))
End Function

Work with INI files In VBS (ASP/WSH)
v1.00
2003 Antonin Foller, PSTRUH Software, http://www.pstruh.cz
Function GetINIString(Section, KeyName, Default, FileName)
Sub WriteINIString(Section, KeyName, Value, FileName)

Sub WriteINIString(Section, KeyName, Value, FileName)
Dim INIContents, PosSection, PosEndSection

Get contents of the INI file As a string
INIContents = GetFile(FileName)

Find section
PosSection = InStr(1, INIContents, "[" & Section & "]", vbTextCompare)
If PosSection>0 Then
Section exists. Find end of section
PosEndSection = InStr(PosSection, INIContents, vbCrLf & "[")
?Is this last section?
If PosEndSection = 0 Then PosEndSection = Len(INIContents)+1

Separate section contents
Dim OldsContents, NewsContents, Line
Dim sKeyName, Found
OldsContents = Mid(INIContents, PosSection, PosEndSection - PosSection)
OldsContents = split(OldsContents, vbCrLf)

Temp variable To find a Key
sKeyName = LCase(KeyName & "=")

Enumerate section lines
For Each Line In OldsContents
If LCase(Left(Line, Len(sKeyName))) = sKeyName Then
Line = KeyName & "=" & Value
Found = True
End If
NewsContents = NewsContents & Line & vbCrLf
Next

If isempty(Found) Then
key Not found - add it at the end of section
NewsContents = NewsContents & KeyName & "=" & Value
Else
remove last vbCrLf - the vbCrLf is at PosEndSection
NewsContents = Left(NewsContents, Len(NewsContents) - 2)
End If

Combine pre-section, new section And post-section data.
INIContents = Left(INIContents, PosSection-1) & _
NewsContents & Mid(INIContents, PosEndSection)
elseif PosSection>0 Then
Section Not found. Add section data at the end of file contents.
If Right(INIContents, 2) <> vbCrLf And Len(INIContents)>0 Then
INIContents = INIContents & vbCrLf
End If
INIContents = INIContents & "[" & Section & "]" & vbCrLf & _
KeyName & "=" & Value
end ifif PosSection>0 Then
WriteFile FileName, INIContents
End Sub

Function GetINIString(Section, KeyName, Default, FileName)
Dim INIContents, PosSection, PosEndSection, sContents, Value, Found

Get contents of the INI file As a string
INIContents = GetFile(FileName)

Separate section contents
sContents = Mid(INIContents, PosSection, PosEndSection - PosSection)

If InStr(1, sContents, vbCrLf & KeyName & "=", vbTextCompare)>0 Then
Found = True
Separate value of a key.
Value = SeparateField(sContents, vbCrLf & KeyName & "=", vbCrLf)
End If
End If
If isempty(Found) Then Value = Default
GetINIString = Value
End Function

Separates one field between sStart And sEnd
Function SeparateField(ByVal sFrom, ByVal sStart, ByVal sEnd)
Dim PosB: PosB = InStr(1, sFrom, sStart, 1)
If PosB > 0 Then
PosB = PosB + Len(sStart)
Dim PosE: PosE = InStr(PosB, sFrom, sEnd, 1)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf, 1)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(sFrom, PosB, PosE - PosB)
End If
End Function

File functions
Function GetFile(ByVal FileName)
Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
Go To windows folder If full path Not specified.
If InStr(FileName, ":/") = 0 And Left (FileName,2)<>"//" Then
FileName = FS.GetSpecialFolder(0) & "/" & FileName
End If
On Error Resume Next

GetFile = FS.OpenTextFile(FileName).ReadAll
End Function

Function WriteFile(ByVal FileName, ByVal Contents)

Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
On Error Resume Next

Go To windows folder If full path Not specified.
If InStr(FileName, ":/") = 0 And Left (FileName,2)<>"//" Then
FileName = FS.GetSpecialFolder(0) & "/" & FileName
End If

Dim OutStream: Set OutStream = FS.OpenTextFile(FileName, 2, True)
OutStream.Write Contents
End Function
更改墙纸
Private 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

Const SPI_SETDESKWALLPAPER = 20

Private Sub Command1_Click()

Dim ChangeWP
Dim s As String
s = "c:/windows/Waves.bmp"
ChangeWP = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, s, 0)

MsgBox "墙纸已经更改为 " & s & "", 64, "Instant Wallpaper Changer"
End Sub
如何调用另一个应用程序中的菜单
用FindWindow找到计算器窗口
用GetMenu获得其菜单句柄
用GetSubMenu获得"查看"菜单项的句柄
用GetMenuItemID得到"科学型"的ID
发送WM_COMMAND到这个计算器窗口

运行此程序，先打开计算器
Option Explicit

Private Declare Function GetMenu Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetMenuItemID Lib "user32.dll" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSubMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Private Const WM_COMMAND As Long = &H111

Private Sub Command1_Click()
    Dim h1 As Long, h2 As Long, id As Long

    h1 = FindWindow(vbNullString, "计算器") '计算器的句柄
    h2 = GetMenu(h1)
    h2 = GetSubMenu(h2, 1)        '"查看"菜單的句柄
    id = GetMenuItemID(h2, 1)     '科学型"的ID
    SendMessage h1, WM_COMMAND, id, ByVal 0&

End Sub
使用api对文件操作
Private Type SHFILEOPSTRUCT
        hwnd As Long
        wFunc As Long       '对文件的操作指令
        pFrom As String     '源文件或路径
        pTo As String       '目的文件或路径
        fFlags As Integer   '操作标志
        fAnyOperationsAborted As Long
        hNameMappings As Long
        lpszProgressTitle As String
End Type

Private Declare Function SHFileOperation Lib _
"shell32" _
(lpFileOp As SHFILEOPSTRUCT) As Long

Const FO_COPY = &H2
Const FO_DELETE = &H3
Const FO_MOVE = &H1
Const FO_RENAME = &H4
Const FOF_ALLOWUNDO = &H40
Const FOF_NOCONFIRMATION = &H10

Private Sub Command1_Click()
    Dim xFile As SHFILEOPSTRUCT

    '复制
    xFile.pFrom = "c:/bbb/*.*"
    xFile.pTo = "c:/aaa"
    xFile.fFlags = FOF_NOCONFIRMATION
    xFile.wFunc = FO_COPY
    xFile.hwnd = Me.hwnd
    If SHFileOperation(xFile) Then
    End If

End Sub

Private Sub Command2_Click()
    Dim xFile As SHFILEOPSTRUCT

    '删除
    xFile.pFrom = "c:/bmp/*.*"
    'xFile.pTo = "c:/"
    xFile.wFunc = FO_DELETE
    xFile.hwnd = Me.hwnd
    '将fFlags设置为FOF_ALLOWUNDO
    '允许被删除的文件放置到回收站中
    xFile.fFlags = FOF_ALLOWUNDO
    If SHFileOperation(xFile) Then
        Debug.Print "Success"
    End If
End Sub

Private Sub Command3_Click()
Dim xFile As SHFILEOPSTRUCT
'更名
xFile.pFrom = "c:/123.doc"
xFile.pTo = "c:/456.doc"
xFile.wFunc = FO_RENAME
xFile.hwnd = Me.hwnd
If SHFileOperation(xFile) Then
End If

'移动
xFile.pFrom = "c:/bmp/eee.bmp"
xFile.pTo = "c:/"
xFile.wFunc = FO_MOVE
xFile.hwnd = Me.hwnd
If SHFileOperation(xFile) Then
End If
End Sub

Option Explicit

Private Sub Command1_Click()
Dim strPathName As String
strPathName = ""
strPathName = InputBox("请输入需要删除的文件夹名称∶", "删除文件夹")
If strPathName = "" Then Exit Sub

On Error GoTo ErrorHandle
SetAttr strPathName, vbNormal '此行主要是为了检查文件夹名称的有效性
RecurseTree strPathName
Label1.Caption = "文件夹" & strPathName & "已经删除！"
Exit Sub
ErrorHandle:
MsgBox "无效的文件夹名称:" & strPathName
End Sub

Sub RecurseTree(CurrPath As String)
Dim sFileName As String
Dim newPath As String
Dim sPath As String
Static oldPath As String

sPath = CurrPath & "/"

sFileName = Dir(sPath, 31) '31的含义∶31=vbNormal+vbReadOnly+vbHidden+vbSystem+vbVolume+vbDirectory
Do While sFileName <> ""
If sFileName <> "." And sFileName <> ".." Then
If GetAttr(sPath & sFileName) And vbDirectory Then '如果是目录和文件夹
newPath = sPath & sFileName
RecurseTree newPath
sFileName = Dir(sPath, 31)
Else
SetAttr sPath & sFileName, vbNormal
Kill (sPath & sFileName)
Label1.Caption = sPath & sFileName '显示删除过程
sFileName = Dir
End If
Else
sFileName = Dir
End If
DoEvents
Loop
SetAttr CurrPath, vbNormal
RmDir CurrPath
Label1.Caption = CurrPath
End Sub
获取硬盘序列号
Option Explicit
'以下这一行是必须的，困为要做结构复制。而结构中有数组。所以，没有它则会错位
Option Base 0

Private Const DFP_GET_VERSION = &H74080
Private Const DFP_SEND_DRIVE_COMMAND = &H7C084
Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088

'#pragma pack(1)
Private Type TGETVERSIONOUTPARAMS   '{
    bVersion As Byte 'Binary driver version.
    bRevision As Byte 'Binary driver revision.
    bReserved As Byte 'Not used.
    bIDEDeviceMap As Byte 'Bit map of IDE devices.
    fCapabilities As Long 'Bit mask of driver capabilities.
    dwReserved(3) As Long 'For future use.
End Type

Private Type TIDEREGS
    bFeaturesReg As Byte   'Used for specifying SMART "commands".
    bSectorCountReg As Byte 'IDE sector count register
    bSectorNumberReg As Byte 'IDE sector number register
    bCylLowReg As Byte    'IDE low order cylinder value
    bCylHighReg As Byte   'IDE high order cylinder value
    bDriveHeadReg As Byte   'IDE drive/head register
    bCommandReg As Byte   'Actual IDE command.
    bReserved As Byte    'reserved for future use. Must be zero.
End Type

Private Type TSENDCMDINPARAMS
    cBufferSize As Long   'Buffer size in bytes
    irDriveRegs As TIDEREGS   'Structure with drive register values.
    bDriveNumber As Byte   'Physical drive number to send 'command to (0,1,2,3).
    bReserved(2) As Byte   'Reserved for future expansion.
    dwReserved(3) As Long   'For future use.
    'bBuffer(0)   As Byte    'Input buffer.
End Type

Private Type TDRIVERSTATUS
    bDriverError As Byte 'Error code from driver, 'or 0 if no error.
    bIDEStatus As Byte 'Contents of IDE Error register.
           'Only valid when bDriverError 'is SMART_IDE_ERROR.
    bReserved(1) As Byte   'Reserved for future expansion.
    dwReserved(1) As Long   'Reserved for future expansion.
End Type

Private Type TSENDCMDOUTPARAMS
    cBufferSize As Long      'Size of bBuffer in bytes
    DRIVERSTATUS As TDRIVERSTATUS   'Driver status structure.
    bBuffer(511) As Byte   'Buffer of arbitrary length
             'in which to store the data read from the drive.
End Type

'下面的结构是要从另一结构复制数据过来的，所以，必须是字节数与VC的完全一致
'而不能用兼容变量，但这里的我们还是用了兼容变量，Integer,因为此结构中这一
'类型的的变量程序中没有用到，如果要用到，建议改为Byte类型。因为VB没有USHORT

Private Type TIDSECTOR
    wGenConfig As Integer
    wNumCyls As Integer
    wReserved As Integer
    wNumHeads As Integer
    wBytesPerTrack As Integer
    wBytesPerSector As Integer
    wSectorsPerTrack As Integer
    wVendorUnique(2) As Integer
    sSerialNumber(19) As Byte
    wBufferType As Integer
    wBufferSize As Integer
    wECCSize As Integer
    sFirmwareRev(7) As Byte
    sModelNumber(39) As Byte
    wMoreVendorUnique As Integer
    wDoubleWordIO As Integer
    wCapabilities As Integer
    wReserved1 As Integer
    wPIOTiming As Integer
    wDMATiming As Integer
    wBS As Integer
    wNumCurrentCyls As Integer
    wNumCurrentHeads As Integer
    wNumCurrentSectorsPerTrack As Integer
    ulCurrentSectorCapacity(3) As Byte   '这里只能用byte，因为VB没有无符号的LONG型变量
    wMultSectorStuff As Integer
    ulTotalAddressableSectors(3) As Byte '这里只能用byte，因为VB没有无符号的LONG型变量
    wSingleWordDMA As Integer
    wMultiWordDMA As Integer
    bReserved(127) As Byte
End Type

'/*+++
'Global vars
'---*/
Private vers As TGETVERSIONOUTPARAMS
Private in_data As TSENDCMDINPARAMS
Private out_data As TSENDCMDOUTPARAMS
Private h As Long
Private i As Long
Private j As Byte

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(LpVersionInformation As OSVERSIONINFO) As Long

Private Const VER_PLATFORM_WIN32S = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2

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 Const CREATE_NEW = 1
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2

Private Type OVERLAPPED
    Internal As Long
    InternalHigh As Long
    offset As Long
    OffsetHigh As Long
    hEvent As Long
End Type

Private Declare Function DeviceIoControl Lib "kernel32" _
    (ByVal hDevice As Long, ByVal dwIoControlCode As Long, _
    lpInBuffer As Any, ByVal nInBufferSize As Long, _
    lpOutBuffer As Any, ByVal nOutBufferSize As Long, _
    lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

'Private Sub CopyRight()
''VC原版权代码（再发行时，请注意采用注解的方式，请不要删除的方式侵权，谢谢！）
''****************************************************************************
'' cerr<<endl<<"HDD identifier v1.0 for WIN95/98/Me/NT/2000. written by Lu Lin"<<endl
'' cerr<<"For more information, please visit Inside Programming: http:'lu0.126.com"<<endl
'' cerr<<"2000.11.3"<<endl<<endl
''****************************************************************************
'Dim StrMsg As String
'StrMsg = StrMsg & "直接从RING3调用API DeviceIoControl()来获取硬盘信息的VB程序 "
'StrMsg = StrMsg & vbCrLf & "VC源作板权信息如下："
'StrMsg = StrMsg & vbCrLf & "***********************************************************"
'StrMsg = StrMsg & vbCrLf & "HDD identifier v1.0 for WIN95/98/Me/NT/2000. written by Lu Lin"
'StrMsg = StrMsg & vbCrLf & "For more information, please visit Inside Programming: http://lu0.126.com"
'StrMsg = StrMsg & vbCrLf & "2000.11.3"
'StrMsg = StrMsg & vbCrLf & "***********************************************************"
'StrMsg = StrMsg & vbCrLf & "VB程序编制：BARDO"
'StrMsg = StrMsg & vbCrLf & "网站：东方热讯：http://www.easthot.net"
'StrMsg = StrMsg & vbCrLf & "邮件：sales@easthot.net"
'StrMsg = StrMsg & vbCrLf & "2003.01.23"
'MsgBox StrMsg
'End Sub

Sub ChangeByteOrder(szString() As Byte, uscStrSize As Long)
    Dim i As Long
    Dim temp As String
     For i = 0 To uscStrSize - 1 Step 2
        temp = szString(i)
        szString(i) = szString(i + 1)
        szString(i + 1) = temp
     Next i
End Sub

Private Function hdid9x(StrHdId As String) As String

'We start in 95/98/Me
h = CreateFile("//./Smartvsd", 0, 0, 0, CREATE_NEW, 0, 0)
If h = 0 Then
    hdid9x = "open smartvsd.vxd failed"
    Exit Function
End If

Dim olp As OVERLAPPED
Dim lRet As Long
Dim lpIn As Long
Dim LpRet As Long

lpIn = 0&
LpRet = i

lRet = DeviceIoControl(h, DFP_GET_VERSION, VarPtr(lpIn), 0, vers, Len(vers), VarPtr(LpRet), olp)
If lRet = 0 Then
        hdid9x = "DeviceIoControl failed:DFP_GET_VERSION"
        CloseHandle (h)
        Exit Function
End If

'If IDE identify command not supported, fails
If (vers.fCapabilities And 1) <> 1 Then
    hdid9x = "Error: IDE identify command not supported."
    CloseHandle (h)
    Exit Function
End If

'Display IDE drive number detected
Dim sPreOutStr As String
sPreOutStr = DetectIDE(vers.bIDEDeviceMap)
hdid9x = sPreOutStr
j = 0
Dim phdinfo As TIDSECTOR
Dim s(40) As Byte

If (j And 1) = 1 Then
    in_data.irDriveRegs.bDriveHeadReg = &HB0
Else
    in_data.irDriveRegs.bDriveHeadReg = &HA0
End If
If (vers.fCapabilities And (16 / (2 ^ j))) = (16 / (2 ^ j)) Then
    'We don't detect a ATAPI device.
    hdid9x = "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"
Else
      in_data.irDriveRegs.bCommandReg = &HEC
      in_data.bDriveNumber = j
      in_data.irDriveRegs.bSectorCountReg = 1
      in_data.irDriveRegs.bSectorNumberReg = 1
      in_data.cBufferSize = 512

      LpRet = i

      lRet = DeviceIoControl(h, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), VarPtr(LpRet), olp)

      If lRet = 0 Then
          hdid9x = "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"
          CloseHandle (h)
          Exit Function
      End If

      Dim StrOut As String

      CopyMemory phdinfo, out_data.bBuffer(0), Len(phdinfo)

      CopyMemory s(0), phdinfo.sSerialNumber(0), 20
      s(20) = 0
      ChangeByteOrder s, 20

      StrHdId = ByteArrToString(s, 20)

End If

'Close handle before quit
CloseHandle (h)
'CopyRight

End Function

限制文本框录入长度
Private Sub Text1_Change()
Const DefineLength = 6          '你允许录入的长度。
    If LenB(StrConv(Text1.Text, vbFromUnicode)) > DefineLength Then
        Text1.Text = Left(Text1.Text, Len(Text1.Text) - 1)
        Text1.SelStart = Len(Text1.Text)
    End If
End Sub

先贴个别的。

' 设置屏幕分辨率及色深

Option Explicit

Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

Private Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Private Const CDS_TEST = &H4
Private Const CDS_UPDATEREGISTRY = &H1
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const EWX_REBOOT = 2

Private Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    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 * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Private Sub Command1_Click()
SetDisplaySettings 800, 600, 16
End Sub

Private Sub Command2_Click()
SetDisplaySettings 1024, 768, 32
End Sub

' 设置屏幕分辨率及色深
' Width 为屏幕宽度, Height 为屏幕高度, ColorDepth 为色深
Function SetDisplaySettings(ByVal Width As Long, ByVal Height As Long, Optional ByVal ColorDepth As Integer) As Boolean
    Dim DevM As DEVMODE, r As Long, answer As Long
    EnumDisplaySettings 0&, 0&, DevM    'DevM收集信息
    DevM.dmFields = IIf(ColorDepth = 0, DM_PELSWIDTH Or DM_PELSHEIGHT, DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL)
    DevM.dmPelsWidth = Width            '屏幕宽度
    DevM.dmPelsHeight = Height          '屏幕高度
    DevM.dmBitsPerPel = ColorDepth      '色深(8,16,32位)
    r = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
    Select Case r
        Case DISP_CHANGE_RESTART
            SetDisplaySettings = True
            answer = MsgBox("你现在必须重新启动计算机，确定吗？", vbYesNo + vbSystemModal + vbQuestion, "重新启动")
            If answer = vbYes Then r = ExitWindowsEx(EWX_REBOOT, 0&)
        Case DISP_CHANGE_SUCCESSFUL
            SetDisplaySettings = True
        Case Else
            SetDisplaySettings = False
    End Select
End Function

Private Sub Form_Load()
Command1.Caption = "800 X 600"
Command2.Caption = "1024 X 768"
End Sub
找到一个模块，还不错，但不是原创的，呵呵，是抄来又修改的

'调用系统“浏览文件夹”对话框的模块，并可选择起始路径
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As String) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long
Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Dim xStartPath As String

Function SelectDir(Optional StartPath As String, _
                   Optional Titel As String) As String
    Dim iBROWSEINFO As BROWSEINFO
    With iBROWSEINFO
        .lpszTitle = IIf(Len(Titel), Titel, "【请选择文件夹】")
        .ulFlags = 7
        If Len(StartPath) Then
        xStartPath = StartPath & vbNullChar
        .lpfnCallback = GetAddressOf(AddressOf CallBack)
        End If
    End With
    Dim xPath As String, NoErr As Long: xPath = Space$(512)
    NoErr = SHGetPathFromIDList(SHBrowseForFolder(iBROWSEINFO), xPath)
    SelectDir = IIf(NoErr, Left$(xPath, InStr(xPath, Chr(0)) - 1), "")
End Function

Function GetAddressOf(Address As Long) As Long
GetAddressOf = Address
End Function

Function CallBack(ByVal hWnd As Long, _
                  ByVal Msg As Long, _
                  ByVal pidl As Long, _
                  ByVal pData As Long) As Long
    Select Case Msg
        Case 1
            Call SendMessage(hWnd, 1126, 1, xStartPath)
        Case 2
            Dim sDir As String * 64, tmp As Long
            tmp = SHGetPathFromIDList(pidl, sDir)
            If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir
    End Select
End Function

'测试代码
Private Sub Command1_Click()
    Dim sPath As String
    sPath = SelectDir("C:/")
    If Len(sPath) Then MsgBox sPath
End Sub
'***************************************************************************************
'程序作者：李绍龙
'建立时间：2004.07.23
'修改人：
'修改时间：
'***************************************************************************************

'模拟删除表格的行
Public Sub DelRow(grid As MSHFlexGrid, Row As Integer)
Dim aCol As Integer
Dim aRow As Integer
If grid.Rows > 2 Then
      If (Row > 0) And (Row < grid.Rows - 1) Then
             With grid
                For aRow = Row To .Rows - 2
                For aCol = 0 To .Cols - 1
                    .TextMatrix(aRow, aCol) = .TextMatrix(aRow + 1, aCol)
                Next
                Next
                .Rows = .Rows - 1
             End With
        Else
         With grid
                   For aRow = Row To .Rows - 1
                   For aCol = 0 To .Cols - 1
                    .TextMatrix(aRow, aCol) = ""
                    Next
                   Next
                .Rows = .Rows - 1
        End With
        End If
    Else
        For aRow = 0 To grid.Cols - 1
           grid.TextMatrix(1, aRow) = ""
        Next
    End If
End Sub
使listview里面的项目不可以移动
Option Explicit
'使listview的项目不移动
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const GWL_WNDPROC = (-4)
Public Const GCL_WNDPROC = (-24)

Public Const LVM_FIRST As Long = &H1000
Public Const LVM_SETITEMPOSITION As Long = LVM_FIRST + 15
Public Const LVM_SETITEMPOSITION32 As Long = LVM_FIRST + 49

Public glDefWindowProc As Long

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    Select Case uMsg
        Case LVM_SETITEMPOSITION, LVM_SETITEMPOSITION32
            WindowProc = 0
        Case Else
            WindowProc = CallWindowProc(glDefWindowProc, hwnd, uMsg, wParam, lParam)
    End Select
End Function
----------------------------------
Private Sub Form_Load()
Dim hwnd As Long
hwnd = ListFTP.hwnd
glDefWindowProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)

End Sub
'生成GUID函数
Public Function GetGuidID() As String
Dim pGuid(16) As Byte
Dim s As String
    s = String(255, " ")
    CoCreateGuid pGuid(0)
    StringFromGUID2 pGuid(0), s, 255
    s = Trim(s)
    GetGuidID = StrConv(s, vbFromUnicode)
End Function