VB5 範例(7)

VB5 初級生老怪範例(七)

回首頁

分類	標題	大意	作者	日期
字串處理	檔案中字串搜尋	InStr 函數的使用	老怪	1998/10/25
字串處理	檔案用字統計		老怪	1998/10/27
字串處理	字串對齊輸出	同字數的字串並不等長	老怪	1998/11/8
變數處理	For Each 敘述與物件參照		老怪	1998/10/27
變數處理	Collection 應用舉例		老怪	1998/11/28
變數處理	一物控多項	物件參照的操作方式	老怪	1998/12/2
日期時間	公文結案日計算範例		老怪	1998/11/17
日期時間	VB 小鬧鐘範例		老怪	1998/11/18
日期時間	時間暫停		老怪	1998/11/28
圖形處理	踩地雷畫面模擬範例	Line 方法及 PictureBox 區塊分割	老怪	1998/10/30
圖形處理	圖片的 90 度翻轉		老怪	1998/11/5
圖形處理	圖片捲動盒範例		老怪	1998/11/26
物件處理	怎樣點取 Disable 的物件	用 Form 接收滑鼠事件	老怪	1998/11/19
外部程式	讓喪失駐點程式恢復駐點	僅限於 Shell 啟動者	老怪	1998/10/28
視窗界面	雙線固定視窗的切換		fumi	1998/9/23
視窗界面	讓 ChildForm 填滿 MDIForm	條件：ChildForm 不要最大化	老怪	1998/11/10
視窗界面	關閉所有程式載入的表單	不留下負擔的結束程式	老怪	1998/11/13
色彩設定	用捲軸設定顏色值		老怪	1998/11/17
檔案 I/O	最快的開檔模式	Open Binary	老怪	1998/11/17
檔案 I/O	檢查目錄中特定檔案是否存在	Dir 函數的使用	老怪	1998/11/26

VB5 初級生範例使用說明

本範例歡迎非營利性個人及組織轉載使用，營利之利用請先徵得本人之同意，來信註明使用方式及回覆地址。
本範例所有的程式碼範例，皆屬十分基本的 VB 語法，如果您是個 VB User ，歡迎直接引用或改寫使用在你的程式中，本人不主張著作權，因為，沒辦法查嘛。
如果你是個 VB 初學者，又有點窮窮(和老怪一樣)，趕快把本頁另存新檔到你自己的磁碟，離線後慢慢看，也可以 Copy 給朋友喔(不可以收錢)。
本範例都是老怪幾個月來在 tw.bbs.comp.language 討論群組中回答版友問題的合輯，因為是針對問題解決，所以並沒有全面觀念的解說，不適合作為入門文章，但如果你讀了入門書，或是上了老師的課，心中仍不甚明白的話，就可以來這找找有沒有你要的答案，因為這都是別人問過的問題。

檔案中字串搜尋

Eric HSU 撰寫於文章

在 VB 裡要怎麼取得一個文字檔的行數？又如何在一個檔案中搜尋特定字串？

老怪答：

'測試本範例請在表單上布置 Label1,2、Text1,2、Command1
Option Explicit

Private Sub Command1_Click()
Dim FileHandle As Integer
Dim I As Long, SearchPos As Long
Dim LineString As String
Dim LongString As String

FileHandle = FreeFile
Open Text1.Text For Input As #FileHandle

Do While Not EOF(FileHandle)
Line Input #FileHandle, LineString
I = I + 1
LongString = LongString + LineString
Loop

MsgBox "檔案總行數：" & Str(I)

SearchPos = InStr(1, LongString, Text2.Text)

If SearchPos <> 0 Then
MsgBox "[" & Text2.Text & "]" & "在 " & Str(SearchPos) & "位置"
Else
MsgBox "找不到[" & Text2.Text & "]"
End If

End Sub

Private Sub Form_Load()
Label1.Caption = "請輸入檔案名稱"
Label2.Caption = "請輸入搜尋字串"

Text1.Text = App.Path
Text2.Text = ""
End Sub

For Each 敘述與物件參照

Yih-Jaj Lin 撰寫於文章

請問 For Each element In Group ... Next 這個敘述應該如何來應用?我看了線上手冊,但是沒有實際例子,所以還是不甚瞭解？

老怪答：

先舉範例：

程式目標：
找出 Form 上所有 CommandButton Control，並把它們的 Caption 改成 "命令"+序列數字。

程式範例：
Dim SetControl As Control
Dim I As Integer

    I = 1

    For Each SetControl In Me.Controls
        If TypeName(SetControl) = "CommandButton" Then
            SetControl.Caption = "命令" & I
            I = I + 1
        End If
    Next

再說 For Each...敘述的要領：

Element 必須是在集合物件中的一個物件。

因為 Element 是物件，所以它的宣告必須是 [物件通用名稱]、[Object] 或 [Variant] ，其中以物件通用名稱效率最好，Object 次之，Variant 最差，但三者皆能達成目的。

因為 Element 是在集合物件中的一個物件，所以你必須知道它集合名稱是什麼，如 Form 上所有的控制項集合名稱為 Me.Controls or FormName.Controls。

當宣告物件變數(如 SetControl)對照到集合物件中某一物件時，即和該物件產生參照關係(如 CommandButton)，你可使用該物件的所有屬性、方法，對宣告物件變數(如SetControl)的所有設定，都將反映在參照物件(CommandButton)上。所以 For Each 只是將物件變數逐一參照到集合物件中，真正重要的是你要對集合物件做何種設定。

物件變數對集合物件的參照關係並不隨 For Each 迴圈結束而結束，如果迴圈自然結束，那物件變數是參照集合中最後一個物件。如果依條件採用 Exit For 方式強迫結束，那麼物件變數是參照 Exit 敘述前的那個物件，這有以下兩個意義：

就記憶體使用而言，除非使用 Set 物件變數=Nothing ，否則物件變數會一直佔有原記憶區塊，然後依照變數生存原則被結束，在區域裏宣告的在區域結束時結束，公用變數則在程式結束時結束。

就參照關係的繼續使用而言，在區域程序裏宣告的物件變數在 For Each 迴圈結束後可以繼續使用其參照關係，直到區域程序結束為止。公用物件變數，則在全部模組都可以繼續使用其參照關係，直到你 Set Nothing or 程式結束。

檔案用字統計

苜蓿芽撰寫於文章

請問該如何寫一支能將一英文字串的所有英文字母、標點符號、空格、數字所出現的次數給統計出來咧????????

老怪答：

Option Explicit

'測試本程式請於標單上布置 Command1,2,3、Label1、List1 及
'CommonDialog1
'儲存所有字碼之陣列
Dim varCalc(32766) As Long

'各字元使用次數統計
Private Sub Command1_Click()
'檔案代號
Dim FileHandle As Integer
'中文字碼負號轉換
Dim CharNo As Integer
Dim I As Long
'二進取檔之 Buffer
Dim Buff() As Byte
'逐字取出之長短變數
Dim LongString As String, ShortString As String * 1
'檔案路徑及名稱
Dim FileString As String

    '清除前次設定
    CommonDialog1.filename = ""
    '啟用開檔對話盒
    CommonDialog1.ShowOpen
    '取得檔案路徑及名稱
    FileString = CommonDialog1.filename

    If FileString = "" Then
        MsgBox "未選擇使用檔案，無法統計。", vbOKOnly, "檔案錯誤"
        Exit Sub
    End If

    Me.MousePointer = 11

    '清除上一次的項目
    List1.Clear

    '用 Byte 陣列模式開檔速度比較快
    FileHandle = FreeFile
    Open FileString For Binary As #FileHandle
    ReDim Buff(LOF(FileHandle) - 1)
    Get #FileHandle, , Buff
    Close #FileHandle

    '把 byte 陣列字碼轉成 Unicode，放入 LongString 中
    '以便逐字取出
    LongString = StrConv(Buff, vbUnicode)
    '清除 Buffer 佔用的記憶體空間
    Erase Buff

    For I = 1 To Len(LongString)
        '循序取出一字
        ShortString = Mid(LongString, I, 1)
        '取得該字碼之絕對值
        CharNo = Abs(Asc(ShortString))
        '將與其對應之陣列指索引計數加 1
        varCalc(CharNo) = varCalc(CharNo) + 1
    Next

    '放到 ListBox 裏顯示統計結果
    For I = 0 To UBound(varCalc)
        '計數不為 0 的才顯示
        If varCalc(I) > 0 Then
            CharNo = I
            '中文字碼是負數的，所以要把陣列索引加負號
            If CharNo > 255 Then CharNo = -CharNo
            List1.AddItem "[" & Chr(CharNo) & "]" & varCalc(I)
        End If
        DoEvents
    Next

    '有開檔才能存檔
    Command2.Enabled = True

    Me.MousePointer = 0
End Sub

'將統計數值存成存文字檔
Private Sub Command2_Click()
Dim FileHandle As Integer, CharNo As Integer
Dim FileString As String
Dim I As Long

    CommonDialog1.filename = ""
    CommonDialog1.ShowSave
    FileString = CommonDialog1.filename

    If FileString = "" Then
        MsgBox "未選擇使用檔案，無法存檔。", vbOKOnly, "檔案錯誤"
        Exit Sub
    End If

    Me.MousePointer = 11

    '開啟輸出檔
    FileHandle = FreeFile
    Open FileString For Output As #FileHandle

    For I = 0 To UBound(varCalc)
        '計數不為 0 的才存入
        If varCalc(I) > 0 Then
            CharNo = I
            If CharNo > 255 Then CharNo = -CharNo
            Write #FileHandle, Chr(CharNo), varCalc(I)
        End If
    Next

    Close #FileHandle

    Me.MousePointer = 0
End Sub

Private Sub Command3_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Me.Caption = "檔案用字統計"
    Label1.Caption = "統計觀察窗"
    Command1.Caption = "開啟檔案"
    Command2.Caption = "存成檔案"
    Command2.Enabled = False
    Command3.Caption = "結束"

    '副檔名預設是 TXT
    CommonDialog1.DefaultExt = "txt"
    CommonDialog1.Filter = "文字檔 (*.txt)|*.txt|所有檔案 (*.*)|*.*"
    CommonDialog1.InitDir = App.Path
End Sub

讓喪失駐點程式恢復駐點

段譽撰寫於文章

請問一下在VB中我利用shell執行外部程式,指定外部程式不擁有駐點, 且最小化 (就是參數給 6)要怎麼做才能讓這個程式恢復成全螢幕大小？

老怪答：

Dim AppNum As Variant

Private Sub Command1_Click()
    AppNum = Shell("c:\windows\notepad.exe", vbMinimizedNoFocus)
End Sub

Private Sub Command2_Click()
    AppActivate AppNum
    SendKeys "{ENTER}"
End Sub

踩地雷畫面模擬範例

寄件者: terry

請問如何寫像踩地雷一像可設定寬高度,按下滑鼠方塊就會下沉.

老怪答：

我們可以用在方塊圖邊線畫明線及暗線的方式作出凸起及凹陷的效果。
方塊行列故然可以用 N*N 個繪圖物件來構成，但太耗費記憶體了。我們可以用 N*N 個陣列變數對應到一個 PictureBox 的各個方格區域，在變數中記錄方塊圖的凸起及凹陷，再在 PictureBox 上一個區塊一個區塊的畫出方塊圖來。
範例如下：
'本範例用一張凸起圖及平面圖(由程式自行繪製，不須載入圖檔。)
'來模擬踩地雷遊戲之操作畫面
'操作本範例請在 Form 上布置 Picture1,Command1
Option Explicit
'一格的寬度，單位 Pixel
Const GRIDLENGTH As Integer = 16
'邊線寬度，單位 Pixel
Const BODERWIDTH As Single = 1.5
'轉換後邊線寬度
Dim LineWidth As Single
'轉換後格子寬度
Dim GW As Single
'轉換後格子高度
Dim GH As Single
'橫軸格子數
Dim GridHNum As Integer
'縱軸格子數
Dim GridVNum As Integer
'平面及凸起圖形陣列
Dim GridPic(1) As Picture
'註記每一格子凸起及凹陷狀態的陣列
Dim GridNote() As Byte
'重玩設定
Private Sub Command1_Click()
Dim I As Long

    '將所有圖形都還原成凸起
    For I = 0 To UBound(GridNote)
        GridNote(I) = 0
    Next

    '畫板重繪
    Picture1_Paint
End Sub
Private Sub Form_Load()
    With Picture1
        '畫算 16 點 Pixel 格子相對高度及寬度
        GW = ScaleX(GRIDLENGTH, vbPixels, .ScaleMode)
        GH = ScaleY(GRIDLENGTH, vbPixels, .ScaleMode)
        '換算格子邊線寬度
        LineWidth = ScaleX(1, vbPixels, .ScaleMode) * BODERWIDTH
        '先維持 Picture1 一格大小，以利基本圖形繪製。
        .Width = GW + .Width - .ScaleWidth
        .Height = GH + .Height - .ScaleHeight
    End With
    '執行畫平面圖及凸起圖之自訂函數
    GetGridPic LineWidth

    '設定橫軸縱軸格數都是 8
    GridHNum = 8
    GridVNum = 8
    With Picture1
        '設定 Picture1 可容納 8*8=64 個格子的大小。
        .Width = GW * GridHNum + .Width - .ScaleWidth
        .Height = GH * GridVNum + .Height - .ScaleHeight
        '移動命令紐位置
        Command1.Move .Left + .Width + GW, .Top
        '調整表單大小
        Me.Width = .Left + .Width + Command1.Width + _
                GW * 2 + Me.Width - Me.ScaleWidth
        Me.Height = .Top + .Height + GH + Me.Height - _
                Me.ScaleHeight
    End With

    '設定 GridNote 總數為 64 個
    ReDim GridNote(GridHNum * GridVNum - 1)

    Command1.Caption = "重玩"
    Me.Caption = "踩地雷畫面模擬範例"
End Sub
'畫平面圖及凸起圖之自訂函數
Private Sub GetGridPic(ByVal Width As Single)
    '先把平面圖設給 GridPic(1)
    Set GridPic(1) = Picture1.Image
    '打開 AutoRedraw 功能才能記錄繪圖動作
    Picture1.AutoRedraw = True
    '切斷 GridPic(1) 與 Picture1.Image 的參照
    Picture1.Cls
    '上界白邊
    Picture1.Line (0, 0)-(GW, Width), QBColor(15), BF
    '右界黑邊
    Picture1.Line (GW - Width, 0)-(GW, GH), QBColor(0), BF
    '下界黑邊
    Picture1.Line (GW, GH - Width)-(0, GH), QBColor(0), BF
    '左界白邊
    Picture1.Line (Width, GH)-(0, 0), QBColor(15), BF
    '把凸起圖設給 GridPic(0)
    Set GridPic(0) = Picture1.Image
    '清掉 Picture1
    Picture1.Cls
    '關掉 AutoRedraw 功能以節省系統資源
    Picture1.AutoRedraw = False
End Sub
'在指定編號的格子中繪圖
Private Sub PaintGridPic(ByVal ArrayNo As Byte)
'橫軸第幾格
Dim HNo As Integer
'縱軸第幾格
Dim VNo As Integer

    VNo = ArrayNo \ GridHNum
    HNo = ArrayNo Mod GridHNum
    With Picture1
        '依 GridNote(ArrayNo) 的儲存值決定顯示圖形
        If GridNote(ArrayNo) = 0 Then
            '顯示凸起圖
            .PaintPicture GridPic(0), GW * HNo, GH * VNo
        Else
            '顯示平面圖
            .PaintPicture GridPic(1), GW * HNo, GH * VNo
        End If
    End With
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim CalcNo As Long
Dim WNo As Integer, HNo As Integer

    '依滑鼠位置換算出格子編號，
    '再依編號畫出圖形
    If Button = 1 Then
        WNo = X \ GW
        HNo = Y \ GH
        CalcNo = HNo * GridHNum + WNo
        '設定陣列相對元素註記為平面圖
        GridNote(CalcNo) = 1
        '將編號送到 PaintGridPic 自訂函數
        PaintGridPic CalcNo
    End If
End Sub
Private Sub Picture1_Paint()
Dim I As Long
    '逐一繪出各格子圖形
    For I = 0 To UBound(GridNote)
        PaintGridPic I
    Next
End Sub

回索引

雙線固定視窗的切換

ㄏㄡ茫啦... 撰寫於文章

當一個form設定為雙線固定時,這一個程式在執行的時候,>就無法用alt+tab去切換,好像是變成背景執行的程式了...有沒有辦法可以加以解決呢??

fumi 答：

ShowInTaskbar 設為 True....

圖片的 90 度翻轉

YQ 撰寫於文章

請問一下呀要怎樣在VB中將圖片讓他旋轉呀

老怪答：

'執行本範例請於表單上布置 Command1,2,3,4、Picture1,2
'本範例只支援 90 度旋轉，預任意角度旋轉圖形，必須使用三角函數，
'範例請參考 CWW http://sunh.hosp.ncku.edu.tw/~cww/ VB心得筆記
Option Explicit
'API SetPixel 在 VB 裏相對應功能為 PSet ，GetPixel 為 Point ，
'但為求更快速畫點，故採用 API 。
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, _
        ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, _
        ByVal X As Long, ByVal Y As Long) As Long
'圖區高度及寬度
Dim PicWidth As Integer, PicHeight As Integer
'邊界寬度
Dim TransX As Single, TransY As Single
'是否進行旋轉重繪
Dim ReDraw As Boolean
'水平翻轉鈕
Private Sub Command1_Click()
    With Picture1
        '設為 AutoRedraw 設為 True 才能取得 Picture1.Image
        .AutoRedraw = True
        '設定進行旋轉重繪，抑制 Picture1_Paint 重繪功能
        ReDraw = True
        '水平翻轉的原理在把繪圖起始點設為右端，而寬度為負數。
        .PaintPicture Picture2.Image, PicWidth - 1, 0, -PicWidth, PicHeight,
_
                0, 0, PicWidth, PicHeight
        .AutoRedraw = False
        Picture2.Picture = .Image
        '設定旋轉重繪結束，開放 Picture1_Paint 重繪功能
        ReDraw = False
    End With
End Sub
'垂直翻轉鈕
Private Sub Command2_Click()
    With Picture1
        .AutoRedraw = True
        ReDraw = True
        '垂直翻轉的原理在把繪圖起始點設為底端，而高度為負數。
        .PaintPicture Picture2.Image, 0, PicHeight - 1,
PicWidth, -PicHeight, _
                0, 0, PicWidth, PicHeight
        .AutoRedraw = False
        Picture2.Picture = .Image
        ReDraw = False
    End With
End Sub
'順時針 90 鈕
Private Sub Command3_Click()
Dim I As Integer, J As Integer
    With Picture1
        'Picture1 高度寬度互換
        .Width = ScaleX(PicHeight, vbPixels, Me.ScaleMode) + TransX
        .Height = ScaleY(PicWidth, vbPixels, Me.ScaleMode) + TransY
        ReDraw = True
        .Visible = False
        .AutoRedraw = True

        '原理：把 Picture2 縱線的末端點當做 Picture1 的橫線起始點
        For I = 0 To PicWidth - 1
            For J = 0 To PicHeight - 1
                SetPixel .hdc, J, I, _
                        GetPixel(Picture2.hdc, I, Abs(J - PicHeight) - 1)
            Next
        Next

        .AutoRedraw = False
        '更新繪圖區
        .Refresh
        .Visible = True
        Picture2.Picture = .Image
        '社將圖區寬高度儲存以備下次利用
        PicWidth = Picture1.ScaleWidth
        PicHeight = Picture1.ScaleHeight
        ReDraw = False
    End With
End Sub
'逆時針 90 鈕
Private Sub Command4_Click()
Dim I As Integer, J As Integer
    With Picture1
        .Width = ScaleX(PicHeight, vbPixels, Me.ScaleMode) + TransX
        .Height = ScaleY(PicWidth, vbPixels, Me.ScaleMode) + TransY
        ReDraw = True
        .Visible = False
        .AutoRedraw = True

        '原理：把 Picture2 開始縱線當做 Picture1 的結束橫線
        For I = 0 To PicWidth - 1
            For J = 0 To PicHeight - 1
                SetPixel .hdc, J, Abs(I - PicWidth) - 1, _
                        GetPixel(Picture2.hdc, I, J)
            Next
        Next

        .AutoRedraw = False
        .Visible = True
        .Refresh
        Picture2.Picture = .Image
        PicWidth = Picture1.ScaleWidth
        PicHeight = Picture1.ScaleHeight
        ReDraw = False
    End With
End Sub
Private Sub Form_Load()
    Command1.Caption = "水平翻轉"
    Command2.Caption = "垂直翻轉"
    Command3.Caption = "順時針 90"
    Command4.Caption = "逆時針 90"

    With Picture2
        '使 Picture2 適應圖檔大小
        .AutoSize = True
        .Picture = LoadPicture("c:\temp\1.1.jpg")
        '使 Picture1 與 Picture2 同大小
        Picture1.Width = .Width
        Picture1.Height = .Height
        '單純為圖素會加快描點繪圖
        .ScaleMode = 3
        '儲存 Picture 寬高度
        PicWidth = .ScaleWidth
        PicHeight = .ScaleHeight
        .Visible = False
        '打開 AutoRedraw 才能取得 Visible = False 的圖點
        .AutoRedraw = True
    End With

    With Picture1
        '儲存邊界 Twip 值以供調整圖形大小之用
        TransX = .Width - .ScaleWidth
        TransY = .Height - .ScaleHeight
        .ScaleMode = 3
    End With

End Sub
Private Sub Picture1_Paint()
    '如果不是在旋轉重繪動作中則重繪圖型
    If Not ReDraw Then
        With Picture1
            .PaintPicture Picture2.Image, 0, 0, PicWidth, PicHeight, _
                    0, 0, PicWidth, PicHeight
        End With
    End If
End Sub

字串對齊輸出

分散對齊輸出：
'Windows 字型在列印時，常為欄位對齊而苦，因為就算字串字數完全一樣，
'也可能因個別字元寬窄不同，而造成字串輸出寬窄不同(最明顯的例子是空白字元)。
'就因為此種特性，使得以往在 Dos 時代，用空白字元補齊字串長度，以求輸出
'欄位對齊的方式變的不可行，因此詳細計算輸出物件的座標，移動輸出的目前位置再
'加以輸出，雖然是一件苦差，但為求輸出的準確，似乎是免不了的事。
'本範例就在展示如何利用 VB 輸出物件的 CurrentX,CurrentY 屬性，達成所有輸出
'字串畫面長度一樣，並有 Word 常用 "分散對齊" 格式的效果。

'測試本範例，請於 Form 上布置 Command1、Picture1

Option Explicit
Private Sub Command1_Click()
Dim SendArray(2) As String
Dim I As Byte

    SendArray(0) = "1234567890"
    SendArray(1) = "VB 6.0 問世"
    SendArray(2) = "長度相同的字串輸出"

    For I = 0 To 2
        '逐一把字串陣列送往字串輸出自訂函數顯示，
        '取字長度是 10 個中文字
        FixWidthString 10, SendArray(I)
    Next
End Sub
'分散對齊輸出自訂函數
'StringLength 取字長度
'AcceptString 對齊字串
Private Sub FixWidthString(ByVal StringLength As Integer _
        , ByVal AcceptString As String)
'計算取字有多寬的字串變數
Dim CalcString As String
'兩字間隔的寬度
Dim SepWidth As Single
Dim I As Integer
'儲存上次輸出的結尾位置
Dim oldY As Single, oldX As Single

    '接收字串比取字長度長則截斷
    If Len(AcceptString) > StringLength Then
        AcceptString = Left(AcceptString, StringLength)
    End If

    '將取字變數填滿中文字
    CalcString = String(StringLength, "國")
    '計算兩字間隔的寬度，原理是取字變數比傳入字串多出的長度，
    '要平均插入兩字間隔中
    SepWidth = (Picture1.TextWidth(CalcString) - _
            Picture1.TextWidth(AcceptString)) / _
            (Len(AcceptString) - 1)

    '記住輸出前的 Y 座標
    oldY = Picture1.CurrentY
    '輸出第一字
    Picture1.Print "[" & Mid(AcceptString, 1, 1)
    '換算接續輸出的 X 座標是多少
    oldX = oldX + Picture1.TextWidth("[" & Mid(AcceptString, 1, 1))

    For I = 2 To Len(AcceptString)
        '回到輸出前的 Y 座標
        Picture1.CurrentY = oldY
        '輸出位置向右移一空白間隔
        oldX = oldX + SepWidth
        '輸出座標移到 oldX
        Picture1.CurrentX = oldX
        Picture1.Print Mid(AcceptString, I, 1)
        '換算接續輸出的 X 座標是多少
        oldX = oldX + Picture1.TextWidth(Mid(AcceptString, I, 1))
    Next
    Picture1.CurrentY = oldY
    Picture1.CurrentX = oldX
    '"[" 和 "]" 主要是為了標示輸出寬度，正式使用時請拿掉。
    Picture1.Print "]"
End Sub
向右對齊輸出：
'測試本範例請於 Form 上布置 Picture1,Command1
'欲使用於列印，將輸出物件由 Picture 轉至 Printer
Option Explicit
Private Sub Command1_Click()
    '以下兩行是把數字在左邊補齊五個字，但最後你會發覺這在輸出
    '對齊上一點用都沒有，因為 Windows 字型寬窄不一，同樣字數字串
    '寬度就是不一樣。
    Picture1.Print Right(Space(5) & Format(123, "###"), 5)
    Picture1.Print Right(Space(5) & Format(12, "###"), 5)

    '下面是呼叫右齊輸出自訂函數，此函數完全放棄了以往 Dos 補字數對齊字串
    '的方法，以圖形座標換算的方式，把不等長字串放在不同位置輸出，達成右齊
    '輸出的目的。
    FixRightPrint CStr(123), 5
    FixRightPrint CStr(12), 5
    '用 "W" 字元的目的是告訴你，同樣是英文字元，字寬差別有多大。
    FixRightPrint "WWWWW", 5
End Sub
'右齊輸出自訂函數
'PrintString 是欲右齊輸出之字串
'PrintLength 是設定輸出之最大字數
'StartPos 是設定輸出時向右偏移字數，省略為不右移。
'以字數換算寬度的概念來說，本涵數以大寫 "W" 寬度為單位。
Private Sub FixRightPrint(ByVal PrintString As String, _
        ByVal PrintLength As Integer, _
        Optional ByVal StartPos As Integer)
'縱合最大字數及偏移字數之計算寬度字串
Dim CalcWidthString As String
    '計算寬度字串等於最大字數加偏移字數
    CalcWidthString = String(PrintLength + StartPos, "W")
    '以單 Byte 字元為計算基準
    PrintString = StrConv(PrintString, vbFromUnicode)

    '只取 PrintLength 字數輸出
    If LenB(PrintString) > PrintLength Then
        PrintString = LeftB(PrintString, PrintLength)
    End If

    '還原為雙位元字
    PrintString = StrConv(PrintString, vbUnicode)

    With Picture1
        '移動輸出之 X 軸
        .CurrentX = .TextWidth(CalcWidthString) - _
                .TextWidth(PrintString)
    End With

    Picture1.Print PrintString
End Sub

回索引

讓 ChildForm 填滿 MDIForm

寄件者: jessy

我的 FORM 的 Midchild 屬性= True，如果設 BorderStyle = 1 ( or 3 ) 則所設計的畫面可以顯現出來，但是Runtime 時無法再調整畫面大小。

而 BorderStyle = 2 , Runtime 時所設計的畫面無法完全顯示出來,但可以調整大小。

,如何將所設計的畫面能完全顯示出來而且還可調整大小。

老怪答：

專案屬性中設 MDIForm 啟動，並把下列碼貼 MDIForm 即可。
Private Sub MDIForm_Load()
    With Me
        .Show
        Load Form1
        Form1.Move 0, 0, .ScaleWidth, .ScaleHeight
        Form1.Show
    End With
End Sub

關閉所有程式載入的表單

XXX 撰寫於文章

請問要如何用一個指令關閉程式中所有的 Form ?

老怪答：

當然最直覺而簡單的做法就是寫上 End 敘述，但這卻是很遭糕的方法。因為只要 VB 碰到 End 敘述，它就不會執行 Form_UnLoad 程序，而直接跳離。所以釋放記憶體、清除物件、資料回寫磁碟及解除檔案鎖定，這些原本慣例放在 UnLoad 程序中執行的動作，都執行不到，因此這種程式每執行一次，就傷害系統一次，甚至導致系統必須重開機才能恢復正常。
所以執行下列程式碼就可以讓使用者下一次指令，就關閉所有的 Form ，並且所有 Form 的 UnLoad 程序都執行的到：
Dim CloseForm As Form

For Each CloseForm In Forms
Unload CloseForm
Next
但我們還該有個認識，並不是 UnLoad Form 之後 Form 必然就被釋放，如果 SecondForm_UnLoad 程序中有：
Private Sub SecondForm_Unload(Cancel As Integer)
If Not 確定脫離 Then
Cancel = True
End If
End Sub
敘述，而當 [確定脫離]= False 時，Form 仍然是無法脫離的，為了在別的 Form 也能關掉此 Form ，則 [確定脫離] 應在一般區宣告為 Public ，才能在別的 Form 利用 FormName.確定脫離=True 敘述，把表單設為能脫離的狀況。所以脫離敘述應改為：
Dim CloseForm As Form

SecondForm.確定脫離=True
For Each CloseForm In Forms
Unload CloseForm
Next

用捲軸設定顏色值

本範例是用三個捲軸來改變色彩值裏的 R、G、B 三原色，重點是把 Color 的長整數值(Long Type)，分離成分別的 R、G、B Byte 值(0~255)。
執行本範例請於表單布置 Label1、Option1,2、HScroll1,2,3。
程式範例如下：
Option Explicit

Private Const ChangeFrontColor As Byte = 0
Private Const ChangeBackColor As Byte = 1

Private Sub Form_Load()
    Option1.Caption = "文字色彩"
    Option2.Caption = "背景色彩"
    Label1.ForeColor = RGB(0, 0, 0)
    Label1.BackColor = RGB(&HC0, &HC0, &HC0)

    HScroll1.Max = 255
    HScroll1.Min = 0
    HScroll1.LargeChange = 15
    HScroll1.SmallChange = 1

    HScroll2.Max = 255
    HScroll2.Min = 0
    HScroll2.LargeChange = 15
    HScroll2.SmallChange = 1

    HScroll3.Max = 255
    HScroll3.Min = 0
    HScroll3.LargeChange = 15
    HScroll3.SmallChange = 1
End Sub

Private Sub HScroll1_Change()
    ColorChange
End Sub

Private Sub HScroll1_Scroll()
    ColorChange
End Sub

Private Sub HScroll2_Change()
    ColorChange
End Sub

Private Sub HScroll2_Scroll()
    ColorChange
End Sub

Private Sub HScroll3_Change()
    ColorChange
End Sub

Private Sub HScroll3_Scroll()
    ColorChange
End Sub

Private Sub Option1_Click()
    SetScrollValue
End Sub

Private Sub Option2_Click()
    SetScrollValue
End Sub

'跟據 HScroll.Value 值來設定 Label Color 的自訂函數
Private Sub ColorChange()
    If Option1 Then
        Label1.ForeColor = RGB(HScroll1.Value, _
                HScroll2.Value, HScroll3.Value)
    Else
        Label1.BackColor = RGB(HScroll1.Value, _
                HScroll2.Value, HScroll3.Value)
    End If
End Sub

'跟據 Label Color 值來設定 HScroll.Value 的自訂函數
Private Sub SetScrollValue()
Dim LongColor As Long

    If Option1 Then
        LongColor = Label1.ForeColor
    Else
        LongColor = Label1.BackColor
    End If

    HScroll1.Value = LongColor Mod 256
    LongColor = LongColor \ 256
    HScroll2.Value = LongColor Mod 256
    LongColor = LongColor \ 256
    HScroll3.Value = LongColor Mod 256
End Sub

公文結案日計算範例

寄件者: Jeff Chen

我想設計一程式用以計算公文的辦理時間,規定是最速件一天,速件三天,普通件七天,但是需跨過假日(國定假日及週休二日) 請問要如何計算出,應該辦完的日期.

老怪答：

Option Explicit

'找某一個週六日期做為推算週休二日的基準日期
Private Const 週六基準日 As Date = #1/3/98#

'如果基準日期是休假的則此常數為 0 ，否則應改為 1。
Private Const 週休二日 As Byte = 0

'放所有國定假日的日期陣列
Dim 假日陣列() As Date

'本函數是用來查核某日期是否為放假日，其準則有三：
'星期日則本函數等於 True
'週休二日的星期六則本函數等於 True
'特定例假日則本函數等於 True
Private Function 假日查核(ByVal CheckDay As Date) As Boolean
Dim I As Integer
Dim 是否假日 As Boolean

    '如果星期日則本函數等於 True
    If WeekDay(CheckDay) = vbSunday Then
        是否假日 = True
    '如果非星期日
    Else
        '如果星期六
        If WeekDay(CheckDay) = vbSaturday Then
            '特定日期減去基準日期除以七，是表示距離基準日期的第幾週。
            '將第幾週數目取 2 的餘數就可以判斷週休二日的輪替。
            If Int((CheckDay - 週六基準日) / 7) Mod 2 = 週休二日 Then
                是否假日 = True
            End If
        End If

        '最後是把所有非週休二日的星期六及其他日期，依我們在
        '[其他例假日] Sub 中放入的假日陣列來判斷是否國定假日。
        If Not 是否假日 Then
            For I = 0 To UBound(假日陣列)
                If CheckDay = 假日陣列(I) Then
                    是否假日 = True
                    Exit For
                End If
            Next
        End If
    End If

    假日查核 = 是否假日
End Function

Private Sub 其他例假日()
    ReDim 假日陣列(2)

    '將國定假日以列舉方式一一放入陣列中，請自行補足不足項目
    假日陣列(0) = DateSerial(Year(Date), 3, 29)     '青年節
    假日陣列(1) = DateSerial(Year(Date), 10, 10)    '國慶日
    假日陣列(2) = DateSerial(Year(Date), 12, 25)    '行憲紀念日
End Sub

Private Sub Form_Click()
Dim CalcDay As Date

    '隨便選一日測試
    CalcDay = #11/20/98#
    CalcDay = 結案日(CalcDay, 7)
    Debug.Print CalcDay
End Sub

Private Sub Form_Load()
    '執行放入假日自訂程序
    其他例假日
End Sub

Private Function 結案日(ByVal 收件日 As Date, _
        ByVal 辦理日數 As Integer) As Date
Dim RetrunDay As Date
'I 是假日查核指標，J 是實際工作天數累計。
Dim I As Integer, J As Integer
    If 辦理日數 < 1 Then
        MsgBox "辦理日數最少為一天"
        Exit Function
    End If

    Do While J < 辦理日數
        I = I + 1
        If Not 假日查核(收件日 + I) Then
            J = J + 1
            結案日 = (收件日 + I)
        End If
    Loop
End Function

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   3840
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   3840
   StartUpPosition =   3 '系統預設值
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   495
      Left            =   2280
      TabIndex        =   2
      Top             =   2400
      Width           =   1215
   End
   Begin VB.Frame Frame1
      Caption         =   "Frame1"
      Height          =   1935
      Left            =   240
      TabIndex        =   1
      Top             =   1080
      Width           =   1575
      Begin VB.TextBox Text1
         Height          =   270
         Index           =   2
         Left            =   600
         TabIndex        =   8
         Text            =   "Text1"
         Top             =   1320
         Width           =   615
      End
      Begin VB.TextBox Text1
         Height          =   270
         Index           =   1
         Left            =   600
         TabIndex        =   6
         Text            =   "Text1"
         Top             =   840
         Width           =   615
      End
      Begin VB.TextBox Text1
         Height          =   270
         Index           =   0
         Left            =   600
         TabIndex        =   4
         Text            =   "Text1"
         Top             =   360
         Width           =   615
      End
      Begin VB.Label Label2
         Caption         =   "Label2"
         Height          =   255
         Index           =   2
         Left            =   240
         TabIndex        =   7
         Top             =   1320
         Width           =   615
      End
      Begin VB.Label Label2
         Caption         =   "Label2"
         Height          =   255
         Index           =   1
         Left            =   240
         TabIndex        =   5
         Top             =   840
         Width           =   615
      End
      Begin VB.Label Label2
         Caption         =   "Label2"
         Height          =   255
         Index           =   0
         Left            =   240
         TabIndex        =   3
         Top             =   360
         Width           =   615
      End
   End
   Begin VB.Timer Timer1
      Left            =   3120
      Top             =   360
   End
   Begin VB.Shape Shape1
      Height          =   255
      Left            =   2040
      Shape           =   3 '圓形
      Top             =   480
      Width           =   255
   End
   Begin VB.Label Label1
      Caption         =   "Label1"
      Height          =   495
      Left            =   360
      TabIndex        =   0
      Top             =   360
      Width           =   2055
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim SetTime As Date
Private Sub Command1_Click()
    If Command1.Caption = "設定時間" Then
        Frame1.Visible = True
        Command1.Caption = "確定時間"
    Else
        Frame1.Visible = False

        If Val(Text1(0).Text) > 24 Then Text1(0).Text = 24
        If Val(Text1(1).Text) > 60 Then Text1(1).Text = 60
        If Val(Text1(2).Text) > 60 Then Text1(2).Text = 60

        If Text1(0).Text = "" Then Text1(0).Text = 0
        If Text1(1).Text = "" Then Text1(1).Text = 0
        If Text1(2).Text = "" Then Text1(2).Text = 0

        SetTime = TimeSerial(Val(Text1(0).Text), Val(Text1(1).Text), _
                Val(Text1(2).Text))
        Command1.Caption = "設定時間"
        Debug.Print SetTime
    End If
End Sub
Private Sub Form_Load()
    Timer1.Interval = 1000
    Label1.BackColor = RGB(125, 0, 255)
    Label1.ForeColor = RGB(0, 255, 255)
    Label1.FontSize = 24

    Shape1.FillStyle = 0
    Shape1.FillColor = RGB(0, 255, 0)

    Frame1.Caption = "請輸入日期"
    Frame1.Visible = False

    Label2(0).Caption = "時"
    Label2(1).Caption = "分"
    Label2(2).Caption = "秒"

    Text1(0).Text = ""
    Text1(1).Text = ""
    Text1(2).Text = ""

    Command1.Caption = "設定時間"

    ShowTime
End Sub
Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
'KeyAscii 32 以下是一些控制鍵，攔截會造成操作障礙
    If KeyAscii >= 33 Then
        If KeyAscii <= vbKey9 And KeyAscii >= vbKey0 Then
        Else
            '把 KeyAscii 設為 0 就是取消輸入
            KeyAscii = 0
            MsgBox "不可輸入非數字字元"
        End If
    End If
End Sub
Private Sub Timer1_Timer()
    ShowTime
End Sub
Private Sub ShowTime()
Dim SubTime As Date
    Shape1.FillColor = RGB(0, 255, 0)
    SubTime = TimeSerial(Hour(Now), Minute(Now), Second(Now))
    Label1.Caption = SubTime

    '在時間到達後的六秒，會有提醒燈號及聲音
    If SubTime > SetTime And SubTime < TimeSerial(Hour(SetTime), _
            Minute(SetTime), Second(SetTime) + 6) Then
        Shape1.FillColor = RGB(255, 0, 0)
        Beep
    End If
End Sub

回索引

最快的開檔模式

安安撰寫於文章

我如果開啟一個超過1mb容量的文字檔,都會覺得很慢!誰可以我指導一下,開啟檔案的一些技巧呢?

老怪答

就我個人在 VB 實作上，File I/O 的 Open Mode ，Input、Random、Binary 裏，以 Binary Mode 的速度最快，所以我為 VB 友介紹的快速開檔方式都是：
Option Explicit

Dim FileHandle As Integer
Dim Buff() As Byte
Dim LongString As String

    FileHandle = FreeFile
    Open "YourFilePath&Name" For Binary As #FileHandle
    ReDim Buff(LOF(FileHandle) - 1)
    Get #FileHandle, , Buff
    Close #FileHandle
那怎麼轉成文字模式呢？很簡單，
- 純英文字串：
  - LongString = Buff
- 不確定中英文：
  - LongString = StrConv(Buff, vbUnicode)
在以往我都沒有解釋為何 Binary Mode 最快，在這裏我想解釋一下，如果不對，請大家指正。
我們用 Input Mode 開檔，則是利用迴圈以 Input #FileHandle,Var1,Var2,Var3 讀入檔案，或以 Line Input #FileHandle,VarString 讀入檔案，不管是 Input # or Line Input # 陳述式，讀檔的動作都是把檔案逐字比對，遇到 "," 及 VbCrLf 字元，則切割讀入字元，放入變數中。所以你有 1 Mega 大小檔案，它就必須讀取比對 1 Mega 次。
Random 模式則好一點，他以固定記錄長度讀取資料，也就是它不會做逐字比對的工作，而是一次抓記錄長度的字串到記憶體裏，再做資料的分配，其中有無分隔字元或分行符號，它是一概不管的。
Binary 和 Random 讀取檔案的基本原理是相同的，那就是讀取固定長度資料而不做逐字比對。但 Random 是以自訂型態變數長度，配合迴圈，分段讀取檔案。而 Binary 則是由你自行指定接收檔案資料 ByteArray 的長度，完全不利用迴圈，一次讀進來。ByteArray 短於 File Length ，則只讀取部份，若長於 File Length，則不足部份 ByteArray 值是 0，要注意的是 Chr(0)<>"" ，Chr(0) 仍佔有字串長度，在做字串轉換時要注意。也因為 Binary 是一次讀取，所以在全檔讀取上，效率比 Random 的分段讀取要好。
在我剛學會 Binary Open Mode ，也順利的用 ByteArray 變數取回檔案資料後，我曾好長一段時間用下列笨笨的方法將 ByteArray 用下列方式轉成字串：
For I=0 To Ubound(Buff)
LongString=LongString + Chr(Buff(I))
Next
因為 Byte 與 String 變數型態不同，按道理應該透過轉換函數啊，所以我仍是算了 1 Mega 次。
直到我看到了別人用 LongString =Buff 這種直接轉換的範例，又知道了 Windows OS 在處理記憶體堆疊有一個 AddressOf() 函數的功能(VB 沒有開放此函數使用)，知道要整批取得陣列資料，可以不用陣列指標逐筆索引，而是取得陣列開始記憶體位置後，一次讀取整個陣列長度的資料到字串變數裏，因此我猜 LongString=Buff 的敘述，就是讓 VB 啟用 AddressOf() 的功能，一次把整個 Buff 陣列一次放入 LongString 字串變數裏。因此 Binary 之所以快的原理就是取得磁碟檔案的開始位置，不經任何比對，一次取出固定長度資料到記憶體，再在計憶體中找到陣列記憶體位址，一次讀固定長度到 StringVariant 中，用的演算很少，自然速度飛快。
Binary 可以說是最原始的檔案讀取型態，因為它不執行分行分欄的功能，所以我們得自行對讀入資料加以分行分欄。
至於記憶體資料的輸出，如果是非文字的二進位檔，那當然還是得用 Binary 方式輸出，至於文字檔，由於就算用 Bianry 輸出，我們還是得先逐行逐筆加入分欄分行資料到 Byte 陣列裏，才會存成正確的文字檔格式，所以用 Output、Append、Random 與 Binary 速度所差無幾，但卻比 Binary 方便很多。

回索引

怎樣點取 Disable 的物件

XXX 撰寫於文章

我在一個Form中擺了個 Frame，我在Form Load時將 Frame Disable，我想讓滑鼠在Frame上點一下,才Enable被點到的Frame，因為Frame未Enable前無法接受任何事件，要如何才能做到呢?

老怪答：

雖然 Frame1.Visible=False 後，Form 上還看得到 Frame1 淡灰色影像，但當我們 MouseClick 後，收到 Mouse Event 的卻是 Frame 背後的物件，所以如果 Frame1 後面就是 Form 的話，可以使用 Form 來接收 Mouse Event ，並使 Frame1.Enable=True：
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With Frame1
        If (X > .Left And X < .Left + .Width) And (Y > .Top And Y < .Top + .Height) Then
            .Enabled = True
        End If
    End With
End Sub

回索引

圖片捲動盒範例

藍色閃靈撰寫於文章

如何才能利用水平和垂直調節鈕來控制圖片方塊裡的圖片呀?

老怪答：

範例功能：
- 圖片置於 Picturebox 中央顯示。
- 圖片比 PictureBox 大則有捲軸。
- 有放大縮小的功能
範例程式碼：
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3750
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   5235
   LinkTopic       =   "Form1"
   ScaleHeight     =   3750
   ScaleWidth      =   5235
   StartUpPosition =   3 '系統預設值
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   3720
      Top             =   1920
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   327680
   End
   Begin VB.HScrollBar HScroll1
      Height          =   255
      Left            =   960
      TabIndex        =   2
      Top             =   2880
      Width           =   1335
   End
   Begin VB.VScrollBar VScroll1
      Height          =   1335
      Left            =   4560
      TabIndex        =   1
      Top             =   480
      Width           =   255
   End
   Begin VB.PictureBox Picture1
      Height          =   2055
      Left            =   240
      ScaleHeight     =   1995
      ScaleWidth      =   2475
      TabIndex        =   0
      Top             =   360
      Width           =   2535
      Begin VB.Image Image1
         Height          =   615
         Left            =   960
         Top             =   480
         Width           =   1215
      End
   End
   Begin VB.Menu mnuFile
      Caption         =   "檔案(&F)"
      Begin VB.Menu mnuOpenFile
         Caption         =   "開啟圖檔(&O)"
      End
      Begin VB.Menu mnuQuitApp
         Caption         =   "結束(&Q)"
      End
   End
   Begin VB.Menu mnuView
      Caption         =   "檢視(&V)"
      Begin VB.Menu mnuZoomIn
         Caption         =   "放大(&I)"
      End
      Begin VB.Menu mnuZoomOut
         Caption         =   "縮小(&S)"
      End
      Begin VB.Menu mnuReset
         Caption         =   "還原(&R)"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'執行本範例要記得引用 CommonDialog 物件，並布置到表單上。
Option Explicit
'記錄原圖片長寬
Dim OPicWidth As Single, OPicHeight As Single
'圖片縮放比
Dim ViewRate As Single
Private Sub Form_Load()
    Me.Caption = "簡易圖片捲動盒:"

    '設定檔案對話盒之啟始路徑為執行程式路徑
    CommonDialog1.InitDir = App.Path

    '設定 CommonDialog 的 Filter 為 VB 支援之圖檔格式
    CommonDialog1.Filter = "所有圖檔|*.bmp;*.dib;*.ico;*.wmf;*.emf;*.jpg;*.gif|" & _
            "Windows 標準圖檔(*.bmp;*.dib)|*.bmp;*.dib|" & _
            "圖示檔(*.ico)|*.ico|向量檔(*.wmf;*.emf)|*.wmf;*.emf|" & _
            "JPeg 壓縮圖檔(*.jpg)|*.jpg|Gif 圖檔(*.gif)|*.gif"

    '把圖片盒單位設為 Pixel ，避免超過 Scroll 設定最大植
    Picture1.ScaleMode = 3

    '圖片縮放一比一
    ViewRate = 1
End Sub
Private Sub Form_Resize()
    '調整 Scroll 位置及圖片盒大小
    With Me
        HScroll1.Move .ScaleLeft, .ScaleHeight - HScroll1.Height, _
                .ScaleWidth - VScroll1.Width, HScroll1.Height
        VScroll1.Move .ScaleWidth - VScroll1.Width, .ScaleTop, _
                VScroll1.Width, .ScaleHeight - HScroll1.Height
        Picture1.Move .ScaleLeft, .ScaleTop, _
                .ScaleWidth - VScroll1.Width, .ScaleHeight - HScroll1.Height
    End With

    '設定 Scroll 捲動值
    HScroll1.LargeChange = 25
    HScroll1.SmallChange = 1
    VScroll1.LargeChange = 25
    VScroll1.SmallChange = 1

    '重設 Scroll 最大最小範圍
    ResetScrollValue
End Sub
Private Sub HScroll1_Change()
    '移動圖片位置
    ReSetImagePosition
End Sub
Private Sub HScroll1_Scroll()
    ReSetImagePosition
End Sub
'利用檔案開啟對話盒開啟顯示圖片
Private Sub mnuOpenFile_Click()
    CommonDialog1.filename = ""
    CommonDialog1.ShowOpen
    If CommonDialog1.filename <> "" Then
        With Image1
            '先關掉 Image 的 Stretch 功能以取得圖片大小
            .Stretch = False
            .Picture = LoadPicture(CommonDialog1.filename)
            OPicWidth = .Width
            OPicHeight = .Height
            '再開啟 Image 的 Stretch 功能才能縮放圖片
            .Stretch = True
        End With
        '重設取圖路徑
        CommonDialog1.InitDir = CutImagePath(CommonDialog1.filename)
        '重設 Scroll 最大最小值
        ResetScrollValue
    End If
End Sub
Private Sub mnuQuitApp_Click()
    Unload Me
End Sub
'依 Scroll 值移動圖片
Private Sub ReSetImagePosition()
    With Image1
        .Move HScroll1.Value, VScroll1.Value
    End With
End Sub
Private Sub ResetScrollValue()
Dim Offset As Long

    With HScroll1
        .Enabled = True
        Offset = (Picture1.ScaleWidth - Image1.Width) / 2
        '當圖片比圖片盒小時取消 Scroll 功能
        If Offset > 0 Then
            .Enabled = False
        End If
        .Min = 0
        '請注意，當設定 Scroll 的 Max 和 Value 值時都會自動觸發
        'Scroll_Change 事件
        .Max = Offset * 2
        .Value = Offset
    End With

    With VScroll1
        .Enabled = True
        Offset = (Picture1.ScaleHeight - Image1.Height) / 2
        If Offset > 0 Then
            .Enabled = False
        End If
        .Min = 0
        .Max = Offset * 2
        .Value = Offset
    End With
End Sub
Private Sub mnuReset_Click()
    '還原圖片縮放
    With Image1
        .Width = OPicWidth
        .Height = OPicHeight
    End With
    ViewRate = 1
    ResetScrollValue

    '恢復所有縮放功能
    mnuZoomIn.Enabled = True
    mnuZoomOut.Enabled = True
End Sub
Private Sub mnuZoomIn_Click()
    If ViewRate >= 8 Then
        '當超過 8 倍則停止放大
        mnuZoomIn.Enabled = False
    Else
        ViewRate = ViewRate + 0.25
        With Image1
            .Width = OPicWidth * ViewRate
            .Height = OPicHeight * ViewRate
        End With
        ResetScrollValue
    End If
    mnuZoomOut.Enabled = True
End Sub
Private Sub mnuZoomOut_Click()
    If ViewRate <= 0.1 Then
        '當小於 1/10 則停止縮小
        mnuZoomOut.Enabled = False
    Else
        ViewRate = ViewRate - 0.25
        With Image1
            .Width = OPicWidth * ViewRate
            .Height = OPicHeight * ViewRate
        End With
        ResetScrollValue
    End If
    mnuZoomIn.Enabled = True
End Sub
Private Sub VScroll1_Change()
    ReSetImagePosition
End Sub
Private Sub VScroll1_Scroll()
    ReSetImagePosition
End Sub
'將完整路徑切去檔名的自訂函數，目的是重設 CommonDailog 的 InitDir 屬性
Private Function CutImagePath(ByVal WholeString As String) As String
Dim I As Integer
    For I = Len(WholeString) To 1 Step -1
        If Mid(WholeString, I, 1) = "\" Then
            CutImagePath = Left(WholeString, I - 1)
            Exit For
        End If
    Next
End Function

回索引

檢查目錄中特定檔案是否存在

水牛撰寫於文章

各位前輩大家好，小弟寫了一段程式來開啟檔案，在這之前想加入一些程式碼來檢查檔案是否確定存在，應該怎麼做比較好呢?

老怪答：

Dim DirReturn As String
Dim DirSend As String
Dim MsgString As String

    DirSend="YourFilePath&Name"
    DirReturn = Dir(DirSend, vbHidden Or vbDirectory Or vbReadOnly Or vbSystem)

    If DirReturn="" Then
        MsgString="找沒有啦"
    Else
        MsgString="找到了 " & DirReturn & " 檔案"
    End If

    MsgBox MsgString

回索引

Collection 應用舉例

Peter 撰寫於文章

請問什麼是集合物件(Collection)？要怎麼使用？及其使用時機為何？

老怪答：

當你需要陣列處理。
當你陣列裏的資料非同質時。
Count,Item,Add,Remove 的方法，自己查 Help。
程式舉例：
如你想把 Form 上一個 Text1,Label1,Command1 做一組，一起改變字型設定，則：
Option Explicit

Dim MyCol As Collection

Private Sub Form_Load()
    Set MyCol = New Collection

    MyCol.Add Text1
    MyCol.Add Label1
    MyCol.Add Command1
End Sub

Private Sub 大字型()
Dim I As Integer
    For I = 1 To MyCol.Count
        MyCol.Item(I).FontSize = 18
        MyCol.Item(I).FontBold = True
    Next
End Sub

Private Sub 小字型()
Dim I As Integer
    For I = 1 To MyCol.Count
        MyCol.Item(I).FontSize = 10
        MyCol.Item(I).FontBold = False
    Next
End Sub

注意：Collection.Item(Index) 基底為 1 而非 VB 一般預設的 0 。

回索引

時間暫停

暫時想不到撰寫於文章

請問VB如何寫才能達到時間暫停幾秒的功能？

老怪答：

Dim Delay As Date
    Me.MousePointer = 11

    Delay = Now
    Do While Second(Now - Delay) < 3
    Loop
    Me.MousePointer = 0

暫停三秒鐘

回索引

一物控多項

倫倫撰寫於文章

在使用模組時...如果需要用到 form1 的控制項...必須寫成 form1.XXX ，有沒有辦法改某些設定...可以不用加 form1.。

老怪答：

在專案中加入 Form1,Form2,Moudle1
專案設為 Sub Main() 啟動
在 Module1 加入：
Public TextA As TextBox
Sub Main()
Set TextA = Form2.Text1
Form1.Show
End Sub
在 Form2 上放 Text1,2
在 Form1 加入：
Private Sub Command1_Click()
    TextA.Text = "Form2.Text1 Be Change"
    Set TextA=Form2.Text2
    TextA.Text = "Form2.Text2 Be Change"
    Form2.Show
End Sub

VB5 初級生 老怪範例(七)

分類

標題

大意

作者

日期

VB5 初級生老怪範例(七)