'VB也可以使用CallBack，下面是一个例子：
'先把下面的代码放入BAS模块：
Option Explicit

'common to both methods
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Public Declare Function SHBrowseForFolder Lib _
"shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long

Public Declare Function SHGetPathFromIDList Lib _
"shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

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 Declare Sub MoveMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)

Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1

'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.

'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)

'If the lParam parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)

'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SelectIONCHANGED
'message.
Public Const BFFM_SETSelectIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSelectIONW As Long = (WM_USER + 103)


'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
"shell32" Alias "#162" _
(ByVal szPath As String) As Long


'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long

Public Declare Function LocalFree Lib "kernel32" _
(ByVal hMem As Long) As Long

Public Declare Function lstrcpyA Lib "kernel32" t color="#000000">_
(lpString1 As Any, lpString2 As Any) As Long

Public Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)


Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long

'Callback for the Browse STRING method.

'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.

Select Case uMsg
Case BFFM_INITIALIZED

Call SendMessage(hWnd, BFFM_SETSelectIONA, _
True, ByVal StrFromPtrA(lpData))

Case Else:

End Select

End Function


Public Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long

'Callback for the Browse PIDL method.

'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.

Select Case uMsg
Case BFFM_INITIALIZED

Call SendMessage(hWnd, BFFM_SETSelectIONA, _
False, ByVal lpData)

Case Else:

End Select

End Function


Public Function FARPROC(pfn As Long) As Long

'A dummy procedure that receives and returns
'the value of the AddressOf operator.

'Obtain and set the address of the callback
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)

FARPROC = pfn

End Function


Public Function StrFromPtrA(lpszA As Long) As String

'Returns an ANSI string from a pointer to an ANSI string.

Dim sRtn As String
sRtn = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal sRtn, ByVal lpszA)
StrFromPtrA = sRtn

End Function

'--end block--'

'-----------------------------------------------------------------------------------------
'将下面代码加入窗体。窗体上还应放置三个按钮和两个TextBox。
'-----------------------------------------------------------------------------------------
Option Explicit

Private Sub cmdString_Click()
Text2 = ""
Text2 = BrowseForFolderByPath((Text1))
End Sub


Private Sub cmdPIDL_Click()
Text2 = ""
Text2 = BrowseForFolderByPIDL((Text1))
End Sub


Private Sub cmdEnd_Click()
Unload Me
End Sub


Public Function BrowseForFolderByPath(sSelPath As String) As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH

With BI
.hOwner = Me.hWnd
.pidlRoot = 0
.lpszTitle = "Pre-selecting the folder using the folder's string."
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)

lpSelPath = LocalAlloc(LPTR, Len(sSelPath))
MoveMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath)
.lParam = lpSelPath

End With

pidl = SHBrowseForFolder(BI)

If p
idl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If

Call LocalFree(lpSelPath)
End Function


Public Function BrowseForFolderByPIDL(sSelPath As String) As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim sPath As String * MAX_PATH

With BI
.hOwner = Me.hWnd
.pidlRoot = 0
.lpszTitle = "Pre-selecting a folder using the folder's pidl."
.lpfn = FARPROC(AddressOf BrowseCallbackProc)
.lParam = SHSimpleIDListFromPath(sSelPath)
End With

pidl = SHBrowseForFolder(BI)

If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If

Call CoTaskMemFree(BI.lParam)
End Function

Public Function chrConvert(strInput As String, Method As Integer) As String
' Method = 0 for Text to vbChr
' Method = 1 for Text to HTML
' Method = 2 for Text to Hex
' Method = 3 for vbChr to Text
' Method = 4 for HTML to Text
' Method = 5 for Hex to Text
If Method = 0 Or Method = 1 Or Method = 2 Then
chrConvert = ToChr(strInput, Method)
ElseIf Method = 3 Or Method = 4 Or Method = 5 Then
chrConvert = ToTxt(strInput, Method)
End If
End Function

Private Function ToChr(strInput As String, Method As Integer) As String
strTmp = ""

For L = 1 To Len(strInput)
A = Asc(Mid(strInput, L, 1))
If Method = 0 Then
strTmp = strTmp & " & Chr(" & A & ")"
ElseIf Method = 1 Then
strTmp = strTmp & "&#" & A & ";"
ElseIf Method = 2 Then
strTmp = strTmp & "%" & Hex(A)
End If
Next L
If Method = 0 Then strTmp = Right(strTmp, Len(strTmp) - 3)
ToChr = strTmp
End Function

Private Function ToTxt(strInput As String, Method As Integer) As String
strTmp = ""
Dim inChr() As String
Dim F As Integer, ForChr As Integer, tmpInput As String
If Method = 3 Then
strInput = Replace(strInput, ")", "")
strInput = Replace(strInput, " & ", "")
strInput = Replace(strInput, "Chr(", "")
ElseIf Method = 4 Then
strInput = Replace(strInput, "&#", "")
strInput = Replace(strInput, ";", "")
ElseIf Method = 5 Then
strInput = Replace(strInput, "%", "")
End If
inChr = Split(strInput, "")

For F = 1 To ChrNum(strInput)
inChr(F) = AddZeros(3 - Len(inChr(F))) & inChr(F)
tmpInput = tmpInput & inChr(F)
Next F

For L = 1 To Len(tmpInput)
A = Mid(tmpInput, L, 3)
If Method = 5 Then A = Val("&H" & A)
strTmp = strTmp & Chr(A)
L = L + 2
Next L
ToTxt = strTmp
End Function

Private Function ChrNum(strInput As String) As Integer
Dim lngLen As Long, lngFound As Long, lngEnd As Long
ChrNum = 0
lngLen& = Len(strInput$)
lngFound& = InStr(strInput$, "")

Do While lngFound& <> 0
ChrNum = ChrNum + 1
lngFound& = InStr(lngFound& + 1, strInput$, "")
Loop
End Function

Private Function AddZeros(Number As Integer) or="#0000FF">As String
Dim Z As Integer, tmpZeros As String

For Z = 1 To Number
tmpZeros = tmpZeros & "0"
Next Z
AddZeros = tmpZeros
End Function

'此方法不需要引用IShellLink.

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type LNKHEAD
dwID As Long
dwGUID(3) As Long
dwFlags As Long
dwFileAttributes As Long
dwCreationTime As FILETIME
dwModificationTime As FILETIME
dwLastaccessTime As FILETIME
dwFileLen As Long
dwIconNum As Long
dwWinStyle As Long
dwHotkey As Long
dwReserved1 As Long
dwReserved2 As Long
End Type

Private Type FILELOCATIONINFO
dwSize As Long
dwFirstOffset As Long
dwFlags As Long
dwOffsetOfVolume As Long
dwOffsetOfBasePath As Long
dwOffsetOfNetworkVolume As Long
dwOffsetOfRemainingPath As Long
End Type

Private Type LOCALVOLUMETAB
dwSize As Long
dwTypeOfVolume As Long
dwVolumeSerialNumber As Long
dwOffsetOfVolumeName As Long
strVolumeName As Byte
End Type

Private Type NETWORKVOLUMETAB
dwSize As Long
dwUnknown1 As Long
dwOffsetOfNetShareName As Long
dwUnknown2 As Long
dwUnknown3 As Long
strNetShareName As Byte
End Type

Private Const LNK_HASIDLIST = &H1
Private Const LNK_FILEDIR = &H2
Private Const LNK_HASDES = &H4
Private Const LNK_HASPATH = &H8
Private Const LNK_HASWORKDIR = &H10
Private Const LNK_HASCMD = &H20

Private Const LNK_LOCALVOLUME = &H1
Private Const LNK_NETSHARE = &H2

Public Function GetLinkPath(ByVal strShortCut As String) As String
Dim objLinked As LNKHEAD
Dim intNo As Integer, intTmp As Integer
Dim objInfo As FILELOCATIONINFO
Dim intSeek As Integer
Dim bytBuffer() As Byte
intNo = FreeFile
Open strShortCut For Binary As #intNo
Get #intNo, , objLinked
intSeek = Len(objLinked)
If objLinked.dwFlags And LNK_HASIDLIST Then
Get #intNo, , intTmp
Else
Close #intNo
Exit Function
End If
intSeek = Seek(intNo)
intSeek = intSeek + intTmp
Seek #intNo, intSeek
Get #intNo, , objInfo
Seek #intNo, objInfo.dwOffsetOfBasePath + intSeek
If objInfo.dwFlags And LNK_NETSHARE Then
intSeek = objInfo.dwOffsetOfNetworkVolume - objInfo.dwOffsetOfBasePath
Else
intSeek = objInfo.dwOffsetOfRemainingPath - objInfo.dwOffsetOfBasePath
End If
ReDim bytBuffer(intSeek - 1)
Get #intNo, , bytBuffer
Close #intNo
GetLinkPath = StrConv(bytBuffer, vbUnicode)
End Function

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

Sub Command1_Click()
Dim lReturn As Long
'添加到桌面
lReturn = fCreateShellLink("..\..\Desktop","ShortcuttoCalculator","c:\windows\calc.exe","")
'添加到程序组
lReturn = fCreateShellLink("","ShortcuttoCalculator","c:\windows\calc.exe","")
'添加到启动组
lReturn = fCreateShellLink("\Startup","ShortcuttoCalculator","c:\windows\calc.exe","")
End Sub

Public Function ToExcel()
On Error GoTo ErrorHandler

Dim exlapp As Excel.Application
Dim exlbook As Excel.Workbook
Set exlapp = CreateObject("Excel.Application")
Set exlbook = exlapp.Workbooks.Add
exlapp.Caption = "数据正在导出......"
exlapp.Visible = True
exlapp.DisplayAlerts = False

Dim exlsheet As Excel.Worksheet

Set exlsheet = exlbook.Worksheets.Add

exlsheet.Activate
Set exlsheet = exlsheet
exlsheet.Name = "【我导出的数据】"

'设置列宽
exlapp.ActiveSheet.Columns(1).ColumnWidth = 10

exlapp.ActiveSheet.Columns(2).ColumnWidth = 20


StrSql = "【你的SQL语句】"

Set exl_rs = PubSysCn.Execute(StrSql)

exlsheet.Range("A2").CopyFromRecordset exl_rs

exl_rs.Close
Set exl_rs = Nothing

exlapp.Worksheets("sheet1").Delete
exlapp.Worksheets("sheet2").Delete
exlapp.Worksheets("sheet3").Delete
exlapp.DisplayAlerts = True
exlapp.Caption = "数据导出完毕！！"
exlapp.Visible = True

Set exlapp = Nothing
Set exlbook = Nothing
Set exlsheet = Nothing

Exit Function

ErrorHandler:
MsgBox "EXCEL : " & err.Number & " : " & err.Description
End Function

Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

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

Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000

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
Dim DevM As DEVMODE


Sub ChangeRes(iWidth As Single, iHeight As Single)
Dim a As Boolean
Dim i As Integer
Dim b As Long
i = 0
Do
a = EnumDisplaySettings(0&, i, DevM)
i = i + 1
Loop Until (a = False)
DevM.dmFields = DM_PELSWIDTH or DM_PELSHEIGHT
DevM.dmPelsWidth = iWidth
DevM.dmPelsHeight = iHeight
ChangeDisplaySettings DevM, 0
End Sub

Private Sub Command1_Click()
Dim x As String
Dim y As String

If Val(x) <> 1024 or Val(y) <> 768 Then
Call ChangeRes(1024, 768)
End If
x = CStr(GetSystemMetrics(SM_CXSCREEN))
y = CStr(GetSystemMetrics(SM_CYSCREEN))
Me.Caption = "当前显示器分辨率: " & x & "x" & y
End Sub

Private Sub Form_Load()
Dim x As String
Dim y As String
x = CStr(GetSystemMetrics(SM_CXSCREEN))
y = CStr(GetSystemMetrics(SM_CYSCREEN))
Me.Caption = "当前显示器分辨率: " t>& x & "x" & y
Call ChangeRes(800, 600) '将分辨率设置成800*600
End Sub

Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private m_TimerID As Long
Private m_Interval As Long
Private m_Enabled As Boolean

Public Tag As Variant
Public Event Timer()

Public Property Get Interval() As Long
Interval = m_Interval
End Property

Public Property Let Interval(ByVal Value As Long)
m_Interval = Value
Enabled = m_Enabled
End Property

Public Property Get Enabled() As Boolean
Interval = m_Enabled
End Property

Public Property Let Enabled(ByVal Value As Boolean)
If Value Then
m_Enabled = StartTimer
Else
Call StopTimer
End If
End Property

Private Function StartTimer() As Boolean
If m_TimerID = 0 Then
If m_Interval > 0 Then
m_TimerID = SetTimer(0, 0, m_Interval, AddressOf TimeProc)
If m_TimerID <> 0 Then
TimerColl.Add ObjPtr(Me), "ID:" & m_TimerID
StartTimer = True
End If
Else
m_Enabled = True
End If
End If
End Function

Friend Sub PulseTimer()
RaiseEvent Timer
End Sub

Private Sub StopTimer()
If m_TimerID <> 0 Then
KillTimer 0, m_TimerID
TimerColl.Remove "ID:" & m_TimerID
m_TimerID = 0
m_Enabled = False
End If
End Sub

Private Sub Class_Terminate()
Call StopTimer
ont color="#0000FF">End Sub

使用方法：
Private WithEvents Timer1 As Timer
Private Sub Form_Load()
Set Timer1 = New TimerLib.Timer
Timer1.Interval = 1000
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Debug.Print Now
End Sub

方法2：
用SetTimer函数定义一个ID,并标志一个触发时间(以MS为单位)和回调函数地址.
当指定的触发时间到了,系统就会调用那个指定的回调函数,并以你在SetTimer时定义的ID为参数,这样就可以区别多个定时器了.
当不需要使用某个定时器时,就使用KillTimer函数把指定ID的定时器干掉就可以了.
窗体代码：

Option Explicit

Const GWL_WNDPROC = (-4)

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private Sub Form_Load()
glngFuncAdd = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc_TimerTest)
Call SetTimer(hWnd, TIMERID, 500, 0&)
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If glngFuncAdd > 0 Then Call SetWindowLong(hWnd, GWL_WNDPROC, glngFuncAdd)
Call KillTimer(hWnd, TIMERID)
End Sub

模块代码：

Option Explicit

Const WM_TIMER = &H113

Public Const TIMERID = &H100 '自定义Timer的ID号

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public glngFuncAdd As Long

Public Function WndProc_TimerTest(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If wMsg = WM_TIMER Then
If wParam = TIMERID Then
Debug.Print Timer
End If
End If

WndProc_TimerTest = CallWindowProc(glngFuncAdd, hWnd, wMsg, wParam, lParam)
End Function

　　程序思想:用Select name From sysobjects Where xtype = 'u'得到所有表，然后循环打开表，根据 Rs_Colums.Fields(I).Name 得到字段名， FieldType(Rs_Colums.Fields(I).Type) 得到字段类型， Rs_Colums.Fields(I).DefinedSize 宽度
　　由于Rs_Colums.Fields(I).Type返回类型是数字，程序中写了一个FieldType函数转化成中文类型。

Private Sub Command1_Click()
　Dim Cn As New ADODB.Connection
　Dim Rs_Table As New ADODB.Recordset
　Dim Rs_Colums As New ADODB.Recordset
　　
　With Cn　 '定义连接
　　.CursorLocation = adUseClient
　　.Provider = "sqloledb"
　　.Properties("Data Source").Value = "LIHG"
　　.Properties("Initial Catalog").Value = "NorthWind"
　　.Properties("User ID") = "sa"
　　.Properties("Password") = "sa"
　　.Properties("prompt") = adPromptNever
　　.ConnectionTimeout = 15
　　.Open
　　
　　If .State = adStateOpen Then
　　Rs_Table.CursorLocation = adUseClient　 '得到所有表名
　　Rs_Table.Open "Select name From sysobjects Where xtype = 'u'", Cn, adOpenDynamic, adLockReadOnly
　　Rs_Table.MoveFirst
　　Do While Not Rs_Table.EOF
　　Debug.Print Rs_Table.Fields("name")
　　Rs_Colums.CursorLocation = adUseClient
　　Rs_Colums.Open "select top 1 * from [" & Rs_Table.Fields("name") & "]", Cn, adOpenStatic, adLockReadOnly
　　For I = 0 To Rs_Colums.Fields.Count - 1　 ' 循环所有列
　　Debug.Print Rs_Colums.Fields(I).Name　 '字段名
　　Debug.Print FieldType(Rs_Colums.Fields(I).Type)　'字段类型
　　Debug.Print Rs_Colums.Fields(I).DefinedSize　'宽度
　　Next
　　Rs_Colums.Close
　　Rs_Table.MoveNext
　　Loop
　　Rs_Table.Close
　　Set Rs_Colums = Nothing
　　Set Rs_Table = Nothing
　　Else
　　MsgBox "数据库连接失败，请找系统管理员进行检查 ！", 16, cProgramName
　　End
　　End If
　End With
End Sub
　　
'*********************************************************
'* 名称：FieldType
'* 功能：返回字段类型
'* 用法：FieldType(nType as integer)
'*********************************************************
Function FieldType(nType As Integer) As String
　Select Case nType
　　Case 128
　　FieldType = "BINARY"
　　Case 11
　　FieldType = "BIT"
　　Case 129
　　FieldType = "CHAR"
　　Case 135
　　FieldType = "DATETIME"
　　Case 131
　　FieldType = "DECIMAL"
　　Case 5
　　FieldType = "FLOAT"
　　Case 205
　　FieldType = "IMAGE"
　　Case 3
　　FieldType = "INT"
　　Case 6
　　FieldType = "MONEY"
　　Case 130
　　FieldType = "NCHAR"
　　Case 203
　　FieldType = "NTEXT"
　　Case 131
　　FieldType = "NUMERIC"
　　Case 202
　　FieldType = "NVARCHAR"
　　Case 4
　　FieldType = "REAL"
　　Case 135
　　FieldType = "SMALLDATETIME"
　　Case 2
　　FieldType = "SMALLMONEY"
　　Case 6
　　FieldType = "TEXT"
　　Case 201
　　FieldType = "TIMESTAMP"
　　Case 128
　　FieldType = "TINYINT"
　　Case 17
　　FieldType = "UNIQUEIDENTIFIER"
　　Case 72
　　FieldType = "VARBINARY"
　　Case 204
　　FieldType = "VARCHAR"
　　Case 200
　　FieldType = ""
　End Select
End Function

　　此程序只是一个雏形，可以在此基础上开发成一个工具使用
　　本程序在：VB 6.0　，SQL SERVER 2000下运行通过
　　注程序中须引用 ActiveX Data Objects (ADO)