网友收藏的一些关于VB处理的函数

一个调用外部程序，并等待该程序结束后返回控制劝的子程序：
Sub ShellWait(cCommandLine As String)
Dim hShell As Long
Dim hProc As Long
Dim lExit As Long
hShell = Shell(cCommandLine, vbNormalFocus)
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)
Do
   GetExitCodeProcess hProc, lExit
   DoEvents
Loop While lExit = STILL_ACTIVE
End Sub

在读取数据库字段显示到控件中，如果碰到该字段的内容为NULL，则会出错，使用如下方法：
...
Text1.Text = Tab_Cust("cust_name") & ""
...

判断一个文件是否存在：
Function FileExists(filename As String) As Integer
Dim i As Integer
On Error Resume Next
i = Len(Dir$(filename))
If Err Or i = 0 Then FileExists = False Else FileExists = True
End Function

将数据从MsFlexGrid导出到EXCEL，代码最少的方法：
在窗体上添加一个CommandButton,一个Label,一个MsFlexGrid,一个OLE(链接EXCEL)
Private Sub Command1_Click()
Dim Str As String
Dim C As Long
Dim R As Long
OLE1.DoVerb -2
Label2.LinkTopic = "excel.exe|book1"
Label2.LinkMode = 2
For C = 0 To Grid1.Cols - 1
   For R = 0 To Grid1.Rows - 1
      Str = "r" & R + 1 & "c" & C + 1
      Label2.LinkItem = Str
      Label2.Caption = Grid1.TextMatrix(R, C)
      Label2.LinkPoke
   Next
Next
End Sub

使用Image控件显示照片，并将它按比例缩放到一个尺寸内。
Sub ShowPicture(PcitureName As String)
Dim ZX As Single
Dim ZY As Single
With Image1
   .Stretch = False
   .Visible = False
   .Picture = LoadPicture(PictureName)
   ZX = .Width / 155     '假设目标宽度为155像素
   ZY = .Height / 165    '假设目标高度为165像素     
   If ZX > ZY Then
      ZY = ZX
   Else
      ZX = ZY
   End If
   .Stretch = True
   .Width = Int(.Width / ZX)
   .Height = Int(.Height / ZY)
   .Visible = Ture
End With
End Sub

一个利用MsFlexGrid控件作的非常简单的程序，可以输入英文字符和数字，按回车自动右移，支持方向键，可以自动添加行。只用到一个MsFlexGrid控件，没有别的：
Private Sub Form_Load()
Grid1.Rows = 10
Grid1.Cols = 6
End Sub
Private Sub Grid1_KeyDown(KeyCode As Integer, Shift As Integer)
Dim X As Long
Dim Y As Long
Dim L As Long
Dim Tmp As String
X = Grid1.Col
Y = Grid1.Row
Select Case KeyCode
   Case 13
      X = X + 1
      If X >= Grid1.Cols Then
         X = 1
         Y = Y + 1
         If Y >= Grid1.Rows Then Grid1.Rows = Grid1.Rows + 1
      End If
      Grid1.Col = X
      Grid1.Row = Y
   Case 8
      Tmp = Grid1.Text
      L = Len(Tmp) - 1
      If L > -1 Then Grid1.Text = Left(Tmp, L)
   Case Else
      Grid1.Text = Grid1.Text & Chr(KeyCode)
End Select
End Sub

一个获得文件后缀名的子程序,参数可以是一个包含路径的任意文件名：
Function GetLastName(FileName as string) as String
Dim Names
Names = Split(FileName , ".", -1)
GetLastName = Names(UBound(Names))
End Function
第一个方法不好，这样做是比较好的：
Const INFINITE = &HFFFF
Const STARTF_USESHOWWINDOW = &H1
Public Enum enSW
    SW_HIDE = 0
    SW_NORMAL = 1
    SW_MAXIMIZE = 3
    SW_MINIMIZE = 6
End Enum
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
Public Enum enPriority_Class
    NORMAL_PRIORITY_CLASS = &H20
    IDLE_PRIORITY_CLASS = &H40
    HIGH_PRIORITY_CLASS = &H80
End Enum
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

Public Function SuperShell(ByVal App As String, ByVal WorkDir As String, ByVal start_size As enSW, ByVal Priority_Class As enPriority_Class) As Boolean
    Dim PClass As Long
    Dim sinfo As STARTUPINFO
    Dim pinfo As PROCESS_INFORMATION
    'Not used, but needed
    Dim sec1 As SECURITY_ATTRIBUTES
    Dim sec2 As SECURITY_ATTRIBUTES
    'Set the structure size
    sec1.nLength = Len(sec1)
    sec2.nLength = Len(sec2)
    sinfo.cb = Len(sinfo)
    'Set the flags
    sinfo.dwFlags = STARTF_USESHOWWINDOW
    'Set the window's startup position
    sinfo.wShowWindow = start_size
    'Set the priority class
    PClass = Priority_Class
    'Start the program
    If CreateProcess(vbNullString, App, sec1, sec2, False, PClass, _
    0&, WorkDir, sinfo, pinfo) Then
        'Wait
        WaitForSingleObject pinfo.hProcess, INFINITE
        SuperShell = True
    Else
        SuperShell = False
    End If
End Function

Public Function SetAppPriority(Priority_Class As enPriority_Class) As Boolean
Dim hProcess As Long
Dim PClass As Long
PClass = Priority_Class
hProcess = GetCurrentProcess
SetPriorityClass hProcess, PClass
End Function

调用时候这样就可以了：
SuperShell 程序位置, 程序所在文件夹, SW_NORMAL, NORMAL_PRIORITY_CLASS
这段代码演示了用WaitForSingleObject就可以使得当那个程序运行时候不再CPU占用率100%了

我个人觉得处理数据库null值时，适宜用保护函数。
例：

sub test()
dim s as string
s=dfToString(rs("UserName").value)
end sub

'确保返回空字符串或有效转换值
Public Function dfToStr(ByVal StringVar As Variant) As String
    
    On Error GoTo eh

    If Not IsNull(StringVar) Then

        StringVar = CStr(StringVar)
        dfToStr = Trim$(StringVar)

    End If
    exit function
eh:

End Function
获取程序自身路径:
Public Function GetEXEPath() As String
    GetEXEPath = IIf(Right(App.Path, 1) <> "/", App.Path & "/", App.Path)
End Function