拿分来！我建议大家把各自知道的vb技巧亮一两个，大家交流！

' 判斷IP地址的格式是否正確
Private Function IsIPDomain(ByVal HostString As String) As Boolean
    Dim sSplit()        As String
    Dim iCtr            As Integer    sSplit = Split(HostString, ".")    If UBound(sSplit) <> 3 Then Exit Function
    For iCtr = 0 To 3
        If Not IsNumeric(sSplit(iCtr)) Then Exit Function
        If iCtr = 0 Then
            If Val(sSplit(iCtr)) > 239 Then Exit Function
        Else
            If Val(sSplit(iCtr)) > 255 Then Exit Function
        End If
    Next
    IsIPDomain= True
End Function

控件是否存在：
Private Function DoesControlExist(ByRef ctl As Control) As Boolean

On Error GoTo handleError        DoesControlExist = (ctl.Name <> vbNullString)
        Exit Function

handleError:
        DoesControlExist = False

End Function

to:daryl715(汉堡包) 请看清楚贴题：各自知道的vb技巧是知道，不是原创 :p

动态加载窗体：Public Function AddDynamicFormEx(ByVal strFormName As String, _
                                 Optional ByVal blnDuplicatable As Boolean = False, _
                                 Optional ByVal blnDirectShow As Boolean = True) As Form

    Dim o_frmItem As Form
    Dim o_frmTarget As Form
    Dim o_intItems As Integer
    Dim o_blnRet As Boolean

    o_blnRet = False

    For Each o_frmItem In Forms
        If o_frmItem.Name = strFormName Then
            o_blnRet = True
            Set o_frmTarget = o_frmItem
            Exit For
        Else
        End If
    Next

    If o_blnRet Then
        If blnDuplicatable Then '可以重复
            Set AddDynamicFormEx = Forms.Add(strFormName)
        Else
            Set AddDynamicFormEx = o_frmTarget
        End If
    Else
        Set AddDynamicFormEx = Forms.Add(strFormName)
    End If

    If blnDirectShow Then '自动显示
        AddDynamicFormEx.Show
    Else
    End If

    Set o_frmItem = Nothing
    Set o_frmTarget = Nothing

End Function

让点阵打印机每次印出一行VB 的 Printer 事件必须调用 EndDoc 或 NewPage，才会将列印的资料输出到打印机，但每印就是一页，我希望每输出一行资料就立刻印在点阵打印机上面，该如何进行呢？
文件名称 "PRN" 对 DOS 而言，指的是打印机，对 Windows 而言仍然是适用的，因此先利用以下叙述开启 "PRN"(印表机 )：
Open "PRN" For Output As #1
然后再利用以下的 Print 叙述便可以逐行印出资料：
Print #1, 资料
注：如果想输出中文，必须使用中文打印机，因为以上的列印方法并未通过 Windows 的打印机驱动程序，所以无法在英文打印机上面输出中文字。

在Visual Basic中，惊叹号“！”与圆点“．”都用于给对象命名，但两者语法上却存在很大的区别，这点在编程时尤其需要注意。
    圆点操作符“．”用来表示对象的属性和方法，在引用时，需要用到对象的Name、圆点和需要的属性或方法。例如要引用文本框Textl中的文本属性时可用reponse＄＝Text1．Text，再如要改变Form1窗体返回或读取对象高度的单位时用Form1．ScaleHeigh＝2000表示。
    感叹号“！”常用于当一个控件作为一个特性访问的情况下，例如引用Fomr2中Text1文本框文本属性时，可采用response＄＝Form2！text1．text语法格式。
    虽然两者的语法应用结构有较大差异，但两条语句的性能是相同的，值得注意的是如果你在感叹号“！”的位置使用“．”可以获得对窗体上Text1特性的直接访问权，为了进一步增加感性认识，你不妨运行下面的例子来试试。
    1．建立一个新项目，并在Form1窗体中增加一个命令控件。
    2．双击Form1窗体，编辑Form－Load事件并输入：
        Form1！Command1．Caption＝”Text”
        Form1．Command1．Caption＝”It Works”
    3．运行试项目，这时你就会在Command1命令框中看到字符串It Works。
    为了在程序中清楚地界定引用的控件名和该控件的属性或方法，增加程序的可读性，最好使用感叹号“！”，这也是VB的推荐方式。

windows98 系统的许多软件中都包含一个windows 风格的about 窗口，它向用户反映了当前系统的一些基本信息，其中显示有关windows 及其应用软件的版本、版权和系统的工作状态等信息。笔者用VB 6.0 通过调用API 函数设计应用系统的ABOUT 窗口。效果如图1。( 略)
1 ．建立含有如下控件的窗体：
      控件     NAME      CAPTION
      窗体     FORM1     用VB6.0 设计ABOUT 窗口
      命令按钮   COMMAND1 关于销售管理系统2 ．程序清单：
---- Private Declare Function GetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Integer
---- Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long ---- Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hinst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long ---- Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO) Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Const GWL_WNDPROC = (-4)
Private Const GWL_HINSTANCE = (-6)
Private Type SYSTEM_INFO
        dwOemID As Long
        dwPageSize As Long
        lpMinimumApplicationAddress As Long
        lpMaximumApplicationAddress As Long
        dwActiveProcessorMask As Long
        dwNumberOrfProcessors As Long
        dwProcessorType As Long
        dwAllocationGranularity As Long
        dwReserved As Long
End Type
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1Private Sub Command1_Click()
Dim hinst As Long
Dim icons As Long
Dim abouts As Long
Dim dispx As String
Dim dispy As String
Dim cps As String
Dim space1 As String
Dim space2 As String
hinst = GetWindowWord(Me.hwnd, GWL_HINSTANCE)
icons = ExtractIcon(hinst, "d:\fpw26\foxprow.exe", 0)
Dim sysinfo As SYSTEM_INFO
Dim cls1 As Long
Dim cls2 As Long
Dim secs As Long
Dim bytes As Long
Dim buffs As String
buff = "C:\"
x = GetDriveType(buffs)
x = GetDiskFreeSpace(buffs, secs, bytes, cls1, cls2)
cls1 = cls1 * secs * bytes
cls2 = cls2 * secs * bytes
space1 = "C驱动器总共容量：
    " + Format$(cls2/1024, "#, #") + "千字节"
space2 = "C驱动器可用容量：
    " + Format$(cls1/1024, "#, #") + "千字节"
x = GetSystemMetrics(SM_CXSCREEN)
dispx = "显示器分辨率：" + Str$(x)
x = GetSystemMetrics(SM_CYSCREEN)
dispy = Str$(x)
Call GetSystemInfo(sysinfo)
Select Case sysinfo.dwProcessorType
Case 386
     cpus = "处理器类型:386"
Case 486
     cpus = "处理器类型:486"
Case 586
     cpus = "处理器类型:586"
End Select
abouts = ShellAbout(Me.hwnd, "演示程序",
   "销售管理系统V2.0版权所有[C]1998-1999蔡可训"
    & Chr$(13) & Chr$(10) & space1 & Chr$(13) & Chr$(10)
    & space2 & Chr$(13) & Chr$(10) & cpus + "  " + dispx +
     "*" + dispy , icons)
End Sub---- 以上程序在WINDOWS98,VISUAL BASIC 6.0 FOR WINDOWS 环境下运行通过. 用户可以将其加入应用系统的ABOUT 菜单项，通过菜单项调用它，效果更好。

通过API获取某页面内容：Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sURL As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As IntegerPrivate Const IF_FROM_CACHE = &H1000000
Private Const IF_MAKE_PERSISTENT = &H2000000
Private Const IF_NO_CACHE_WRITE = &H4000000

Private Const BUFFER_LEN = 256Public Function GetUrlSource(sURL As String) As String
    Dim sBuffer As String * BUFFER_LEN, iResult As Integer, sData As String
    Dim hInternet As Long, hSession As Long, lReturn As Long    'get the handle of the current internet connection
    hSession = InternetOpen("vb wininet", 1, vbNullString, vbNullString, 0)
    'get the handle of the url
    If hSession Then hInternet = InternetOpenUrl(hSession, sURL, vbNullString, 0, IF_NO_CACHE_WRITE, 0)
    'if we have the handle, then start reading the web page
    If hInternet Then
        'get the first chunk & buffer it.
        iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
        sData = sBuffer
        'if there's more data then keep reading it into the buffer
        Do While lReturn <> 0
            iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
            sData = sData + Mid(sBuffer, 1, lReturn)
        Loop
    End If

    'close the URL
    iResult = InternetCloseHandle(hInternet)    GetUrlSource = sData
End Function
判断是否在vb IDE：
Private Declare Function GetModuleFileName Lib "kernel32" Alias _
        "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As _
        String, ByVal nSize As Long) As LongFunction IsUnderIDEMode(Optional iVBVer As Integer = 6) As Boolean
    Dim S As String, Length
    Length = 256
    S = String(Length, 0)
    Call GetModuleFileName(0, S, Length)
    S = Left(S, InStr(S, Chr(0)) - 1)
    IsUnderIDEMode = (UCase(Right(S, 7)) = "VB" & CStr(iVBVer) & ".EXE")
End FunctionPrivate Sub Command1_Click()
    MsgBox IsUnderIDEMode(6) '是否在vb6 IDE
End Sub
判断是否保护非标志字符，如汉字等：Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long'方法一
Public Function HasSpecialCharEx(ByVal strText As String) As Boolean

        HasSpecialCharEx = Not (Len(strText) = lstrlen(strText))

End Function'方法二
Public Function HasSpecialChar(ByVal strText As String) As Boolean

        HasSpecialChar = Not (Len(strText) = LenB(StrConv(strText, vbFromUnicode)))

End Function控件安全聚焦：Public Sub sfSetFocus(ByRef ctl As Control)

On Error Resume Next     If not (ctl is nothing) then
        if typeof ctl is control then
           ctl.SetFocus
        else
        endif
     else
     endif

     Err.Clear

End Sub
优化的DoEvents：Public Sub sfSetFocus(ByRef ctl As Control)

On Error Resume Next        ctl.SetFocus

        Err.Clear

End Sub

上面错了一点，现在更正：优化的DoEvents：
Private Declare Function GetInputState Lib "user32" () As LongPublic Sub DoEventsEx()
If GetInputState() <> 0 Then DoEvents
End Sub

很好！我也贴一个！
'文件查找Public Function TreeSearch(ByVal sPath As String, ByVal sFileSpec As String, sFiles() As String) As Long
Static es As Long '文件数目
Dim sDir As String
Dim sSubDirs() As String '‘存放子目录名称
Dim ex As Long
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sDir = Dir(sPath & sFileSpec)
'获得当前目录下文件名和数目
Do While Len(sDir)
es = es + 1
ReDim Preserve sFiles(1 To es)
sFiles(es) = sDir
'sFiles(es) = sPath & sDir
sDir = Dir
Loop
'获得当前目录下的子目录名称
ex = 0
sDir = Dir(sPath & "*.*", 16)
Do While Len(sDir)
If Left(sDir, 1) <> "." Then 'ip.and..
'找出子目录名
If GetAttr(sPath & sDir) And vbDirectory Then
ex = ex + 1
'保存子目录名
ReDim Preserve sSubDirs(1 To ex)
sSubDirs(ex) = sPath & sDir & "\"
End If
End If
sDir = Dir
Loop
For ex = 1 To ex
'查找每一个子目录下文件，这里利用了递归
Call TreeSearch(sSubDirs(ex), sFileSpec, sFiles())
Next ex
TreeSearch = es
End Function

主題：如何取得印表機列印報表時紙張的各邊界大小及可列印範圍？
來源：小紀（紀文和）
版本：VB6 / VB5 / VB4-32
當您需要在程式中列印報表，如果不是使用列印報表的輔助工具，例如：Crystal Report、Data Report ... 等，而是直接使用 Printer 的 Print、Line、Circle、PaintPicture 或 PSet 方法的方式來列印，您如何知道，該報表的可列印範圍有多大呢？一般，印表機在列印報表時，報表的上下左右都會留下一定的邊界範圍無法列印，所以，常常會發生您要列印的資料，在最右邊或最下方有一部份被切掉了，沒有印出來！您如何解決呢？據小紀所知，很多人都是使用【錯誤嘗試法】，也就是實際測試，一張一張的印，測到能正確印出來為止！這樣真的是浪費時間及紙張，更耗費精神及金錢呢！其實，要取得報表的可列印範圍很簡單，方法如下（Pixels）：　　PrintWidth = Printer.ScaleWidth      '可列印範圍寬度
　　PrintHeight = Printer.ScaleHeight    '可列印範圍高度
如果您想取得紙張的實際大小及上下左右四個邊界的大小，就要借助 GetDeviceCaps 這個 API 了！宣告資料如下：Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Const PHYSICALWIDTH = 110
Private Const PHYSICALHEIGHT = 111
Private Const PHYSICALOFFSETX = 112
Private Const PHYSICALOFFSETY = 113
要計算紙張及邊界的大小，重要程式碼如下：　　Printer.ScaleMode = vbPixels

　　PhysWidth = GetDeviceCaps(Printer.hDC, PHYSICALWIDTH)     '紙張實際寬度
　　PhysHeight = GetDeviceCaps(Printer.hDC, PHYSICALHEIGHT)   '紙張實際高度
　　PrintWidth = Printer.ScaleWidth                           '可列印範圍寬度
　　PrintHeight = Printer.ScaleHeight                         '可列印範圍高度
　　LeftMargin = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETX)  '左邊界
　　RightMargin = PhysWidth - (LeftMargin + PrintWidth)       '右邊界
　　TopMargin = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETY)   '上邊界
　　BottomMargin = PhysHeight - (TopMargin + PrintHeight)     '下邊界
不過上面算出來的數字，其單位是 Pixels，如果您要別的單位，必須再加以換算才行！今天的範例程式畫面如下：範例程式提供的計算單位有 cm、pixels、twips、inches，如果您需要其他單位，例如：mm，請自行換算！还有更多在:
www.vbguide.com.tw

主題：如何抓出 Access 的 Table 欄位中的【敘述】部份呢？（ADO）
來源：小紀（紀文和）
版本：VB6 --------------------------------------------------------------------------------
這個主題在【問題0165:如何抓出 Access 的 Table 欄位中的【敘述】部份呢？】中，我們已經提過一次了，不過，當時我們是使用 DAO 來做，現在，我們來看看使用 ADO 要如何做呢？和問題 0165 一樣，我已經將這個部份寫成一個模組了，您只要帶入相關的參數即可．不過，在使用這個模組時，必須要先在【設定引用項目】中，加入以下二個引用項目：（版本數字可能不同，沒關係！）※ Microsoft ADO Ext. 2.5 for DDL and Security
※ Microsoft ActiveX Data Objects 2.5 Library 如下圖：模組程式碼如下：Function Getdescription(sDBName As String, sPass As String, sTable As String, sField As String) As String
'傳入參數4個
'sDBName: Access 資料庫檔案名稱(含路徑)
'sPass  : Access 資料庫密碼
'sTable : Table Name
'sField : 欄位名稱
'傳回值 : 欄位說明
    Dim mCon As ADODB.Connection
    Dim mCat As ADOX.Catalog
    Set mCon = New ADODB.Connection
    mCon.Provider = "Microsoft.Jet.OLEDB.4.0"
    mCon.Mode = adModeRead
    mCon.CursorLocation = adUseClient
    mCon.Properties("Data Source") = sDBName
    mCon.Properties("Jet OLEDB:Database Password") = sPass
    mCon.Open    Set mCat = New ADOX.Catalog
    mCat.ActiveConnection = mCon

    Dim F As Integer
    For F = 0 To mCat.Tables(sTable).Columns(sField).Properties.Count - 1
        If LCase(mCat.Tables(sTable).Columns(sField).Properties(F).Name) = "description" Then
            Getdescription = mCat.Tables(sTable).Columns(sField).Properties(F).Value & ""
        End If
  Next F
End Function
如程式碼中所示，此一模組共需要４個參數，說明如下：參數名稱參數說明
sDBName  Access 資料庫檔案名稱（含完整路徑）
sPass  Access 資料庫密碼，若無蜜碼則傳入空字串即可
sTable  Table Name
sField  欄位名稱而傳回值呢，當然就是欄位說明了，也就是欄位中的【敘述】部份了！接下來，看看範例程式的畫面：實際呼叫這個模組的程式碼如下：欄位說明 = Getdescription("資料庫檔案名稱", "資料庫密碼", "Table名稱", "欄位名稱")
还有更多在:
www.vbguide.com.tw

主題：如何達成【自動更新程式】～更換執行檔？
來源：範例程式：SupLDN　撰稿：小紀
版本：VB6 / VB5 / VB4-32 --------------------------------------------------------------------------------
自動更新程式，可以簡略的分成二個範疇，說明如下：１、從 Internet 上下載更新：
將較新版本的應用程式從 Internet 上下載後，再更換掉目前正在執行的應用程式．
目前很多軟體都有提供這樣的功能，例如：Pccillin 等掃毒軟體（如圖一）
　
（圖一）
　
２、從網路磁碟機或磁片上下載更新：
較新版本的應用程式就在 Local 端的主機上或更新磁片上．
在小紀服務的集團，所有公司的應用系統，執行檔至少就有 200 個，這些執行檔都統一放在公司的主機中，程式如果有任何的修改或更新版本，也都直接放到主機上，之後，一旦使用者在 Client 端重新啟動程式，便會自動先和主機上的執行檔比較版本，再決定如何執行，結果可能有二種：
～ Server 上的版本較新：自動從主機（或磁片）上複製較新版本的執行檔，並啟動新版的程式．
～ Server 上的版本相同：不做任何動作，繼續執行原來在 Client 端的程式．在整個自動更新的過程中，可分成以下幾個階段：１、檢查程式是否有新版本
比對主機上的程式版本和目前機器中的程式版本是否相同，方法有很多種，像 Pccillin 的病毒碼是以副檔名的數字來判別，比較簡單的方式，可以比較應用程式檔案的日期．
２、下載新版本的程式
若是 Server 上的版本較新，就將檔案複製到自己的機器中．
３、更換執行檔或其他資料檔
將檔案複製到自己的機器之後，要停止目前正在執行的程式，並啟動最新下載的程式．在本單元中，我們要討論的是更新過程中的第三個階段，也就是執行檔的更換．所以本單元的範例，我們有了假設的狀況，就是假設程式（Start.exe）有了新版本，而且已經下載完畢放在 C:\ 根目錄中．應用程式啟動後畫面如下：整個程式只有二個事件需要處理，分別說明如下：１、 Command1_Click() 事件
～檢查新的執行檔（C:\Start.exe）是否真的存在？
～將新的執行檔複製到應用程式所在的目錄中，並更名為 Update.exe．
～啟動新版本的程式 Update.exe，執行時傳入參數 S
～結束目前正在執行的程式 Start.exe
～到此為止，整個置換動作只算進行到一半喔！
程式碼如下：

Private Sub Command1_Click()
    '判斷更新檔案是否存在
    If Dir("C:\START.EXE") <> "" Then
        '複製到本端路徑，並更名為 Update.exe
        FileCopy "C:\START.EXE", App.Path & "\UPDATE.EXE"
        '執行新下載的程式（暫時更名為 Update.exe），傳入的參數是 S
        Shell App.Path & "\UPDATE.EXE S"
        '關閉程式,因為已交由 UPDATE.EXE 來控制
        Unload Me
    End If
End Sub

２、 Form_Load() 事件
判斷程式啟動時所帶的參數，可能為 S／S1／空字串三種（空字串不處理）
參數為 S：表示目前正在執行的程式名稱是 Update.exe，執行檔置換動作進行到一半．等舊程式 Start.exe 確實結束了，將正在執行的 Update.exe 再複製一次成 Start.exe 覆蓋掉原來的舊程式，覆蓋完畢後，啟動新版本的程式 Start.exe，執行時傳入參數 S1，這時候 Update.exe 就可以功成身退了，所以，結束目前正在執行的程式 Update.exe．參數為 S1：表示程式剛置換完畢，新程式 Start.exe 更新後第一次啟動，等 Update.exe 確實結束了，就可以將它刪除了．到此，一切就算大功告成了．程式碼如下：

Private Sub Form_Load()
    Dim T As Double
    T = Timer

    '判斷有無更新參數
    If Command = "S" Then
        '延遲 3 秒，等待 START.EXE 執行結束
        '(其實應該改用 API 來偵測 START.EXE 是否執行結束)
        Do While Timer - T < 3
            DoEvents
        Loop
        '將 START.EXE 更新
        FileCopy App.Path & "\UPDATE.EXE", App.Path & "\START.EXE"
        '執行更新後的程式,並傳入更新參數
        Shell App.Path & "\START.EXE S1"
        Unload Me
    ElseIf Command = "S1" Then
        '延遲 3 秒，等待 UPDATE.EXE 執行結束
        '(其實應該改用 API 來偵測 UPDATE.EXE 是否執行結束)
        Do While Timer - T < 3
            DoEvents
        Loop
        '將更新用的 temp 檔砍掉
        If Dir(App.Path & "\UPDATE.EXE") <> "" Then Kill App.Path & "\UPDATE.EXE"
        MsgBox "更新完畢 !"
    End If
End Sub还有更多在:
www.vbguide.com.tw

'*********************************************************
'* 名称：NumToText
'* 功能：将数字转换成英文
'* 用法：
'*********************************************************
Public Function NumToText(dblVal As Double) As String
    Static Ones(0 To 9) As String
    Static Teens(0 To 9) As String
    Static Tens(0 To 9) As String
    Static Thousands(0 To 4) As String
    Static bInit As Boolean
    Dim i As Integer, bAllZeros As Boolean, bShowThousands As Boolean
    Dim strVal As String, strBuff As String, strTemp As String
    Dim nCOL As Integer, nChar As Integer
    'Only handles positive values
    Debug.Assert dblVal >= 0    If bInit = False Then
        'Initialize array
        bInit = True
        Ones(0) = "ZERO"
        Ones(1) = "ONE"
        Ones(2) = "TWO"
        Ones(3) = "THREE"
        Ones(4) = "FOUR"
        Ones(5) = "FIVE"
        Ones(6) = "SIX"
        Ones(7) = "SEVEN"
        Ones(8) = "EIGHT"
        Ones(9) = "NINE"
        Teens(0) = "TEN"
        Teens(1) = "ELEVEN"
        Teens(2) = "TWELVE"
        Teens(3) = "THIRTEEN"
        Teens(4) = "FOURTEEN"
        Teens(5) = "FIFTEEN"
        Teens(6) = "SIXTEEN"
        Teens(7) = "SEVENTEEN"
        Teens(8) = "EIGHTEEN"
        Teens(9) = "NINETEEN"
        Tens(0) = ""
        Tens(1) = "TEN"
        Tens(2) = "TWENTY"
        Tens(3) = "THIRTY"
        Tens(4) = "FORTY"
        Tens(5) = "FIFTY"
        Tens(6) = "SIXTY"
        Tens(7) = "SEVENTY"
        Tens(8) = "EIGHTY"
        Tens(9) = "NINETY"
        Thousands(0) = ""
        Thousands(1) = "THOUSAND"   'US numbering
        Thousands(2) = "MILLION"
        Thousands(3) = "BILLION"
        Thousands(4) = "TRILLION"
    End If
    On Error GoTo NumToTextError
    If dblVal - Int(dblVal) >= 0.01 Then
        strBuff = "and " & NumToText((dblVal - Int(Val(Str(dblVal)))) * 100) & "CENTS"
    Else
        strBuff = ""
    End If
    strVal = CStr(Int(dblVal))
    bAllZeros = True
    For i = Len(strVal) To 1 Step -1
        'Get value of this digit
        nChar = Val(Mid$(strVal, i, 1))
        'Get column position
        nCOL = (Len(strVal) - i) + 1
        'Action depends on 1's, 10's or 100's column
        Select Case (nCOL Mod 3)
            Case 1  '1's position
                bShowThousands = True
                If i = 1 Then
                    'First digit in number (last in loop)
                    strTemp = Ones(nChar) & " "
                ElseIf Mid$(strVal, i - 1, 1) = "1" Then
                    'This digit is part of "teen" number
                    strTemp = Teens(nChar) & " "
                    i = i - 1   'Skip tens position
                ElseIf nChar > 0 Then
                    'Any non-zero digit
                    strTemp = Ones(nChar) & " "
                Else
                    'This digit is zero. If digit in tens and hundreds column
                    'are also zero, don't show "thousands"
                    bShowThousands = False
                    'Test for non-zero digit in this grouping
                    If Mid$(strVal, i - 1, 1) <> "0" Then
                        bShowThousands = True
                    ElseIf i > 2 Then
                        If Mid$(strVal, i - 2, 1) <> "0" Then
                            bShowThousands = True
                        End If
                    End If
                    strTemp = ""
                End If
                'Show "thousands" if non-zero in grouping
                If bShowThousands Then
                    If nCOL > 1 Then
                        strTemp = strTemp & Thousands(nCOL \ 3)
                        If bAllZeros Then
                            strTemp = strTemp & " "
                        Else
                            strTemp = strTemp & " "
                        End If
                    End If
                    'Indicate non-zero digit encountered
                    bAllZeros = False
                End If
                strBuff = strTemp & strBuff
            Case 2  '10's position
                If nChar > 0 Then
                    If Mid$(strVal, i + 1, 1) <> "0" Then
                        strBuff = Tens(nChar) & "-" & strBuff
                    Else
                        strBuff = Tens(nChar) & " " & strBuff
                    End If
                End If
            Case 0  '100's position
                If nChar > 0 Then
                    strBuff = Ones(nChar) & " HUNDRED " & strBuff
                End If
        End Select
    Next i
    'Convert first letter to upper case
    strBuff = UCase$(Left$(strBuff, 1)) & Mid$(strBuff, 2)
EndNumToText:
    'Return result
    NumToText = strBuff
    Exit Function
NumToTextError:
    strBuff = "#Error#"
    Resume EndNumToText
End Function

主題：如何中斷【撥號網路連線】？（二）
來源：小紀（紀文和）
版本：VB6 / VB5 / VB4-32 --------------------------------------------------------------------------------
這個主題我們在問題126：如何中斷【撥號網路連線】？中曾經說過了，當時的程式碼看起來有點複雜，或許有些網友也是有看沒有懂呢．今天我們就講一個簡單一點的，程式碼只要幾行就行了！我們要呼叫以下的 InternetAutodialHangup API，請將它直接放到表單的宣告區中：Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved_ As Long) As Long它只有一個參數，是一個保留值，只要傳入０就行了，所以使用方式大概如下：Private Sub Command1_Click()
　　InternetAutodialHangup 0&
End Sub
就是這樣而已，很簡單吧！有些軟體會提供類似【下載完畢後自動斷線】的功能，就是這個
还有更多尽在:
www.vbguide.com.tw

主題：SQL 十個查詢訣竅
來源：SQL 的奧祕（SQL For Dummies）
版本：VB6 / VB5 / VB4-32 / VB4-16 / VB3 --------------------------------------------------------------------------------
前言：本單元節錄自 SQL 的奧祕（SQL For Dummies）一書，作者為 Allen G. Taylor，譯者為蔡國瑞，松格出版．ISBN957-9641-34-X．松格翻譯了很多寫得很好的原文書，不過可惜松格已不復存在，我將會從該書中節錄二個單元出來，分別是：． SQL 最常犯的十大錯誤
． SQL 十個查詢訣竅本單元是第二個單元：SQL 十個查詢訣竅內文：資料就像金銀島上的寶藏，十分珍貴，但這些寶藏是被埋在隱密的地方，必須正確的藏寶圖（正確的查詢命令）和工具來挖掘，而 SQL 的 Select 命令即是最佳利器來掘取珍貴的資訊。由於 Select 指令是非常靈活的，您可以使用不同的 Select 組合，來查得您想知道的資訊，但如果不能掌握正確的 Select 命令，那所得的結果是一堆糞土，為了減少這類錯誤，本單元將告訴您查詢的秘訣。１）驗證資料庫架構是否正確如果您下了一個查詢命令，但卻得到一個不合理的結果，這時您必須注意資料庫的設計是否正確。有些不正確的資料庫定義，可能會導致資料的不一致性等嚴重後果。２）在測試資料庫上做查詢測試在開發應用系統時，建議您建立二個資料庫，分別為正式資料庫和測試資料庫，而在測試資料庫中，存放部份測試資料。在設計查詢程式時，您可以以測試資料庫的資料為主，先測試查詢結果是否正確，以做為修正依據。在建立測試資料時，您可能需要特別設計，在測試資料中先建立正確資料，再建立特殊情況的資料，例如存放一些數值很大的資料，或 Null 值，如此可以測出您所設計的程式，在處理特殊資料時，是否也可正確運作。３）再三查核任何 Join 的查詢命令對於多個 Table 做 Join 時，您必須特別檢查 Where 後面的條件句是否正確，尤其是對每個 Join Table 的 Primary Key 的比較條件。４）詳細檢查含有次查詢的 Select 命令由於次查詢命令經常是將某一 Table 的條件資料與另一 Table 的資料核對比較，如果一不小心，很容易造成錯誤，因此外層 Select 的 Where 條件必須符合內層 Select 的 Select-list 資料型態，尤其是在多層次查詢情況下，更需特別小心。５）Group By 與集合 Function 的配合使用，產生統計資料假設美國 NBA 籃球隊的資料存放在 NBA Table，這 Table 的欄位為 Player（球員）、Team（球隊名稱）和 Good（灌籃次數），記錄 NBA 球員的灌籃次數，以下 SQL 命令用來找出各隊灌籃次數：Select Team, Sum(Good)
From NBA
Group By Team;這查詢的結果是列出 NBA 球隊名稱和灌籃總次數。６）在使用 Group By 時有什麼限制假設您想從 NBA 籃球隊的資料中找出灌籃次數最多的有那些人，您下了以下的 SQL 命令：Select Player, Team, Good
From NBA
Where Good >=50
Group By Team;這查詢的結果並非我們想要的，而且執行時會產生錯誤，原因是在於使用 Group By 時，集合（Set）Function 內的欄位外，其他欄位一定要列在 Group By 後面，因此正確的 SQL 命令是：Select Player, Team, Good
From NBA
Where Good >=50
Group By Team, Player, Good;這查詢結果會以各隊各球員（Team, Player）為單位，加總各人的灌籃次數。７）善用括弧（）來區分 And、Or 和 Not 的執行先後順序當您 SQL 查詢條件式中所使用的 And、Or 或 Not 等運算子，在執行順序安排有問題時，或邏輯運算相當複雜時，建議您善用括弧，將正確的執行順序區分出來。８）切勿將查詢權限開放給不該有的人企業資料庫中，有許多重要的資料，例如客戶資料，往往不希望被其他人盜取做為它用，因此 DBMS 對這類資料，必須嚴密管制查詢權限。９）經常備份資料庫為了防止因天災或人禍所帶來的資料庫損毀危險，建議您經常備份資料庫。１０）詳細規劃 SQL 錯誤的處理一個優良的資料庫應用程式，不但是要執行正確，速度快，而且對於 SQL 錯誤發生時，也必須有適當的處理，並將適當的錯誤訊息，顯示給 User 了解。這種 SQL 的錯誤處理是相當重要的，而且會決定應用系統是否成功。还有更多尽在:
www.vbguide.com.tw

不发了,自己去看!

[VB课程系列五]拖动没有标题栏的窗口
[设计步骤]
（1）新建一个工程，将窗体的Caption属性设置为空，ControlBox属性的值设为False，使之成为一个无标题的窗体。
（2）在窗体上放置一个按钮控件，并设置其Caption属性为“退出”。
（3）将以下几个API函数和常量的声明添加到窗体的声明段。
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (Byval _ hwnd As Long,Byval wMsg As Long,Byval wParam As Long,lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const WM_SYSCOMMAND=&H112
Private Const SC_MOVE=&HF012
（4）编写窗体的MouseDown事件过程，代码如下：
Private Sub Form_MouseDown(Button As Integer,Shift As Integer,X As Single,Y As _ Single)
    ReleaseCapture
    SendMessage Form1.hwnd,WM_SYSCOMMAND,SC_MOVE,0
End Sub
（5）编号“退出”按钮的Click事件过程，代码如下：
Private Sub Command!_Click()
    End
End Sub

    用VB读取和控制Windows的中文输入法

作者: vbfdy　
    在Windows中我们可以用“Ctrl＋Shift”键来调入或切换中文输入法，但是这样做每次都是使位于输入法列表顶端的那个输入法首先被调用。通常我们都要连续按好几次“Ctrl＋Shift”才能将习惯的输入法调出。我编制了一段小程序，通过它可以把任意一个输入法放在输入法列表的顶端。
　　它的原理是：使用LoadKeyboardLayout函数可以改变输入法的顺序，只要在第一个参数中传递目标输入法的KeyboardlayoutName，第二个参数用KLF_REORDER就可以了。
　　例如，aa = LoadKeyboardLayout(″00000409″, KLF_REORDER) 使英文变成第一。那怎样获得KeyboardlayoutName呢？因为使用GetKeyboardLayoutname可以返回当前输入法的KeyboardlayoutName，所以我们可以先用GetKeyboardLayoutList 函数来取得所有输入法，再用activateKeyboardlayout()函数设置当前输入法，最后就可以得到它的KeyboardlayoutName了。具体步骤如下：
　　打开VB后选择标准的EXE文档，在Form1上添加一个Combobox和一个command控件，输入以下程序。
　　′以下的API函数用于输入法操作
　　Private Declare Function GetKeyboardLayoutList Lib ″user32″ _
　　(ByVal nBuff As Long, lpList As Long) As Long
　　Private Declare Function ImmGetDescription Lib ″imm32.dll″ _
　　Alias ″ImmGetDescriptionA″ (ByVal hkl As Long, _
　　ByVal lpsz As String, ByVal uBufLen As Long) As Long
　　Private Declare Function ImmIsIME Lib ″imm32.dll″ (ByVal hkl As Long) As Long
　　Private Declare Function ActivateKeyboardLayout Lib ″user32″ _
　　(ByVal hkl As Long, ByVal flags As Long) As Long
　　Private Declare Function GetKeyboardLayout Lib ″user32″ (ByVal dwLayout As Long)As Long
　　Private Declare Function GetKeyboardLayoutName Lib ″user32″ Alias _
　　″GetKeyboardLayoutNameA″ (ByVal pwszKLID As String) As Long
　　Private Declare Function LoadKeyboardLayout Lib ″user32″ Alias ″LoadKeyboardLayoutA″ _
　　(ByVal pwszKLID As String, ByVal flags As Long) As Long
　　Const KLF_REORDER = ＆H8
　　Private NoOfKBDLayout As Long, i As Long, j As Long
　　Private hKB(24) As Long, BuffLen As Long
　　Private Buff As String
　　Private RetStr As String
　　Private RetCount As Long
　　Private kln As String
　　Private Sub Command1_Click()
　　If Combo1.ListIndex = －1 Then′如果用户尚未选择输入法，显示出错信息
　　MsgBox ″请先选择一个输入法″
　　Exit Sub
　　End If
　　′改变输入法顺序
　　kln = String(8, 0)
　　ActivateKeyboardLayout hKB(Combo1.ListIndex), 0
　　res = GetKeyboardLayoutName(kln)
　　res = LoadKeyboardLayout(kln, KLF_REORDER)
　　ActivateKeyboardLayout hCurKBDLayout, 0
　　End Sub
　　Private Sub Form_Load()
　　Buff = String(255, 0)
　　hCurKBDLayout = GetKeyboardLayout(0) ′取得目前的输入法
　　NoOfKBDLayout = GetKeyboardLayoutList(25, hKB(0)) ′取得所有输入法
　　′ReDim layoutlist(NoOfKBDLayout) As String
　　For i = 1 To NoOfKBDLayout
　　If ImmIsIME(hKB(i － 1)) = 1 Then ′中文输入法
　　BuffLen = 255
　　RetCount = ImmGetDescription(hKB(i － 1), Buff, BuffLen)
　　RetStr = Left(Buff, RetCount)
　　Combo1.AddItem RetStr
　　Else
　　RetStr = ″English (American)″ ′英文输入法
　　Combo1.AddItem RetStr
　　End If
　　Next
　　ActivateKeyboardLayout hCurKBDLayout, 0 ′恢复原来的输入法
　　End Sub
　　运行后，在combobox中选择目标输入法，按下command即可。。


　

[VB课堂系列四]渐变背景
[设计步骤]
（1）新建一个工程，将窗体的Autoredraw属性设置为True。
（2）在代码窗口中编号一个用来实现窗体背景渐变的子过程，代码如下：
Private Sub Gradient(Theobject As Object,Redval,Greenval,Blueval)
    Dim Step,i,T,L,R,B
    Step=(Theobject.Height/60)
    T=0
    L=0
    R=Theobject.Width
    B=T+Step
    '使用循环在窗体上从上至下依次绘制60个矩形
    For i=1 to 60
        Theobject.Line(L,T)-(R,B),RGB(Redval,Greenval,Blueval),BF
        Redval=Redval-4
        Greenval=Greenval-4
        Blueval=Blueval-4
        If Redval<=0 Then Redval=0
        If Greenval<=0 Then Greenval=0
        If Blueval<=0 Then Blueval=0
        T=B
        B=B+Step
    Next
End Sub
（3）在窗体的Resize事件过程中调用子过程Gradient，代码如下：
Private Sub Form_Resize()
    Gradient Form1,0,0,255
End Sub

[VB课堂系列三]在vb中总在最前面的窗体怎么实现？
曾看到一个问题：如何使我的窗口总在最前？使用api函数 SetWindowPos 可以很容易的作到。
    顾名思义， SetWindowPos 就是完成设置窗口位置和状态（pos=position）的功能。源代码如下：
    Option Explicit
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Const HWND_TOPMOST& = -1
    ' 将窗口置于列表顶部，并位于任何最顶部窗口的前面
    Private Const SWP_NOSIZE& = &H1
    ' 保持窗口大小
    Private Const SWP_NOMOVE& = &H2
    ' 保持窗口位置
    Private Sub Form_Load()
        SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
        ' 将窗口设为总在最前
    End Sub

非提问，偶有所得（DriveBox 控件的另类用法）......（288794）

在ListBox中增加水平条Private Const LB_FINDSTRIG = &H18F
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Sub Form_Load()
Dim i As Integer
For i = 1 To 10
List1.AddItem "wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww"
Next
SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, List1.Width + 1000, 0
End Sub

文本对齐：
如果要生成多个字段的记录文本，并能使其每个字段都在用一位置，
则要格式化文本
下面一个函数即可以格式化为指定宽度（按字节算）Private Function tFormat(ByVal Str As String, ByVal tlen As Integer) As String
     Str = StrConv(Str, vbFromUnicode)
     Str = StrConv(MidB(Str, 1, tlen), vbUnicode)
     Str = Str & String(tlen - LenB(StrConv(Str, vbFromUnicode)), Chr(32))
     tFormat = Str
End Function

计算文本中指定字串重复的次数
RepeatCount=Ubound(Split(OrgStr,DistingStr))

Bardo(巴顿) :你那个tFormat不是可以用LSet,RSet实现吗?

inforum(坛中人,不得不用VB):难道你学习的方式是死扣书本？呵呵，笑掉大牙！在成长中学习！！
+++++++++++++++++++++
放分好象没到头，继续加分！+99！

绝对原创：http://www.csdn.net/expert/topic/560/560709.xml?temp=.7457086
自定义打开对话框http://www.csdn.net/expert/topic/559/559353.xml?temp=.96719
256色抖动http://www.csdn.net/expert/topic/486/486765.xml?temp=.9823267
16位色抖动http://www.csdn.net/expert/topic/449/449511.xml?temp=.6561548
得到DOS程序的目录（相当于VB的App.Path）？(用QB的)

Private Sub Form_Load()
   if "有难度" then
       "想几分钟"
       if "还不会" then
           "上csdn"
       endif
   else
       "这有啥，容易"
   endif
   if "解决" then
       "加工资"
   elseEnd Sub

Private Sub Form_Load()
   if "有难度" then
       "想几分钟"
       if "还不会" then
           "上csdn"
       endif
   else
       "这有啥，容易"
   endif
   if "解决" then
       "加工资"
   else
        "吃鱿鱼"
        end
   endif
End Sub

问到的（10点的信誉就是从那加的）：http://www.csdn.net/expert/topic/531/531615.xml?temp=.6633875
QB的SCREEN 12（640*480*16）下怎样直接写屏画点？

判断 rs.name=nulltext1.text=ra!name & ""

如何使键盘、Mouse失效
Public Declare Function EnableWindow Lib "user32" Alias "EnableWindow" (ByVal hwnd As Long, ByVal fEnable As Long) As LongPublic Declare Function GetDesktopWindow Lib "user32" () As Long使用锁定
Call EnableWindow(GetDesktopWindow, 0)使用解锁
Call EnableWindow(GetDesktopWindow, 1)

如何取得计算机名
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long Private Sub Command1_Click()
Dim Name As String, Length As Long Length = 225
Name = String(Length, Chr(0))
GetComputerName Name, Length
Name = Left(Name, Length)
Label1.Caption = Name End Sub

Open "aa.txt" For Binary As #1
       Text1.Text = Input(LOF(1), 1)
    Close #1
    Text1.SetFocus
    Text1.SelStart = Len(Text1.Text)

拦截ComboBox的mouse右键　在ComboBox上按右键时，会有一个popup menu出现，如何令之不出现呢？在editBox中可用ubclassing的技巧check msg是否是WM_RBUTTONDOWN 来拦截mouse是否按了右键而後吃掉该message(不Call CallWindowProc())，而使之不会出现popup menu。但在ComboBox中，按了mouse右键，却仍出现Popup Menu，查了一下按右键时，发现是 WM_PARENTNOTIFY的讯息，而不是wm_rbuttondown，这该如何才能使之不出现Popup menu这是个有趣的问题，ComboBox 是由 "Edit"(TextBox 的前身) 及 "ListBox"两种 Windows 的 control 所组成的，而在 ComboBox 上面按下滑鼠右钮是由"Edit" 来处理，因此拦截的方法是：1. 呼叫 EnumChildWindows 取得 ComboBox 的 "Edit" 子视窗的 hWnd2. 拦截 "Edit" hWnd。'以下程式在form
Option Explicit
Private hwnd5 As LongPrivate Sub Form_Load()
Dim ret As Long
'取得Combo内EditBox的hwnd
hwnd5 = FindEditInCombo(Combo1)
'记录原本的Window Procedure的位址
preWinProc = GetWindowLong(hwnd5, GWL_WNDPROC)
'设定EditBox的window Procedure到wndproc
ret = SetWindowLong(hwnd5, GWL_WNDPROC, AddressOf wndproc)
End SubPrivate Sub Form_Unload(Cancel As Integer)
Dim ret As Long
'取消Message的截取，而使之又只送往原来的Window Procedure
ret = SetWindowLong(hwnd5, GWL_WNDPROC, preWinProc)
End Sub'以下程式在.bas module
Option ExplicitDeclare Function EnumChildWindows Lib "user32" _
(ByVal hWndParent As Long, ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As Long, ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
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 LongPublic Const GWL_WNDPROC = (-4)
Public Const WM_MOUSEMOVE = &H200
Public Const WM_RBUTTONDOWN = &H204
Public preWinProc As Long
Private hEditWnd As LongPublic Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'以下会截取mouse Rbutton Down
If Msg = WM_RBUTTONDOWN Then
Debug.Print "Combol Mouse RButton Down "
Else
'将之送往原来的Window Procedure
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End If
End Function
Public Function FindEditInCombo(ctl As ComboBox) As Long
Call EnumChildWindows(ctl.hwnd, AddressOf EnumFunc, 0)
FindEditInCombo = hEditWnd
End FunctionPublic Function EnumFunc(ByVal hwnd As Long, ByVal lParam As Long) As Long
Dim ClsName As String
Dim len5 As Long
If hwnd = 0 Then
EnumFunc = 0
Else
ClsName = String(255, 0)
len5 = GetClassName(hwnd, ClsName, 256)
ClsName = Left(ClsName, len5)
If ClsName = "Edit" Then
hEditWnd = hwnd
EnumFunc = 0
Else
EnumFunc = 1
End If
End If
End Function
       以上代码来自：源代码数据库(SourceDataBase)
           当前版本： 1.0.539
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

控件随窗体大小而变化'----当窗体大小改变时，如何动态的改变控件的大小是许多VB程序员头痛的
'事。有的人设置窗体Resizable但却不改变控件的大小；有的人则根据控件的
'绝对位置与窗口大小相加减的办法来重新定位控件与改变大小，这种办法比
'较繁琐，且不可重用；当然也有人则限定窗口干脆不让改变。有没有一种简
'便易行的办法？答案是肯定的，下面给出一个一劳永逸的办法，源程序如下:Option Explicit
Private FormOldWidth As Long
'保存窗体的原始宽度
Private FormOldHeight As Long
'保存窗体的原始高度'在调用ResizeForm前先调用本函数
Public Sub ResizeInit(FormName As Form)
Dim Obj As Control
FormOldWidth = FormName.ScaleWidth
FormOldHeight = FormName.ScaleHeight
On Error Resume Next
For Each Obj In FormName
Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
Next Obj
On Error GoTo 0
End Sub'按比例改变表单内各元件的大小，
'在调用ReSizeForm前先调用ReSizeInit函数
Public Sub ResizeForm(FormName As Form)
Dim Pos(4) As Double
Dim i As Long, TempPos As Long, StartPos As Long
Dim Obj As Control
Dim ScaleX As Double, ScaleY As DoubleScaleX = FormName.ScaleWidth / FormOldWidth
'保存窗体宽度缩放比例
ScaleY = FormName.ScaleHeight / FormOldHeight
'保存窗体高度缩放比例
On Error Resume Next
For Each Obj In FormName
StartPos = 1
For i = 0 To 4
'读取控件的原始位置与大小TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
If TempPos > 0 Then
Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
StartPos = TempPos + 1
Else
Pos(i) = 0
End If
'根据控件的原始位置及窗体改变大小
'的比例对控件重新定位与改变大小
Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
Next i
Next Obj
On Error GoTo 0
End SubPrivate Sub Form_Load()
Call ResizeInit(Me) '在程序装入时必须加入
End SubPrivate Sub Form_Resize()
Call ResizeForm(Me) '确保窗体改变时控件随之改变
End Sub'----本例中给出了二个函数:ResizeInit和ResizeForm,在调用ResizeForm之前
'必须先调用ResizeInit。你可以将本程序拷到窗体代码段里，然后在窗体里加
'入任意控件即可进行测试。
       以上代码来自：源代码数据库(SourceDataBase)
           当前版本： 1.0.539
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

如何映射/中断网络磁盘下面的程序段可以模拟【网上邻居】及【我的电脑】中的【映射 / 中断网络磁盘】，就是出现【映射 / 中断网络磁盘】的问话框，让使用者根据自己电脑的情形，来决定要连接的网络磁盘要映射到自己的那一个磁盘？要中断的又是那一个对应的磁盘？　　请在声明区中加入以下声明及模组：Private Declare Function WNetConnectionDialog Lib "mpr.dll" _
(ByVal hwnd As Long, ByVal dwType As Long) As Long
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" _
(ByVal hwnd As Long, ByVal dwType As Long) As LongSub ShowMapDrives(hwnd As Long)
　WNetConnectionDialog hwnd, 1
End SubSub ShowUnMapDrives(hwnd As Long)
　WNetDisconnectDialog hwnd, 1
End Sub'程序中使用方式如下：Private Sub Command1_Click()
　'出现映射网络磁盘问话框
　ShowMapDrives Me.hwnd
End Sub
Private Sub Command2_Click()
　'出现中断网络磁盘问话框
　ShowUnMapDrives Me.hwnd
End Sub
       以上代码来自：源代码数据库(SourceDataBase)
           当前版本： 1.0.538
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

实现文件查找功能　　在VB中要实现查找文件功能，我们可以利用VB的DIR函数进行递归来实现。每次使用DIR函数后，比较是否有要查找的文件，再检查是否有子目录，若有，利用递归继续查找，这样可对整个盘进行查找。
　　下面是一个例子，查找DOS目录下的所有EXE文件，统计EXE文件的数目并列出文件名。本程序会查找当前路径下的所有文件和子目录，与WIN95的“包含子文件夹”的查找功能类似。程序与注释如下：
1.在窗体中加一命令按钮Command1,Caption=查找示例，双击此按钮，写如下代码：　Private Sub Command1_Click()
　 Dim ff() As String '定义一个字符串数组用来保存找到的文件名称
　 Dim fn As Long '保存找到的文件数目
　 fn=TreeSearch("C:%%dos","*.exe"，ff())
　 Print "找到文件数目为" & fn
　 For I=1 To fn
　　 Print ff(I)
　 Next
　End Sub 2.插入一模块Modulel.bas，写如下代码：　Option Explicit
　Public Function TreeSearch(ByVal sPath As String,ByVal sFileSpec As String,sFiles() As String) As Long
　　Static 1Files As Long '文件数目
　　Dim sDir As String
　　Dim sSubDirs() As String '存放子目录名称
　　Dim 1Index As Long
　　If Right(sPath,1)<>"%%" Then sPath=sPath & "%%"
　　sDir=Dir(sPath & sFileSpec)
　 '获得当前目录下文件名和数目
　　Do While Len(sDir)
　　　1Files=1Files+1
　　　ReDim Preserve sFiles(1 To 1Files)
　　　sFiles(1Files)=sPath & sDir
　　　sDir=Dir
　　Loop
　 '获得当前目录下的子目录名称
　　1Index=0
　　sDir=Dir(sPath & "*.*",16)
　　Do While Len(sDir)
　　　If Left(sDir,1)<>"." Then 'skip.and..
　　 '找出子目录名
　　　　If GetAttr(sPath & sDir)And vbDirectory Then
　　　　　1Index=lIndex+1
　　　　 '保存子目录名
　　　　　Redim Preserve sSubDirs(1 To 1Index)
　　　　　sSubDirs(1Index)=sPath & sDir & "%%"
　　　　End If
　　　End If
　　　sDir=dir
　　Loop
　　For 1Index=1 To 1Index
　　　'查找每一个子目录下文件，这里利用了递归
　　　Call TreeSearch(sSubDirs(1Index),sFileSpec,sFiles())
　　Next 1Index
　　TreeSearch=1Files
　End Function 3.保存文件，按F5运行，单击命令按钮即可。
       以上代码来自：源代码数据库(SourceDataBase)
           当前版本： 1.0.538
               作者： Shawls
           个人主页： Http://Shawls.Yeah.Net
             E-Mail： [email protected]
                 QQ： 9181729

调试易

拿分来！我建议大家把各自知道的vb技巧亮一两个，大家交流！

解决方案 »