VB5 初級生 老怪範例(六)

回首頁

分類

標題

大意

作者

日期
流程控制 如何偵測出程式陷入了無限 GOTO 　 老怪 1998/9/21
流程控制 按一鍵再執行 模擬 getch() 老怪 1998/9/21
流程控制 多迴圈同時進行 　 老怪 1998/10/14
物件使用 如何求取 Forms 的 Index 值 Forms 集合物件的使用 老怪 1998/9/21
檔案 I/O 中文文字檔的開啟模式 　 老怪 1998/9/21
裝置驅動 偵測磁碟機是否已ready 　 老怪 1998/9/25
變數處理 在 Call & BeCall 中傳遞陣列 有求必應的 Variant 型態變數 老怪 1998/9/24
數值處理 如何將亂數產生在固定數值之間 　 老怪 1998/10/1
數值處理 九九乘法表 雙層迴圈範例 老怪 1998/10/7
數值處理 四捨五入函數 用 Format 函數四捨五入 老怪 1998/10/8
輸入檢查 離開輸入盒即檢查輸入是否正確 LostFocus 事件 老怪 1998/10/2
使用者界面 讓無框線表單不遮住 TaskBar SysInfo Control 的使用 老怪 1998/10/3
使用者界面 滑鼠游標彩色變黑白 CUR 和 ICO 圖檔格式 老怪 1998/10/5
使用者界面 用文字檔儲存程式設定 拋開 Windows 登錄 老怪 1998/10/18
使用者界面 用滑鼠拖曳圖片 以 MouseMove 代替 Drag 老怪 1998/10/27
FileBox使用 拖曳複製多個檔案範例 　 老怪 1998/10/8
TextBox使用 讓 TextBox 不變色的 Unabled 　 老怪 1998/10/8
ScrollBar使用 用 ScrollBar 捲動 Label 　 老怪 1998/10/10
PictureBox使用 斜向漸層的製作 PictureBox.Line 方法 老怪 1998/10/26
字串處理 整數補空白，小數補零。 Format 函數的使用 老怪 1998/10/8

VB5 初級生範例使用說明

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

回索引

如何偵測出程式陷入了無限 GOTO

Cheng Tom 撰寫於文章

有什麼方法可以偵測出程式陷入了無限 GOTO ?

老怪答：

Dim 數值檢查 As Integer

Private Sub 被呼叫副程序()
    Debug.Print 數值檢查
    數值檢查=數值檢查+1
    執行程式
    Call 其他副程序
    數值檢查=數值檢查-1
End Sub

  1. 原理是副程序如果再 Call 其他副程序，此再 Call 動作如果有返回，則會執行 [數值
    檢查=數值檢查-1]。
  2. 如果一去不回，則 [數值檢查=數值檢查-1] 就執行不到(注意，如
    果程序中有 Exit Sub or Function 指令，要把 數值檢查=數值檢查-1 排在 Exit 動作之前。)，數值檢查就會一直累加下去。
  3. 所以我們觀察 Debug Window ，數值檢查一直往上加，表示八成進了無窮迴圈中，若時上時下的，應該是還沒執行完畢，你試試Work 不 Work ，因為我也沒把握。這個題目應該還有其他作法，希望大家集思廣義一下。

回索引

如何求取 Forms 的 Index 值

我依然是小呆瓜 撰寫於文章

要如何簡單得知一個GetFocus的子視窗它的Forms(I)中 I 的數值

老怪答：

Private Sub Command1_Click()
Dim I As Integer
Dim FormIndex As Integer
    For I = 0 To Forms.Count - 1
        If Forms(I) Is Me.ActiveForm Then
            FormIndex = I
            Exit For
        End If
    Next

    Debug.Print FormIndex
End Sub

回索引

中文文字檔的開啟模式

  1. Input #
  2. InPutB()
  3. ByteArray 的使用

回索引

在 Call & BeCall 中傳遞陣列

(一半) 的文章中提到:

VB的SUB可以傳遞陣列嗎?看了線上手冊沒看到範例,是否真的不行嗎?

老怪答：

  1. 先談 VB 5.0 從 Function 中傳回陣列：
  2. 向 Sub 及 Function 傳遞陣列：

回索引

按一鍵再執行

麥克九蛋 撰寫於文章

就是在程式中我想像 getch()的function 按任意鍵再繼續下一步我想應該有吧,有沒人知道呢?

老怪答：

自己寫模擬程式囉

Option Explicit
Dim EndLoop As Boolean
Private Sub Form_Click()
    GetC
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii <> 0 Then
        EndLoop = True
    End If
    Label1.Caption = "LoopIsEnd"
End Sub

Private Sub GetC()
    Do
        If EndLoop Then
            Exit Do
        End If
        Label1.Caption = Now
        DoEvents
    Loop
    EndLoop = False
End Sub

回索引

偵測磁碟機是否已ready

麥克九蛋 撰寫於文章

請問VB5如何得知磁碟機是否已ready??

老怪答：

Private Sub Command1_Click()
Dim OldPath As String

    On Error Resume Next
    OldPath = CurDir
    ChDrive "a:"
    Select Case Err.Number
        Case 68
            MsgBox Err.Description, vbOKOnly, "錯誤代碼：" & Err.Number
    End Select

    ChDrive OldPath

End Sub

回索引

如何將亂數產生在固定數值之間

寄件者: 藍色旅人

老怪答：

Option Explicit
Private Sub Form_Click()
Dim I As Integer

'呼叫固定範圍亂數自定函數
    Debug.print GetRangeRnd(12, 11)
End Sub

Private Function GetRangeRnd(ByVal Max As Integer, _
        Optional ByVal Min As Integer) As Integer
Dim TempNum As Integer
'如果使用者把傳入參數的最小值設的比最大值大，
'那麼大小值互換
    If Min > Max Then
        TempNum = Max
        Max = Min
        Min = TempNum
    End If

'啟動亂數種子
    Randomize
    TempNum = Int((Max - Min + 1) * Rnd) + Min
    GetRangeRnd = TempNum
End Function

回索引

離開輸入盒即檢查輸入是否正確

笨笨的家豬 撰寫於文章

我想當我的 Focus 一離開 TextBox的時候就可以顯示未填寫資料的訊息,這要如何去應用???

老怪答：

Private Sub Text1_LostFocus()
Dim GoBack As Integer
    If Len(Text1.Text) <> 8 Then
        GoBack = MsgBox("你資料輸入不完整，是否重新輸入？", vbYesNo, "資料欠缺")
        If GoBack = vbYes Then
            Text1.SetFocus
        End If
    End If
End Sub

回索引

讓無框線表單不遮住 TaskBar

YIhan 撰寫於文章

請問 Form 如何設定讓它上方無"大小調整"(title)，而下方保留95的工作列，為何我都設不出來?

老怪答：

  1. 上方無"大小調整" 及 Title 的 Form ，其 Border = 0 (沒有框線) ，當你把它 WindowsState=2 (最大化) 時，它會連 Windows TaskBar 都蓋掉，而這也是此種 Form 的使用目的(把整個 Windows 桌面遮掉)。
  2. 怎樣計算 TaskBar 的寬度及它的 Align ，恐怕就得動用 API 了，因為 Screen 物件並無法提供此種訊息。
  3. 不過 VB 外建控制項 SysInfo Control ，提供了一個不需使用 API 的替代方案，你可以：
  4. 把下列程式寫入即可：

回索引

滑鼠游標彩色變黑白

快取 撰寫於文章

用VB 寫一程式,使用自訂之MOUSE ICON,其 游標為彩色,,,但 程式在RUN時,遊標卻變成了黑白的....WHY ???

老怪答：

  1. VB 的滑鼠指標支援副檔名為 CUR 和 ICO 檔的兩種格式圖檔。
  2. CUR 格式圖檔，不管其原先是黑白還是彩色，載入 VB 中顯示都是黑白的。
  3. ICO 格式圖檔才會是彩色的。
  4. VB 不支援動態滑鼠指標(副檔名 ANI)。

回索引

九九乘法表

寧若 撰寫於文章

各位網友.....我是一個VB5.0的初學者.....老師出了一個難題.....那就是要用巢狀迴圈寫一個九九乘法表的程式......而我又剛學VB5.0.....實在是不太會寫.....所以想請各位好心的網友們幫幫我.....感激不盡.....

老怪答：

  1. 其實這麼基本的迴圈使用問題，把它放在範例中，大概許多高手都要大喊"老怪!請注意水準問題。"
  2. 沒辦法，誰叫我們叫初級生範例呢？那就請大家先不要看範例，自己寫寫看，再和我的比一下，有沒比我寫的更簡潔。
  3. 範例如下：
    Private Sub Form_Click()
    Dim I As Byte, J As Byte
    Dim PrintString As String
        For I = 1 To 9
            For J = 1 To 9
                PrintString = PrintString + _
                    "[" & Right("00" & Trim(Str(I * J)), 2) & "]"
            Next
            Me.Print PrintString
            PrintString = ""
        Next
    End Sub

回索引

拖曳複製多個檔案範例

寄件者: 78go

請問.... vb可以做成像cview一樣的工能嗎??? (就是可以選取多個資料後再將它存入其他地方...如disk,或資料庫內)    請提供範例....意見.....thanks

老怪答：

VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 5475
ClientLeft = 60
ClientTop = 345
ClientWidth = 6510
LinkTopic = "Form1"
ScaleHeight = 5475
ScaleWidth = 6510
StartUpPosition = 3 '系統預設值
Begin VB.Frame Frame2
Caption = "目標區"
Height = 4935
Left = 3360
TabIndex = 4
Top = 120
Width = 3015
Begin VB.DriveListBox Drive2
Height = 300
Left = 360
TabIndex = 7
Top = 360
Width = 2295
End
Begin VB.DirListBox Dir2
Height = 1140
Left = 360
TabIndex = 6
Top = 840
Width = 2295
End
Begin VB.FileListBox File2
DragIcon = "Form1.frx":0000
Height = 2250
Left = 360
MultiSelect = 2 '進階多重選取
TabIndex = 5
Top = 2280
Width = 2295
End
End
Begin VB.Frame Frame1
Caption = "來源區"
Height = 4935
Left = 120
TabIndex = 0
Top = 120
Width = 3015
Begin VB.FileListBox File1
DragIcon = "Form1.frx":030A
Height = 2250
Left = 360
MultiSelect = 2 '進階多重選取
TabIndex = 3
Top = 2280
Width = 2295
End
Begin VB.DirListBox Dir1
Height = 1140
Left = 360
TabIndex = 2
Top = 840
Width = 2295
End
Begin VB.DriveListBox Drive1
Height = 300
Left = 360
TabIndex = 1
Top = 360
Width = 2295
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'請不要忘了，來源檔案盒在設計階段 MultiSelect 屬性一定要設為 True
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub

Private Sub Dir2_Change()
File2.Path = Dir2.Path

End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Private Sub Drive2_Change()
Dir2.Path = Drive2.Drive
End Sub

Private Sub File1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'按滑鼠右鍵表示拖曳開始
If Button = 2 Then
File1.Drag 1
End If
End Sub

Private Sub File2_DragDrop(Source As Control, X As Single, Y As Single)
Dim I As Integer
'如果拖曳來源是檔案盒
If TypeName(Source) = "FileListBox" Then
For I = 0 To Source.ListCount - 1
'如果檔案被選取
If Source.Selected(I) Then
FileCopy Source.Path & "\" & Source.List(I), _
File2.Path & "\" & Source.List(I)
End If
Next
'目標檔案盒更新顯示
File2.Refresh
'來源檔案盒結束拖曳動作
Source.Drag 2
End If
End Sub

回索引

整數補空白，小數補零。

jsc72232 撰寫於文章

請問 Format 函數要怎樣設定才能不論數值大小，都有固定長度，並且整數若不足長度則以空位元填入，小數部份則以 "0" 字元補入。

老怪答：

'試試看下面這段
Option Explicit
Private Sub Command1_Click()
    '設定整數九位，小數兩位，小數不足補零，整數不足補空白的格式。
    Text1.Text = Right(Space(11) & Format(5459.4, "###,###,###.00"), 14)
End Sub

Private Sub Form_Load()
    'Courier New 字型是每個字大小都一樣，
    '可以免去英文字寬窄不一的對齊困難。
    Text1.FontName = "Courier New"
End Sub

回索引

四捨五入函數

XXX 撰寫於文章

VB有無現成的四捨五入取整數的函數可用?

老怪答：

  1. 並無現成的四捨五入函數可用，但 VB 在由較精確的數值進入整數時，都會自動有四捨五入的動作。
  2. 你也可以寫一個像下面的範例來用：
    Option Explicit
    Private Sub Command1_Click()
    Dim 取位數 As Byte
    Dim SendNum As Double
    Dim I As Byte

        '設定要四捨五入的數值
        SendNum = 0.123456789123456
        '小數點下取幾位數
        取位數 = 10

        For I = 0 To 取位數
            List1.AddItem 四捨五入進位(SendNum, I)
        Next
    End Sub

    Private Function 四捨五入進位(ByVal newNum As Double _
            , ByVal NumLong As Byte) As Double
    Dim TempString As String

        TempString = Trim(CStr(newNum))
        '把小數點前整數去掉，只留小數。
        TempString = Right(TempString, Len(TempString) - InStr(1, TempString,
    "."))

        '如果傳入之取位數超過小數位數，則以小數位數為取位數長度。
        If Len(TempString) < NumLong Then
            NumLong = Len(TempString)
        End If

        四捨五入進位 = Format(newNum, "0." & String(NumLong, "0"))
    End Function

回索引

讓 TextBox 不變色的 Unabled

離魂 撰寫於文章

在vb中如何使 textbox 不能輸入資料，但又不想使得文字框的字變成灰白色而使用 enabled 屬性，不知是否還有其他的方法可以用呢???

老怪答：

  1. Private Sub Text1_GotFocus()
        Text1.Locked = True
    End Sub
    Private Sub Text1_LostFocus()
        Text1.Locked = False
    End Sub
  2. Private Sub Text2_KeyPress(KeyAscii As Integer)
        KeyAscii = 0
    End Sub
  3. 以上兩種都可以。

回索引

用 ScrollBar 捲動 Label

通訊家 撰寫於文章 ...

請問該如何使用VB的VScrollBAR去連結必須顯示很多字的Label,使其可以使用VScrollBAR翻頁呢??

老怪答：

Option Explicit
'其實用 Vscroll 捲動 Label ，和用 Timer 捲 Label 是一樣的原理，
'所以此處我把 Label 捲動盒與電子捲動看板合而為一，請大家建議批評。
'本範例須用 Label1,Vscroll1,Command1,Picture1,Timer1
Private Sub Command1_Click()
    If Command1.Caption = "開始電子佈告欄" Then
        Command1.Caption = "結束電子佈告欄"
        '打開自動捲動驅動器
        Timer1.Enabled = True
    Else
        Command1.Caption = "開始電子佈告欄"
        '關上自動捲動驅動器
        Timer1.Enabled = False
    End If
End Sub
Private Sub Form_Load()
Dim Loadstring As String
Dim BuffString As String
Dim FileHandle As Integer
    '把 Label 設成透明才可以看到 Picture1 背景
    Label1.BackStyle = 0

    With Picture1
        '單位設為圖素可避免 Label 高度超過 Scroll 支援上限
        .ScaleMode = 3
        '把 Vscroll Align Picture Right
        VScroll1.Move .ScaleWidth - VScroll1.Width, _
                .ScaleTop, VScroll1.Width, .ScaleHeight
        '剩下的空間給 Label 來顯示
        Label1.Width = .ScaleWidth - VScroll1.Width
        Label1.Move .ScaleLeft, .ScaleTop
    End With

    '開啟文字檔案，並放入 Label 中
    FileHandle = FreeFile
    Open "c:\temp\vtcolor.htm" For Input As #FileHandle
    Do While Not EOF(FileHandle)
        Line Input #FileHandle, Loadstring
        BuffString = BuffString + Loadstring + vbCrLf
    Loop
    Close #FileHandle
    Label1.Caption = BuffString

    '半秒鐘捲一次
    Timer1.Interval = 500
    '先把驅動器關著。
    Timer1.Enabled = False
    Command1.Caption = "開始電子佈告欄"

    '啟動亂數種子，等下選取亂數色彩會用到。
    Randomize
End Sub
'因為 Label1.Autosize 和 Label.WordWrap 屬性搭配出來的大小不能精確對齊，
'因此我們自行依 Label.Caption 內容調整高度
Private Sub Label1_Change()
    Label1.Height = Picture1.TextHeight(Label1.Caption)
    'VScorll 最大值為 Label 高度
    VScroll1.Max = Picture1.TextHeight(Label1.Caption)
    'VScorll 捲動值為 Label 字元高度
    VScroll1.SmallChange = Label1.FontSize
    'VScorll 翻頁值為 Picture1 高度
    VScroll1.LargeChange = Picture1.ScaleHeight
End Sub
Private Sub Timer1_Timer()
    If VScroll1.Value + Label1.FontSize <= VScroll1.Max Then
        'Label 向下拉一頁
        VScroll1.Value = VScroll1.Value + VScroll1.SmallChange
    Else
        'Label 從頭顯示
        VScroll1.Value = 0
    End If
End Sub
Private Sub VScroll1_Change()
Dim RndNum As Byte
    'Label 配合 Vsrcoll 值捲動
    Label1.Move Picture1.ScaleLeft, Picture1.ScaleTop - VScroll1.Value

    '以下純為騷包設計，不喜歡就拿掉
    '取 0~15 的一個亂數
    RndNum = Int(Rnd * 16)
    '取 QuickBasic Color 十六色定義之一色
    Picture1.BackColor = QBColor(RndNum)
    'Label 為 Picture 的反相色
    Label1.ForeColor = QBColor(15 - RndNum)

End Sub

回索引

多迴圈同時進行

寄件者: 蔡文山 (m2664)

程式需要有兩個迴圈同時運算，同時執行，不知道有何種辦法可以到多工的目的？

老怪答：

要談起 Windows 程式多工問題，這問題又複雜了，不談理論，只談我用過的可行辦法：

  1. 不要用迴圈，因為我已往的測試一個迴圈在跑時另個迴圈會暫停。
  2. 你可以用兩個Timer ，啟動時 Timer.Enable=True 進入再用數值判斷終止條件成立時，把 Timer.Enable =False。

回索引

用文字檔儲存程式設定

寄件者: 簡喬亭

如何將一程式中的一切設定值(如果不少的話),儲存在一隻純文字檔中,我只希望能夠存在純文字檔中!!並且一個設定值一行。

老怪答：

  1. 其實儲存程式中的設定值不一定要用 GetSetting 和 SaveSetting 和 Windows 登錄項目攪和在一起，或許老怪杞人憂天，心中總想萬一那個程式設計師和我一樣不長眼睛，用了同一個節區名稱，那兩個程式不要打架了嗎，所以[隨人公媽隨人拜](台語俗諺)，老怪還是喜歡把程式設定用檔案放在自己的程式目錄裏，自己負責儲存及讀入。
  2. 如果要用文字檔存設定程式設定，我建議使用兩個動態 String 陣列，一個放索引值(如 性別)，一個放設定值(如男,女)，把它們 Index 值相對應 ，然後用 Open File 方式，配合 Input # , Write# 陳述來讀出及寫入，底下的程式範例就是這樣的做法。
    '本範例利用一普通文字檔來儲存 Form 的視窗大小設定，
    '以便下次開檔時還原 視窗設定
    Option Explicit

    '設定名稱索引
    Dim SetKey() As String
    '設定內容陣列
    Dim SetValue() As String
    '設定儲存檔名稱含路徑
    Dim FileString As String

    Private Sub Form_Load()
    ReDim SetKey(4)
    ReDim SetValue(4)

    FileString = App.Path
    If Right(FileString, 1) <> "\" Then
    FileString = FileString & "\"
    End If

    '設定儲存檔路徑及名稱
    FileString = FileString & "user.set"

    If Dir(FileString) = "" Then
    '執行儲存設定自訂函數
    SaveSetting
    Else
    '執行讀入設定自訂函數
    LoadSetting
    End If

    End Sub

    Private Sub FormSet(ByVal SetIndex As Single)
    '依 SetKey 名稱索引決定設定項目
    Select Case SetKey(SetIndex)
    Case "WindowsState"
    Me.WindowState = SetValue(SetIndex)
    Case "Left"
    Me.Left = SetValue(SetIndex)
    Case "Top"
    Me.Top = SetValue(SetIndex)
    Case "Width"
    Me.Width = SetValue(SetIndex)
    Case "Height"
    Me.Height = SetValue(SetIndex)
    End Select
    End Sub

    Private Sub SaveSetting()
    Dim FileHandle As Integer
    Dim I As Long

    '將 Form 設定值填入名稱索引陣列及內容設定陣列
    SetKey(0) = "WindowsState": SetValue(0) = Me.WindowState
    '當視窗最大化或最小化時，不儲存 Form 位置及大小設定
    If SetValue(0) = 0 Then
    SetKey(1) = "Left": SetValue(1) = Me.Left
    SetKey(2) = "Top": SetValue(2) = Me.Top
    SetKey(3) = "Width": SetValue(3) = Me.Width
    SetKey(4) = "Height": SetValue(4) = Me.Height
    End If

    '將設定值寫入 user.set 檔
    FileHandle = FreeFile
    Open FileString For Output As #FileHandle
    For I = 0 To UBound(SetKey)
    Write #FileHandle, SetKey(I), SetValue(I)
    Next

    Close #FileHandle
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    '在視窗結束前將設定值存檔
    SaveSetting
    End Sub

    Private Sub LoadSetting()
    Dim FileHandle As Integer
    Dim I As Long

    '將 user.set 內容讀入兩個設定陣列
    FileHandle = FreeFile
    Open FileString For Input As #FileHandle
    For I = 0 To UBound(SetKey)
    Input #FileHandle, SetKey(I), SetValue(I)
    '逐項執行 Form 設定
    FormSet I
    Next

    Close #FileHandle

    End Sub

回索引

斜向漸層的製作

寄件者: wopeter

我想問關於斜向漸層的寫法

老怪答：

Option Explicit
'做斜角線性漸層真正的途徑應該是啟用三角函數，依夾角弧度算出
'對角點位置，但因本人高中時代很打混，三角函數從來沒懂過，所
'以只會做 45 度角斜線漸層。所幸外面繪圖軟體的斜角線性漸層也
'都是 45 度，所以老怪也不算太丟臉。
'45 度角線有個很 Easy 的特性，就是夾直角的兩邊等長，所以求
'(x,y) 的左對角點就是 (x-ScaleHeight,y+ScaleHeight)，
'(x,y) 的右對角點就是 (x+ScaleHeight,y+ScaleHeight)，
'或許有人要問那 x-ScaleHeight<0 或 x+ScaleHeight>ScaleWidth
'怎麼辦？答案是沒怎麼辦，你就讓它畫出去，反正會顯示出來的只
'有那個顯示框而已，你管那條線是畫到天邊還是海角？所以蠻幹一
'番，老怪的線性漸層盒就做出來啦。
'測試本範例請在 Form 上布置 Picture1,Frame1,Label1,Text1，並
'在 Frame1 框架內放入 Option1(0),Option1(1),Option1(2),Option1(3)
'線條寬度設定
Dim LineWidth As Byte
'線條起點的 X 座標
Dim UpStart As Long
'線條終點的 X 座標
Dim DnStart As Long
'色彩端點選擇
Dim ColorStart As Integer
Private Sub Form_Load()
    Frame1.Caption = "光源方向選擇"
    Option1(0).Caption = "光源左上"
    Option1(1).Caption = "光源左下"
    Option1(2).Caption = "光源右上"
    Option1(3).Caption = "光源右下"
    Me.Caption = "斜角線性漸層範例"
    Label1.Caption = "線條寬度"

    '設定線條寬度為 8 Pixels
    '線條寬度愈細，畫面愈細緻，但顯示也愈費時。
    Text1.Text = 8

    With Picture1
        'Picture 單位為 Pixel
        .ScaleMode = 3
        '設定 Picture 畫線寬度
        .DrawWidth = LineWidth
    End With

    '預設光源為左上
    Option1(0).Value = True
End Sub
Private Sub Option1_Click(Index As Integer)
    With Picture1
        Select Case Index
            Case 0
                '以 Picture 左端為線起點 X 軸
                UpStart = 0
                '線終點 X 軸向 Picture 左端移出一個 Picture 高度距離
                DnStart = -.ScaleHeight
                '以 255 為色彩起點
                ColorStart = 255
            Case 1
                '線起點 X 軸向 Picture 左端移出一個 Picture 高度距離
                UpStart = -.ScaleHeight
                '以 Picture 左端為線終點 X 軸
                DnStart = 0
                ColorStart = 255
            Case 2
                UpStart = -.ScaleHeight
                DnStart = 0
                '以 0 為色彩起點
                ColorStart = 0
            Case 3
                UpStart = 0
                DnStart = -.ScaleHeight
                ColorStart = 0
        End Select
    End With

    'PictureBox 重繪
    Picture1_Paint
End Sub
Private Sub Picture1_Paint()
Dim I As Long, Total As Long
Dim Trans256 As Integer

    '全部繪圖次數為 Picture 寬度加高度
    Total = Picture1.ScaleWidth + Picture1.ScaleHeight

    '依線條寬度而決定隔幾點畫一條線
    For I = 0 To Total Step LineWidth
        '把 256 階色彩強度平均分配給總長度，以利階層顯現
        Trans256 = (255 / Total) * I
        'Abs(UpStart+DnStart)=Picture1.ScaleHeight,之所以
        '不用 ScaleHeight 是避免每次查核 ScaleHeight 拖延
        '處理速度
        Picture1.Line (I + UpStart, 0)-(I + DnStart, _
                Abs(UpStart + DnStart)), _
                RGB(Abs(ColorStart - Trans256), Abs(ColorStart - Trans256),
0)
    Next
End Sub
Private Sub Text1_Change()
    If Val(Text1.Text) > 255 Then Text1.Text = 255
    If Val(Text1.Text) <= 0 Then Text1.Text = 1
    LineWidth = Val(Text1.Text)
End Sub
Private Sub Text1_KeyPress(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

回索引

用滑鼠拖曳圖片

寄件者: ssman

請問，我想把一圖片拖曳到另空白圖形方塊，如何在拖曳圖片時顯示該圖片並把它放到該空白圖形方塊。

老怪答：

  1. 用 DragMove 和 DragDrop 原始方法，有兩大限制：
  2. 所以還是用 Mouse_Move 直接移動圖片會比較順暢。程式碼如下：
    Option Explicit
    '測試本範例請在 Form 上布置 Image1,Shape1
    '返回座標軸
    Dim SaveX As Single, SaveY As Single
    '定位座標軸
    Dim OldX As Single, OldY As Single
    Private Sub Form_Load()
        Image1.Picture = LoadPicture("C:\temp\king.bmp")
        '設定撲克移入區
        With Shape1
            .Width = Image1.Width
            .Height = Image1.Height
            .FillColor = &HFFFFFF
            .FillStyle = 0
        End With
    End Sub
    Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As
    Single, Y As Single)
        '按住左鍵才開始拖曳
        If Button = 1 Then
            '設定移動距離計算定位點
            OldX = X
            OldY = Y
            '設定反回座標，以供未放入置入區返回之用
            SaveX = Image1.Left
            SaveY = Image1.Top
        End If
    End Sub
    Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As
    Single, Y As Single)
        If Button = 1 Then
            With Image1
                'Image1 移動的距離為現 x,y 與 OldX,Y 的距離
                .Move .Left + X - OldX, .Top + Y - OldY
            End With
        End If
    End Sub
    Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single,
    Y As Single)
        If Button = 1 Then
            With Shape1
                'Image1 左上端移入置牌區則放入置牌區
                If Image1.Left > .Left And Image1.Left < .Left + .Width _
                        And Image1.Top > .Top And Image1.Top < .Top + .Height
    Then
                    Image1.Move .Left, .Top
                '未進入則反回原位置
                Else
                    Image1.Move SaveX, SaveY
                End If
            End With
        End If
    End Sub

回索引

回首頁

1