建立多级目录
建立多级目录 98-6-16
Sub CreateLongDir(sDrive As String, sDir As String)
Dim sBuild As String

While InStr(2, sDir, "\") > 1
sBuild = sBuild & left(sDir, InStr(2, sDir, "\") - 1)
sDir = Mid(sDir, InStr(2, sDir, "\"))
If Dir(sDrive & sBuild, 16) = "" Then
MkDir sDrive & sBuild
End If
Wend
End Sub

建立和删除一个 DSN
建立和删除一个 DSN
1. 增加声明:

Private Const ODBC_ADD_DSN = 1 ' Add data source
Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source
Private Const ODBC_REMOVE_DSN = 3 ' Remove data source
Private Const vbAPINull As Long = 0& ' NULL Pointer

Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long

2. 新增加一个 DSN

Dim intRet As Long
Dim strDriver As String
Dim strAttributes As String

'设置数据库类别 这里是 SQL Server
strDriver = "SQL Server"
'null 结尾的参数
'请看相关文档
strAttributes = "SERVER=SomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=pubs" & Chr$(0)
strAttributes = strAttributes & "UID=sa" & Chr$(0)
strAttributes = strAttributes & "PWD=" & Chr$(0)
'如果要显示对话，可使用 Form1.Hwnd 代替 vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)
If intRet Then
MsgBox "DSN 建立"
Else
MsgBox "失败"
End If

3. 删除一个 DSN

Dim intRet As Long
Dim strDriver As String
Dim strAttributes As String

strDriver = "SQL Server"
strAttributes = "DSN=DSN_TEMP" & Chr$(0)
intRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, strDriver, strAttributes)
If intRet Then
MsgBox "DSN 删除"
Else
MsgBox "失败"
End If

建立可下拉选择的属性
建立可下拉选择的属性
例如在 BorderStyle 中有以下的四个选择：
0 - None
1 - Dashed
2 - Single Line
3 - Double Line
4 - 3D
首先在控件中定义以下的集合：
Enum BorderType
   None
   Dashed
   [Single Line]
   [Double Line]
   [3D]
End Enum
然后就可以把属性的类型设置好：
Public Property Get BorderStyle() As BorderType
   Border = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As BorderType)
   m_BorderStyle = New_BorderStyle
   PropertyChanged "BorderStyle"
End Property

建立快捷方式
建立快捷方式
Private Declare Function fCreateShellLink Lib "vb5stkit.DLL" (ByVal _
lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal _
lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long

Private Sub MakeShortCuts()

Dim lReturn As Long
Dim MyPath As String
Dim MyName As String
MyPath = App.Path
MyName = App.EXEName
'增加到桌面
lReturn = fCreateShellLink("..\..\Desktop", _
"Shortcut to Net Timer", MyPath & "\" & MyName, "")
'增加到启动组
lReturn = fCreateShellLink("\启动", "Shortcut to Net Timer", _
MyPath & "\" & MyName, "")

End Sub

交换鼠标按钮
交换鼠标按钮 98-7-05
声明：
Declare Function SwapMouseButton Lib "user32" Alias "SwapMouseButton" (ByVal bSwap As Long) As Long
使用：
bSwsp 值为 True ， 为交换状态，即左手习惯。
bSwsp 值为 False， 为正常状态，即右手习惯

借用Windows系统的标准ABOUT窗口
ABOUT窗口是应用程序向用户传达自身一些基本信息的最佳方式。Windows系统的许多软件，如程序管理器、文件管理器、书写器等，都带有一个风格一致的ABOUT窗口。在这些软件中，只要选择“帮助”菜单命令“关于XXX．．．”，就会弹出这个标准ABOUT窗口，其中显示有关Windows及相应软件的版本、工作方式和版权等信息。在VB应用程序中，可以通过调用API函数ShellAbout，方便地借用这个标准ABOUT窗口，并将自己的基本信息加入其中。

　　首先，在module文件中加入下列声明语句：

　　Declare Function ExtractIcon% Lib "shell.dll" (ByVal hinst%, ByVal lpszExeName$，ByVal iIcon%)

　　Declare Function GetWindowWord Lib "User"( ByVal hWnd As Integer，ByVal nIndex As Integer)As Integer

　　Declare Function ShellAbout Lib "shell.dll"(ByVal hWnd As Integer，ByVal szApp As String，ByVal szOtherStuff As String，ByVal hIcon As Integer)As Integer

　　Public Const GWL_EXSTYLE=(－20)

　　Public Const GWL_STYLE=(－16)

　　Public Const GWL_WNDPROC=(－4)

Public Const GWW_HINSTANCE=(－6)

　　然后，在调用ABOUT窗口的菜单项的Click事件中加入下列代码：

　　Dim Ret As Integer

　　Dim Icon As Integer

　　Dim Inst As Integer

　　Inst=GetWindowWord(Me.hWnd,GWW_HINSTANCE)

　　'从可执行文件中抽取图标

　　Icon=ExtractIcon(Inst,"DEMO.EXE",0)

　　'调用Windows系统标准ABOUT窗口

　　Ret=ShellAbout (Me.hWnd，"演示程序"，"版权所有［c］1996－1997吴斌" & Chr$(13) & Chr$(10) & "序列号：123456"，Icon)

金额大小写转换
  各位高手：
        本人是VB初学者，想尝试用VB5.0+ACCESS97编写一支票打印管理程序.
   现有一问题:如何将输入的阿拉伯数字转换成中文金额大写,如"123.00"转换
   成"壹佰贰拾叁元整"?
        另外还有一些问题,希望哪位高手能用E—MAIL与我交流，另外有没有类
   似我所要编的程序的范例能供我参考。
                    不胜感激。
                               - sya

答:
   Sya,我来帮你。

   Dim Num_To_Chinese(10) As String

   Sub Init_Chinese()
 
   Num_To_Chinese(0) = "零"
   Num_To_Chinese(1) = "壹"
   Num_To_Chinese(2) = "贰"
   Num_To_Chinese(3) = "叁"
   Num_To_Chinese(4) = "肆"
   Num_To_Chinese(5) = "伍"
   Num_To_Chinese(6) = "陆"
   Num_To_Chinese(7) = "柒"
   Num_To_Chinese(8) = "捌"
   Num_To_Chinese(9) = "玖"

   End Sub

   Function Get_Chinese(ByVal m As Currency) As String

   Dim Pre As integer
   Dim Had_Frist_Num As Boolean
   Dim temp As String

   Init_Chinese

   Pre = 0

   re:
   Select Case m
   Case Is >= 10000000 And m < 100000000
       Had_Frist_Num = True
       temp = Num_To_Chinese(Int(m / 10000000)) & "千"
       Pre = 1
       m = m - Int(m / 10000000) * 10000000
       GoTo re
   Case Is >= 1000000 And m < 10000000
       Had_Frist_Num = True
       temp = temp & Num_To_Chinese(Int(m / 1000000)) & "百"
       Pre = 2
       m = m - Int(m / 1000000) * 1000000
       GoTo re
   Case Is >= 100000 And m < 1000000
       If Not Had_Frist_Num Then
         temp = Num_To_Chinese(Int(m / 100000)) & "拾"
       ElseIf Pre <> 2 Then
          temp = temp & "零" & Num_To_Chinese(Int(m / 100000)) & "拾"
       Else
          temp = temp & Num_To_Chinese(Int(m / 100000)) & "拾"
       End If
       Had_Frist_Num = True
       Pre = 3
       m = m - Int(m / 100000) * 100000
       GoTo re
   Case Is >= 10000 And m < 100000
       If Not Had_Frist_Num Then
        temp = Num_To_Chinese(Int(m / 10000)) & "万"
       ElseIf Pre <> 3 Then
        temp = temp & "零" & Num_To_Chinese(Int(m / 10000)) & "万"
       Else
        temp = temp & Num_To_Chinese(Int(m / 10000)) & "万"
       End If
       Had_Frist_Num = True
       Pre = 4
       m = m - Int(m / 10000) * 10000
       GoTo re
 Case Is >= 1000 And m < 10000
       If Not Had_Frist_Num Then
         temp = temp & Num_To_Chinese(Int(m / 1000)) & "千"
       ElseIf Pre <> 4 Then
        temp = temp & "万零" & Num_To_Chinese(Int(m / 1000)) & "千"
       Else
        temp = temp & Num_To_Chinese(Int(m / 1000)) & "千"
       End If
   
       Had_Frist_Num = True
       Pre = 5
       m = m - Int(m / 1000) * 1000
       GoTo re
   
  Case Is >= 100 And m < 1000
       If Not Had_Frist_Num Then
         temp = temp & Num_To_Chinese(Int(m / 100)) & "百"
       ElseIf Pre <> 4 And Pre < 4 Then
        temp = temp & "万零" & Num_To_Chinese(Int(m / 100)) & "百"
       ElseIf Pre <> 5 Then
         temp = temp & "零" & Num_To_Chinese(Int(m / 100)) & "百"
       Else
       temp = temp & Num_To_Chinese(Int(m / 100)) & "百"
       End If
       Had_Frist_Num = True
       Pre = 6
       m = m - Int(m / 100) * 100
       GoTo re
 Case Is >= 10 And m < 100
       If Not Had_Frist_Num Then
         temp = temp & Num_To_Chinese(Int(m / 10)) & "拾"
       ElseIf Pre <> 4 And Pre < 4 Then
         temp = temp & "万零" & Num_To_Chinese(Int(m / 10)) & "拾"
       ElseIf Pre <> 6 Then
         temp = temp & "零" & Num_To_Chinese(Int(m / 10)) & "拾 "
       Else
        temp = temp & Num_To_Chinese(Int(m / 10)) & "拾"
       End If
       Had_Frist_Num = True
       Pre = 7
       m = m - Int(m / 10) * 10
       GoTo re
 Case Is >= 1 And m < 10
       If Not Had_Frist_Num Then
         temp = temp & Num_To_Chinese(Int(m)) & "元"
       ElseIf Pre <> 4 And Pre < 4 Then
        temp = temp & "万零" & Num_To_Chinese(Int(m)) & "元"
       ElseIf Pre <> 7 Then
         temp = temp & "零" & Num_To_Chinese(Int(m)) & "元"
       Else
        temp = temp & Num_To_Chinese(Int(m)) & "元"
       End If
       Had_Frist_Num = True
       Pre = 8
       m = m - Int(m)
       GoTo re
  Case Is >= 0.1  
       If Not Had_Frist_Num Then
         temp = temp & Num_To_Chinese(Int(m * 10)) & "角"
       ElseIf Pre <> 4 And Pre < 4 Then
           temp = temp & "万零" & Num_To_Chinese(Int(m * 10)) & "角"
       ElseIf Pre <> 8 Then
         temp = temp & "元零" & Num_To_Chinese(Int(m * 10)) & "角"
       Else
          temp = temp & Num_To_Chinese(Int(m * 10)) & "角"
       End If
       Pre = 9
       m = m - Int(m * 10) / 10
       GoTo re:
 Case Is >= 0.01
       If m <> 0 Then
        If Not Had_Frist_Num Then
          temp = temp & Num_To_Chinese(Int(m * 100)) & "分"
        ElseIf Pre <> 4 And Pre < 4 Then
         temp = temp & "万零" & Num_To_Chinese(Int(m * 100)) & "分"
        ElseIf Pre <> 8 And Pre <> 9 Then
         temp = temp & "元零" & Num_To_Chinese(Int(m * 100)) & "分"
        Else
        temp = temp & Num_To_Chinese(Int(m * 100)) & "分"
        End If
       End If
       Pre = 10
   End Select
   temp = Trim(temp)
   Get_Chinese = temp
End Function

   赶制品，不够简练，多包涵。
   调用格式：Get_Chinese( m as currency)
   最多到千万，很容易扩充。
   Ok?
                              -----zxf 98/05/21

禁止任务切换

Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Integer, ByVal aBOOL As Integer) As Integer
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Integer) As Integer
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Integer) As Integer
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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

Private TaskBarhWnd As Long
Private IsTaskBarEnabled As Integer
Private TaskBarMenuHwnd As Integer
'禁止或允许使用 Alt-Tab
Sub FastTaskSwitching(bEnabled As Boolean)
Dim X As Long, bDisabled As Long
bDisabled = Not bEnabled
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub
'禁止使用Ctrl-Alt-Del
Public Sub DisableTaskBar()
Dim EWindow As Integer
TaskBarhWnd = FindWindow("Shell_traywnd", "")
If TaskBarhWnd <> 0 Then
EWindow = IsWindowEnabled(TaskBarhWnd)
If EWindow = 1 Then
IsTaskBarEnabled = EnableWindow(TaskBarhWnd, 0)
End If
End If
End Sub
'允许使用Ctrl-Alt-Del
Public Sub EnableTaskBar()
If IsTaskBarEnabled = 0 Then
IsTaskBarEnabled = EnableWindow(TaskBarhWnd, 1)
End If
End Sub

98-7-22 禁止 Ctrl+Alt+Del
声明(For Win95)：
Const SPI_SCREENSAVERRUNNING = 97
Private Declare Function SystemParametersInfo Lib "user32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, _
lpvParam As Any, ByVal fuWinIni As Long) As Long
使用：
'禁止
Dim pOld As Boolean
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, pOld, 0)
'开启
Dim pOld As Boolean
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, pOld, 0)

禁止使用 Alt+F4 关闭窗口
禁止使用 Alt+F4 关闭窗口 98-8-21
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Const MF_BYPOSITION = &H400&

Private Sub Form_Load()
Dim hwndMenu As Long
Dim c As Long
hwndMenu = GetSystemMenu(Me.hwnd, 0)

c = GetMenuItemCount(hwndMenu)
'slet det nederste menupunkt ("LUK ALT+F4")

DeleteMenu hwndMenu, c - 1, MF_BYPOSITION

c = GetMenuItemCount(hwndMenu)
'slet det nederste menupunkt ("Skillelinje")
DeleteMenu hwndMenu, c - 1, MF_BYPOSITION

End Sub

开启文件属性窗口
开启文件属性窗口 98-8-22
声明：
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type

Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400

Declare Function ShellExecuteEX Lib "shell32.dll" Alias _
"ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long

代码：
' 使用： ShowProps("c:\command.com",Me.hWnd)
Public Sub ShowProps(FileName As String, OwnerhWnd As Long)
Dim SEI As SHELLEXECUTEINFO
Dim r As Long
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or _
SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = OwnerhWnd
.lpVerb = "properties"
.lpFile = FileName
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
End With
r = ShellExecuteEX(SEI)
End Sub