29. 圖 形
HSLHSV應用程式
HSLHSV應用程式是一個簡單的色彩選擇工具,你可以用RGB顏色定義、HSV顏色定義或是HSL顏色定義來選擇顏色。這個應用程式建立了一個在
第十四章 討論過的HSV物件和HSL物件,讓使用者可以在HSV顏色定義和HSL顏色定義之間轉換。和本書第三部份其他的範例程式一樣,有些主功能表的選項還沒被定義,這些功能我們留給你自己發揮,你可以加入程式碼來完成它們,而「說明」功能表裡所有的選項都可以被使用,其中包括筆者所建立的標準「關於」對話方塊及有關於這個應用程式的說明檔。
在Update程序中,我們用一個標籤控制項lblColor來顯示目前被選取的顏色的十六進位值,為了要能夠表示標準的Visual Basic十六進位數字,我們在十六進位數值的前面加上了&符號和字母H。請注意在程式中這個字串含有兩個"&"符號:
lblColor = "Color = " & "&&H" & Hex$(RGBColor)
如果只用一個&符號,Visual Basic會在H底下加上底線;用兩個 & 符號,Visual Basic就會顯示一個單一的&符號,而不會在H的底下加上底線。
圖29-1顯示的是HSLHSV應用程式執行的情況,當某個滑鈕移動時,圖片方塊就會根據所有滑鈕的位置來顯示顏色,而其他相關的Slider控制項也會跟自動調整滑鈕位置。圖29-2是HSLHSV應用程式的專案視窗,圖29-3所顯示的是設計階段的HSLHSV表單,圖上的數字是用來說明表單上物件的編號,物件的說明請看"HSLHSV.FRM物件與屬性設定"一表。
圖29-1 HSLHSV應用程式執行的情況 |
圖29-2 HSLHSV應用程式的專案視窗 |
請依照以下這幾張表和程式碼加入適當的控制項並設定它們的屬性,以建立HSLHSV應用程式。
在這裡你可以看到About表單和HSV物件和HSL物件類別模組的程式碼,請回到 第十二章"對話方塊" 和 第十四章"繪圖技巧" 參閱完整的說明。
圖29-3 設計階段的HSLHSV表單 |
HSLHSV.FRM功能表項目 |
標題 | 名稱 | 內縮 | 啟用 |
---|---|---|---|
&File | MnuFile | 0 | True |
&New | mnuNew | 1 | False |
&Open | mnuOpen | 1 | False |
&Save | mnuSave | 1 | False |
Save&As | mnuSaveAs | 1 | False |
- | mnuFileDash1 | 1 | True |
E&xit | mnuExit | 1 | True |
&Help | mnuHelp | 0 | True |
&Contents | mnuContents | 1 | True |
&SearchforHelpon | mnuSearch | 1 | True |
- | mnuHelpDash1 | 1 | True |
&About | mnuAbout | 1 | True |
HSLHSV.FRM物件與屬性設定 |
編號 * | 屬性 | 值 |
---|---|---|
Slider 1 |
Name Index Max LargeChange |
sliRGB 0 255 10 |
Slider 2 |
Name Index Max LargeChange |
sliRGB 1 255 10 |
Slider 3 |
Name Index Max LargeChange |
sliRGB 2 255 10 |
Slider 4 |
Name Index Max |
sliHSV 0 359 |
Slider 5 |
Name Index Max |
sliHSV 1 100 |
Slider 6 |
Name Index Max |
sliHSV 2 100 |
Slider 7 |
Name Index Max |
sliHSL 0 239 |
Slider 8 |
Name Index Max |
sliHSL 1 240 |
Slider 9 |
Name Index Max |
sliHSL 2 240 |
Label |
Name Index Caption |
Label1 0 Red |
Label |
Name Index Caption |
Label1 1 Green |
Label |
Name Index Caption |
Label1 2 Blue |
Label |
Name Index Caption |
Label2 0 Hue |
Label |
Name Index Caption |
Label2 1 Saturation |
Label |
Name Index Caption |
Label2 2 Value |
Label |
Name Index Caption |
Label3 0 Hue |
Label |
Name Index Caption |
Label3 1 Saturation |
Label |
Name Index Caption |
Label3 2 Luminosity |
Label |
Name Index |
lblRGB 0 |
Label |
Name Index |
lblRGB 1 |
Label |
Name Index |
lblRGB 2 |
Label |
Name Index |
lblHSV 0 |
Label |
Name Index |
lblHSV 1 |
Label |
Name Index |
lblHSV 2 |
Label |
Name Index |
lblHSL 0 |
Label |
Name Inde |
lblHSL 1 |
Label |
Name Inde |
lblHSL 2 |
Label | Name | lblColor |
PictureBox 7 |
Name | picColor |
HSLHSV.FRM原始程式碼
Option Explicit Private Declare Function WinHelp _ Lib "user32" Alias "WinHelpA" ( _ ByVal hwnd As Long, _ ByVal lpHelpFile As String, _ ByVal wCommand As Long, _ ByVal dwData As Long _ ) As Long Dim RGBColor Dim hsvDemo As New HSV Dim hslDemo As New HSL Private Sub Form_Load() `Set a gray starting color With hsvDemo .Red = 127 .Green = 127 .Blue = 127 End With With hslDemo .Red = 127 .Green = 127 .Blue = 127 End With Update End Sub Private Sub mnuAbout_Click() `Set properties About.Application = "HSVHSL" About.Heading = _ "Microsoft Visual Basic 6.0 Developer's Workshop" About.Copyright = "1998 John Clark Craig and Jeff Webb" `Call a method About.Display End Sub Private Sub mnuContents_Click() WinHelp hwnd, App.Path & "\..\..\Help\Mvbdw.hlp", _ cdlHelpContents, 0 End Sub Private Sub mnuExit_Click() Unload Me End Sub Private Sub mnuSearch_Click() WinHelp hwnd, App.Path & "\..\..\Help\Mvbdw.hlp", _ cdlHelpPartialKey, 0 End Sub Sub Update() sliRGB(0).Value = hsvDemo.Red sliRGB(1).Value = hsvDemo.Green sliRGB(2).Value = hsvDemo.Blue sliHSV(0).Value = hsvDemo.Hue sliHSV(1).Value = hsvDemo.Saturation sliHSV(2).Value = hsvDemo.Value sliHSL(0).Value = hslDemo.Hue sliHSL(1).Value = hslDemo.Saturation sliHSL(2).Value = hslDemo.Luminosity `Update RGB color labels lblRGB(0).Caption = Format$(hsvDemo.Red, "##0") lblRGB(1).Caption = Format$(hsvDemo.Green, "##0") lblRGB(2).Caption = Format$(hsvDemo.Blue, "##0") `Update HSV color labels lblHSV(0).Caption = Format$(hsvDemo.Hue, "##0") lblHSV(1).Caption = Format$(hsvDemo.Saturation, "##0") lblHSV(2).Caption = Format$(hsvDemo.Value, "##0") `Update HSL color labels lblHSL(0).Caption = Format$(sliHSL(0).Value, "##0") lblHSL(1).Caption = Format$(sliHSL(1).Value, "##0") lblHSL(2).Caption = Format$(sliHSL(2).Value, "##0") `Update the displayed color RGBColor = RGB(hsvDemo.Red, hsvDemo.Green, hsvDemo.Blue) picColor.BackColor = RGBColor `Update the color's number lblColor = "Color = " & "&&H" & Hex$(RGBColor) End Sub Private Sub sliHSL_Scroll(Index As Integer) hslDemo.Hue = sliHSL(0).Value hslDemo.Saturation = sliHSL(1).Value hslDemo.Luminosity = sliHSL(2).Value hsvDemo.Red = hslDemo.Red hsvDemo.Green = hslDemo.Green hsvDemo.Blue = hslDemo.Blue Update End Sub Private Sub sliRGB_Scroll(Index As Integer) hsvDemo.Red = sliRGB(0).Value hsvDemo.Green = sliRGB(1).Value hsvDemo.Blue = sliRGB(2).Value hslDemo.Red = hsvDemo.Red hslDemo.Green = hsvDemo.Green hslDemo.Blue = hsvDemo.Blue Update End Sub Private Sub sliHSV_Scroll(Index As Integer) hsvDemo.Hue = sliHSV(0).Value hsvDemo.Saturation = sliHSV(1).Value hsvDemo.Value = sliHSV(2).Value hslDemo.Red = hsvDemo.Red hslDemo.Green = hsvDemo.Green hslDemo.Blue = hsvDemo.Blue Update End Sub
HSV.CLS原始程式碼
`HSV.CLS Option Explicit `RGB color properties Private mintRed As Integer Private mintGreen As Integer Private mintBlue As Integer `HSV color properties Private msngHue As Single Private msngSaturation As Single Private msngValue As Single `Keep track of implied conversion Private mintCalc As Integer Private Const RGB2HSV = 1 Private Const HSV2RGB = 2 `~~~ Hue Property Let Hue(intHue As Integer) msngHue = intHue mintCalc = HSV2RGB End Property Property Get Hue() As Integer If mintCalc = RGB2HSV Then CalcHSV Hue = msngHue End Property `~~~ Saturation Property Let Saturation(intSaturation As Integer) msngSaturation = intSaturation mintCalc = HSV2RGB End Property Property Get Saturation() As Integer If mintCalc = RGB2HSV Then CalcHSV Saturation = msngSaturation End Property `~~~ Value Property Let Value(intValue As Integer) msngValue = intValue mintCalc = HSV2RGB End Property Property Get Value() As Integer If mintCalc = RGB2HSV Then CalcHSV Value = msngValue End Property `~~~ Red Property Let Red(intRed As Integer) mintRed = intRed mintCalc = RGB2HSV End Property Property Get Red() As Integer If mintCalc = HSV2RGB Then CalcRGB Red = mintRed End Property `~~~ Green Property Let Green(intGreen As Integer) mintGreen = intGreen mintCalc = RGB2HSV End Property Property Get Green() As Integer If mintCalc = HSV2RGB Then CalcRGB Green = mintGreen End Property `~~~ Blue Property Let Blue(intBlue As Integer) mintBlue = intBlue mintCalc = RGB2HSV End Property Property Get Blue() As Integer If mintCalc = HSV2RGB Then CalcRGB Blue = mintBlue End Property `Converts RGB to HSV Private Sub CalcHSV() Dim sngRed As Single Dim sngGreen As Single Dim sngBlue As Single Dim sngMx As Single Dim sngMn As Single Dim sngDelta As Single Dim sngVa As Single Dim sngSa As Single Dim sngRc As Single Dim sngGc As Single Dim sngBc As Single sngRed = mintRed / 255 sngGreen = mintGreen / 255 sngBlue = mintBlue / 255 sngMx = sngRed If sngGreen > sngMx Then sngMx = sngGreen If sngBlue > sngMx Then sngMx = sngBlue sngMn = sngRed If sngGreen < sngMn Then sngMn = sngGreen If sngBlue < sngMn Then sngMn = sngBlue sngDelta = sngMx - sngMn sngVa = sngMx If sngMx Then sngSa = sngDelta / sngMx Else sngSa = 0 End If If sngSa = 0 Then msngHue = 0 Else sngRc = (sngMx - sngRed) / sngDelta sngGc = (sngMx - sngGreen) / sngDelta sngBc = (sngMx - sngBlue) / sngDelta Select Case sngMx Case sngRed msngHue = sngBc - sngGc Case sngGreen msngHue = 2 + sngRc - sngBc Case sngBlue msngHue = 4 + sngGc - sngRc End Select msngHue = msngHue * 60 If msngHue < 0 Then msngHue = msngHue + 360 End If msngSaturation = sngSa * 100 msngValue = sngVa * 100 mintCalc = 0 End Sub `Converts HSV to RGB Private Sub CalcRGB() Dim sngSaturation As Single Dim sngValue As Single Dim sngHue As Single Dim intI As Integer Dim sngF As Single Dim sngP As Single Dim sngQ As Single Dim sngT As Single Dim sngRed As Single Dim sngGreen As Single Dim sngBlue As Single sngSaturation = msngSaturation / 100 sngValue = msngValue / 100 If msngSaturation = 0 Then sngRed = sngValue sngGreen = sngValue sngBlue = sngValue Else sngHue = msngHue / 60 If sngHue = 6 Then sngHue = 0 intI = Int(sngHue) sngF = sngHue - intI sngP = sngValue * (1! - sngSaturation) sngQ = sngValue * (1! - (sngSaturation * sngF)) sngT = sngValue * (1! - (sngSaturation * (1! - sngF))) Select Case intI Case 0 sngRed = sngValue sngGreen = sngT sngBlue = sngP Case 1 sngRed = sngQ sngGreen = sngValue sngBlue = sngP Case 2 sngRed = sngP sngGreen = sngValue sngBlue = sngT Case 3 sngRed = sngP sngGreen = sngQ sngBlue = sngValue Case 4 sngRed = sngT sngGreen = sngP sngBlue = sngValue Case 5 sngRed = sngValue sngGreen = sngP sngBlue = sngQ End Select End If mintRed = Int(255.9999 * sngRed) mintGreen = Int(255.9999 * sngGreen) mintBlue = Int(255.9999 * sngBlue) mintCalc = 0 End Sub
HSL.CLS原始程式碼
`HSL.CLS Option Explicit `RGB color properties Private mintRed As Integer Private mintGreen As Integer Private mintBlue As Integer `HSL color properties Private msngHue As Single Private msngSaturation As Single Private msngLuminosity As Single `Keep track of implied conversion Private mintCalc As Integer Private Const RGB2HSL = 1 Private Const HSL2RGB = 2 `~~~ Hue Property Let Hue(intHue As Integer) msngHue = (intHue / 240!) * 360! mintCalc = HSL2RGB End Property Property Get Hue() As Integer If mintCalc = RGB2HSL Then CalcHSL Hue = (msngHue / 360!) * 240! End Property `~~~ Saturation Property Let Saturation(intSaturation As Integer) msngSaturation = intSaturation / 240! mintCalc = HSL2RGB End Property Property Get Saturation() As Integer If mintCalc = RGB2HSL Then CalcHSL Saturation = msngSaturation * 240! End Property `~~~ Luminosity Property Let Luminosity(intLuminosity As Integer) msngLuminosity = intLuminosity / 240! mintCalc = HSL2RGB End Property Property Get Luminosity() As Integer If mintCalc = RGB2HSL Then CalcHSL Luminosity = msngLuminosity * 240! End Property `~~~ Red Property Let Red(intRed As Integer) mintRed = intRed mintCalc = RGB2HSL End Property Property Get Red() As Integer If mintCalc = HSL2RGB Then CalcRGB Red = mintRed End Property `~~~ Green Property Let Green(intGreen As Integer) mintGreen = intGreen mintCalc = RGB2HSL End Property Property Get Green() As Integer If mintCalc = HSL2RGB Then CalcRGB Green = mintGreen End Property `~~~ Blue Property Let Blue(intBlue As Integer) mintBlue = intBlue mintCalc = RGB2HSL End Property Property Get Blue() As Integer If mintCalc = HSL2RGB Then CalcRGB Blue = mintBlue End Property Private Sub CalcHSL() Dim sngMx As Single Dim sngMn As Single Dim sngDelta As Single Dim sngPctRed As Single Dim sngPctGrn As Single Dim sngPctBlu As Single sngPctRed = mintRed / 255 sngPctGrn = mintGreen / 255 sngPctBlu = mintBlue / 255 sngMx = sngMaxOf(sngMaxOf(sngPctRed, sngPctGrn), sngPctBlu) sngMn = sngMinOf(sngMinOf(sngPctRed, sngPctGrn), sngPctBlu) sngDelta = sngMx - sngMn msngLuminosity = (sngMx + sngMn) / 2 If sngMx = sngMn Then msngSaturation = 0 Else msngSaturation = 1 End If If msngLuminosity <= 0.5 Then If msngSaturation > 0 Then msngSaturation = sngDelta / (sngMx + sngMn) End If Else If msngSaturation > 0 Then msngSaturation = sngDelta / (2 - sngMx - sngMn) End If End If If msngSaturation Then If sngPctRed = sngMx Then msngHue = (sngPctGrn - sngPctBlu) / sngDelta End If If sngPctGrn = sngMx Then msngHue = 2 + (sngPctBlu - sngPctRed) / sngDelta End If If sngPctBlu = sngMx Then msngHue = 4 + (sngPctRed - sngPctGrn) / sngDelta End If msngHue = msngHue * 60 End If If msngHue < 0 Then msngHue = msngHue + 360 mintCalc = 0 End Sub Private Sub CalcRGB() Dim sngM1 As Single Dim sngM2 As Single Dim sngPctRed As Single Dim sngPctGrn As Single Dim sngPctBlu As Single If msngLuminosity <= 0.5 Then sngM2 = msngLuminosity * (1! + msngSaturation) Else sngM2 = (msngLuminosity + msngSaturation) _ - (msngLuminosity * msngSaturation) End If sngM1 = 2! * msngLuminosity - sngM2 If msngSaturation = 0! Then sngPctRed = msngLuminosity sngPctGrn = msngLuminosity sngPctBlu = msngLuminosity Else sngPctRed = rgbVal(sngM1, sngM2, msngHue + 120!) sngPctGrn = rgbVal(sngM1, sngM2, msngHue) sngPctBlu = rgbVal(sngM1, sngM2, msngHue - 120!) End If mintRed = Int(255.9999 * sngPctRed) mintGreen = Int(255.9999 * sngPctGrn) mintBlue = Int(255.9999 * sngPctBlu) mintCalc = 0 End Sub Private Function rgbVal(sngN1 As Single, sngN2 As Single, _ sngHue As Single) As Single If sngHue > 360 Then sngHue = sngHue - 360 ElseIf sngHue < 0 Then sngHue = sngHue + 360 End If If sngHue < 60 Then rgbVal = sngN1 + (sngN2 - sngN1) * sngHue / 60 ElseIf sngHue < 180 Then rgbVal = sngN2 ElseIf sngHue < 240 Then rgbVal = sngN1 + (sngN2 - sngN1) * (240 - sngHue) / 60 Else rgbVal = sngN1 End If End Function Private Function sngMaxOf(sngV1 As Single, sngV2 As Single) As Single sngMaxOf = IIf(sngV1 > sngV2, sngV1, sngV2) End Function Private Function sngMinOf(sngV1 As Single, sngV2 As Single) As Single sngMinOf = IIf(sngV1 < sngV2, sngV1, sngV2) End Function
ABOUT.FRM原始程式碼
Option Explicit Private Sub cmdOK_Click() `Cancel About form Unload Me End Sub Private Sub Form_Load() `Center this form Left = (Screen.Width - Width) \ 2 Top = (Screen.Height - Height) \ 2 `Set defaults lblApplication.Caption = "- Application -" lblHeading.Caption = "- Heading -" lblCopyright.Caption = "- Copyright -" End Sub Public Sub Display() `Display self as modal Show vbModal End Sub Property Let Application(Application As String) `Define string property for Application lblApplication.Caption = Application End Property Property Let Heading(Heading As String) `Define string property for Heading lblHeading.Caption = Heading End Property Property Let Copyright(Copyright As String) `Build complete Copyright string property lblCopyright.Caption = "Copyright (c) " & Copyright End Property
Animate應用程式
首先,讓我們來看看ANIMATE.BAS的程式碼。在程式中,Sub Main顯示了兩張表單,這兩張表單個別展示了其獨特的繪圖技巧,不過我們先從整個程式模組開始介紹,然後再討論表單中的細節部份。
ANIMATE.BAS原始程式碼
Option Explicit DefDbl A-Z `<<<< NOTICE!!! Public Const PI = 3.14159265358979 Public Const RADPERDEG = PI / 180 Sub Main() App.HelpFile = App.Path & "\..\..\Help\Mvbdw.hlp" frmClock.Show vbModeless frmGlobe.Show vbModeless End Sub Sub RotateX(X, Y, Z, Angle) Dim Radians, Ca, Sa, Ty Radians = Angle * RADPERDEG Ca = Cos(Radians) Sa = Sin(Radians) Ty = Y * Ca - Z * Sa Z = Z * Ca + Y * Sa Y = Ty End Sub Sub RotateY(X, Y, Z, Angle) Dim Radians, Ca, Sa, Tx Radians = Angle * RADPERDEG Ca = Cos(Radians) Sa = Sin(Radians) Tx = X * Ca + Z * Sa Z = Z * Ca - X * Sa X = Tx End Sub Sub RotateZ(X, Y, Z, Angle) Dim Radians, Ca, Sa, Tx Radians = Angle * RADPERDEG Ca = Cos(Radians) Sa = Sin(Radians) Tx = X * Ca - Y * Sa Y = Y * Ca + X * Sa X = Tx End Sub Sub PolToRec(Radius, Angle, X, Y) Dim Radians Radians = Angle * RADPERDEG X = Radius * Cos(Radians) Y = Radius * Sin(Radians) End Sub Sub RecToPol(X, Y, Radius, Angle) Dim Radians Radius = Sqr(X * X + Y * Y) If X = 0 Then Select Case Y Case Is > 0 Angle = 90 Case Is < 0 Angle = -90 Case Else Angle = 0 End Select ElseIf Y = 0 Then Select Case X Case Is < 0 Angle = 180 Case Else Angle = 0 End Select Else If X < 0 Then If Y > 0 Then Radians = Atn(Y / X) + PI Else Radians = Atn(Y / X) - PI End If Else Radians = Atn(Y / X) End If Angle = Radians / RADPERDEG End If End Sub
在所有表單和程式模組的開始處,我們用RefDbl A-Z陳述式使所有的變數都預設為雙精準浮點數(Double),如果預設所有的變數為Variant,程式仍然能正常執行,但用Double型別的變數會使程式執行的速度稍微快一點。
由於這個應用程式並沒有主功能表,因此,我們用F1鍵來叫用線上說明。為了能夠用F1鍵叫用線上說明,我們在Sub Main程序中將說明檔的路徑和檔名設定在應用程式的HelpFile屬性中。
另一個設定HelpFile屬性的方法是從「專案屬性」對話方塊中設定說明檔的檔名和路徑:從「專案」功能表中叫出專案屬性對話方塊,然後在「說明檔名稱」欄中輸入說明檔檔名,讓「專案說明主題代碼」維持不變。
接下來,我們要將Sub Main設定為啟動物件。同樣地,先叫出「專案屬性」對話方塊,在「啟動物件」的下拉式清單中選擇Sub Main。
Sub Main的程式很短,它主要在顯示兩張用來展示動畫的表單並且設定App物件的HelpFile屬性。其他在模組中的程式碼則是用來處理平面座標和球體座標之間的轉換,這些程序對三維圖形的計算是非常有用的。我們稍後會討論這個部份,現在讓我們看看動畫時鐘表單。
ANICLOCK.FRM
這張表單只用了一個Line控制項和一個Timer控制項就建好了一個模擬的時鐘,圖29-4顯示的是設計階段中的表單,圖29-5則是執行階段中的表單。
圖29-4 設計階段中的ANICLOCK.FRM表單 |
鐘面上的長短線是怎麼畫出來的呢?秘訣是用Load陳述式複製另外14份Line控制項,設定好每一份執行實體(線段)的端點座標,然後把這些線段擺在適當的位置上。在這15條線段中,只有十二條被畫了一次,做為每個鐘點的區隔,剩下的三條線(時針、分針、秒針)在畫面則每秒鐘更新一次。
圖29-5 執行階段中的ANICLOCK.FRM表單 |
我們並未使用任何一個Line方法畫線,也沒有用程式直接把線段擦掉,當線段的端點座標值更新時,擦掉及重畫的動作由Visual Basic本身負責。
請依照以下這張表來加入控制項以及設定控制項的屬性值。
ANICLOCK.FRM物件與屬性設定 |
屬性 | 值 |
---|---|
Form | |
Name Caption MinButton |
frmClock Animation-Clock False |
Timer | |
Name Interval |
tmrClock 100 |
Line | |
Name Index |
linClock 0 |
我們把Timer控制項的Interval屬性值設定為100,十分之一秒;為什麼不是每1000微秒更新時鐘的指針一次呢?Visual Basic的Timer控制項是用來提供延遲效果的,這個延遲時間會大於或等於Interval屬性所設定的時間,但並不保證每一次延遲效果都一樣的精準。因此,如果把Interval屬性設為1000,有時候,秒針看起來會跳動不順暢。為了解決這個問題,我們每秒鐘檢查10次,看看是否又過了一秒,雖然這樣仍會有一些誤差,但在可以接受的範圍之中。
大部份tmrClock的事件程序都在處理重新計算和重新設定線段的端點座標X1、X2、Y1和Y2,請看以下AniClock的原始程式:
ANICLOCK.FRM原始程式碼
Option Explicit DefDbl A-Z `<<<< NOTICE!!! Private Sub Form_Load() Width = 4000 Height = 4000 Left = Screen.Width \ 2 - 4100 Top = (Screen.Height - Height) \ 2 End Sub Private Sub Form_Resize() Dim i, Angle Static Flag As Boolean If Flag = False Then Flag = True For i = 0 To 14 If i > 0 Then Load linClock(i) linClock(i).Visible = True linClock(i).BorderWidth = 5 linClock(i).BorderColor = RGB(0, 128, 0) Next i End If For i = 0 To 14 Scale (-1, -1)-(1, 1) Angle = i * 2 * Atn(1) / 3 linClock(i).x1 = 0.9 * Cos(Angle) linClock(i).y1 = 0.9 * Sin(Angle) linClock(i).x2 = Cos(Angle) linClock(i).y2 = Sin(Angle) Next i End Sub Private Sub tmrClock_Timer() Const HourHand = 0 Const MinuteHand = 13 Const SecondHand = 14 Dim Angle Static LastSecond `Position hands only on the second If Second(Now) = LastSecond Then Exit Sub LastSecond = Second(Now) `Position hour hand Angle = -0.5236 * (15 - (Hour(Now) + Minute(Now) / 60)) linClock(HourHand).x1 = 0 linClock(HourHand).y1 = 0 linClock(HourHand).x2 = 0.3 * Cos(Angle) linClock(HourHand).y2 = 0.3 * Sin(Angle) `Position minute hand Angle = -0.1047 * (75 - (Minute(Now) + Second(Now) / 60)) linClock(MinuteHand).x1 = 0 linClock(MinuteHand).y1 = 0 linClock(MinuteHand).x2 = 0.7 * Cos(Angle) linClock(MinuteHand).y2 = 0.7 * Sin(Angle) `Position second hand Angle = -0.1047 * (75 - Second(Now)) linClock(SecondHand).x1 = 0 linClock(SecondHand).y1 = 0 linClock(SecondHand).x2 = 0.8 * Cos(Angle) linClock(SecondHand).y2 = 0.8 * Sin(Angle) End Sub
ANIGLOBE.FRM
這張表單顯示一系列含有經緯線球體的連續影像,用以製造地球旋轉的視覺效果。我們用ImageList控制項存放這些連續影像,並快速地把這些影像複製到另一個控制項中。圖29-6所顯示的是設計階段的AniGlobe表單,表單上有一個圖片方塊控制項、一個ImageList控制項和一個計時器控制項。
圖29-6 設計階段中的AniGlobe表單 |
這張表單在tmrGlobe的Timer事件被驅動時會更新一次。在最初的15次Timer事件中,每次呼叫tmrGlobe_Timer事件程序,程式就畫好一張新的影像;當每一張影像完成時,它就立刻被存放到ImageList控制項裡,等到15張圖全部完成之後,程式把這連續的15張影像依序不斷地在圖片方塊控制項裡顯示,如圖29-7。
圖29-7 執行中的AniGlobe表單 |
以下這張表列出了AniGlobe表單中各項控制項屬性的設定內容。
ANIGLOBE.FRM物件與屬性設定 |
編號 * | 屬性 | 值 |
---|---|---|
Form |
Name Caption |
frmGlobe Animation-Spinning Globe |
Timer 1 |
Name Interval |
tmrGlobe 1 |
PictureBox 2 |
Name AutoRedraw |
picGlobe True |
ImageList 3 |
Name | imlGlobe |
*"編號"欄中的號碼用來標示圖29-6中表單上物件的位置。
ImageList控制項和其他一些控制項(如ListView、ToolBar、Tab Strip和TreeView控制項)一併使用時,更可以發揮ImageList控制項的效果。請參閱線上說明中有關ImageList控制項的部份,以更進一步了解這個威力強大的影像處理工具。
在以下的程式中,我們把設定球體斜角度的兩個常數獨立出來,放在程式的開頭,你可嘗試改變TILTSOUTH和TILTEAST常數的值,看看有什麼不同的效果。
以下是AniGlobe的原始程式:
ANIGLOBE.FRM原始程式碼
Option Explicit DefDbl A-Z `<<<< NOTICE!!! Const TILTSOUTH = 47 Const TILTEAST = -37 Private Sub Form_Load() Width = 4000 Height = 4000 Left = Screen.Width \ 2 + 100 Top = (Screen.Height - Height) \ 2 End Sub Private Sub tmrGlobe_Timer() Dim Lat, Lon, Radians Dim R, A, i Dim x1, y1, x2, y2 Dim Xc(72), Yc(72), Zc(72) Dim imgX As ListImage Static ImageIndex, ImageNum Select Case ImageNum `Pump next image to display Case -1 ImageIndex = (ImageIndex Mod 15) + 1 Set picGlobe.Picture = imlGlobe.ListImages _ (ImageIndex).Picture Exit Sub `Initialize PictureBox Case 0 picGlobe.Move 0, 0, ScaleWidth, ScaleHeight picGlobe.Scale (-1.1, 1.1)-(1.1, -1.1) Caption = "Animation Dear John, How Do I... PREPARATION" ImageNum = ImageNum + 1 Exit Sub `Set flag when last image has been `drawn and saved in image list Case 16 Caption = "Animation - Spinning Globe" ImageNum = -1 Exit Sub End Select `Erase any previous picture in PictureBox control Set picGlobe.Picture = Nothing `Draw edge of globe picGlobe.ForeColor = vbBlue For i = 0 To 72 PolToRec 1, i * 5, Xc(i), Yc(i) Next i For i = 1 To 72 picGlobe.Line (Xc(i - 1), Yc(i - 1))-(Xc(i), Yc(i)) Next i `Calculate and draw latitude lines picGlobe.ForeColor = vbRed For Lat = -75 To 75 Step 15 `Convert latitude to radians Radians = Lat * RADPERDEG `Draw circle size based on latitude For i = 0 To 72 PolToRec Cos(Radians), i * 5, Xc(i), Zc(i) Yc(i) = Sin(Radians) `Tilt globe's north pole toward us RotateX Xc(i), Yc(i), Zc(i), TILTSOUTH `Tilt globe's north pole to the right RotateY Xc(i), Yc(i), Zc(i), TILTEAST Next i `Draw front half of rotated circle For i = 1 To 72 If Zc(i) >= 0 Then picGlobe.Line (Xc(i - 1), Yc(i - 1))-(Xc(i), Yc(i)) End If Next i Next Lat `Calculate and draw longitude lines picGlobe.ForeColor = vbBlue For Lon = 0 To 165 Step 15 `Start with xy-plane circle For A = 0 To 72 PolToRec 1, A * 5, Xc(A), Yc(A) Zc(A) = 0 Next A `Rotate points for current line of longitude For i = 0 To 72 RotateY Xc(i), Yc(i), Zc(i), Lon + ImageNum `Tilt globe's north pole toward us RotateX Xc(i), Yc(i), Zc(i), TILTSOUTH `Tilt globe's north pole to the right RotateY Xc(i), Yc(i), Zc(i), TILTEAST Next i `Draw front half of rotated circle For i = 1 To 72 If Zc(i) >= 0 Then picGlobe.Line (Xc(i - 1), Yc(i - 1))-(Xc(i), Yc(i)) End If Next i Next Lon `Update PictureBox state picGlobe.Refresh picGlobe.Picture = picGlobe.Image `Add this image to our image list Set imgX = imlGlobe.ListImages.Add(, , picGlobe.Picture) `Prepare to draw next image ImageNum = ImageNum + 1 End Sub
Lottery應用程式
Lottery應用程式是摩仿美國科羅拉多州樂透彩券而設計的程式,規則很簡單:從編號1到42的一籃乒乓球裡隨機地選取6個球,這6個號碼便是得獎的號碼。在Lottery應用程式中,每次按下「Next ball」按鍵,程式就會選中一個球,被選中的球會整齊地排列在表單下緣,如圖29-8。我們另外再加上了一個購買1000張樂透券的選項,看看買這麼多張樂透券,中獎的機會大不大。
圖29-8 執行中的Lottery應用程式 |
從圖29-9中可以知道Lottery應用程式包含兩張表單和一個物件類別模組;Lottery表單用來顯示落下的乒乓球,RANDOM.CLS物件類別模組產生亂數,ABOUT.FRM則是我們在
第十二章 討論過的標準「關於」對話方塊。
圖29-9 Lottery應用程式的專案視窗 |
LOTTERY.FRM
LOTTERY.FRM是應用程式的啟動表單,圖片方塊控制項picTumble顯示滾動的球及被選中的球,兩個指令按鈕負責選球的動作,而計時器控制項tmrPingPong則負責每隔一段時間更新畫面一次。圖29-10顯示的是在設計階段中的表單,接下來的幾張表列出了表單中所有控制項的設定內容。
圖29-10 設計階段中的Lottery表單 |
LOTTERY.FRM功能表項目 |
標題 | 名稱 | 內縮 | 啟用 |
---|---|---|---|
&File | mnuFile | 0 | True |
&New | mnuNew | 1 | False |
&Open... | mnuOpen | False | |
&Save | mnuSave | 1 | False |
Save &As... | mnuSaveAs | 1 | Fals |
- | mnuFileDash1 | 1 | True |
E&xit | mnuExit | 1 | True |
&Help | mnuHelp | 0 | True |
&Contents | mnuContents | 1 | True |
&Search for Help on... | mnuSearch | 1 | True |
- | mnuHelpDash1 | 1 | True |
&About... | mnuAbout | 1 | True |
LOTTERY.FRM物件與屬性設定 |
編號 * | 屬性 | 值 |
---|---|---|
Form |
Name Caption |
frmLottery Lottery |
PictureBox 1 |
Name AutoRedraw BackColor Height Width |
picTumble True &H00FF0000& 3600 3600 |
Timer 2 |
Name Interval |
tmrPingPong 50 |
CommandButton 3 |
Name Caption |
cmdNextBall &NextBall |
CommandButton 4 |
Name Caption |
cmdSample &Sample 1000tickets... |
*"編號"欄中的號碼用來標示圖29-10中表單上物件的位置
LOTTERY.FRM原始程式碼
Option Explicit Private Declare Function WinHelp _ Lib "user32" Alias "WinHelpA" ( _ ByVal hwnd As Long, _ ByVal lpHelpFile As String, _ ByVal wCommand As Long, _ ByVal dwData As Long _ ) As Long Const MAXNUM = 42 Dim intPPBall(6) As Integer Dim randDemo As New Random Private Sub cmdNextBall_Click() Dim intI As Integer Dim intJ As Integer `Set command button caption cmdNextBall.Caption = "&Next ball" cmdSample.Visible = False `Get current count of selected balls intI = intPPBall(0) `If all balls were grabbed, start over If intI = 6 Then For intI = 0 To 6 intPPBall(intI) = 0 Next intI Exit Sub End If `Select next unique Ping-Pong ball GrabNext intPPBall() `Change command button caption, `and show sample command button If intPPBall(0) = 6 Then cmdNextBall.Caption = "Start &over" cmdSample.Visible = True End If End Sub Private Sub cmdSample_Click() Dim intI As Integer Dim intJ As Integer Dim intK As Integer Dim intN As Integer Dim intTicket(6) As Integer Dim Hits(6) As Integer Dim strMsg As String `Display hourglass mouse pointer MousePointer = vbHourglass `Now simulate a thousand "quick pick" tickets For intI = 1 To 1000 `Generate a ticket intTicket(0) = 0 For intJ = 1 To 6 GrabNext intTicket() Next intJ `Tally the hits intN = 0 For intJ = 1 To 6 For intK = 1 To 6 If intTicket(intJ) = intPPBall(intK) Then intN = intN + 1 End If Next intK Next intJ `Update statistics Hits(intN) = Hits(intN) + 1 Next intI `Display default mouse pointer MousePointer = vbDefault `Display summarized statistics strMsg = "Sample of 1000 ticketsDear John, How Do I... " & vbCrLf & vbCrLf strMsg = strMsg & Space$(10) & "Hits Tally" & vbCrLf For intI = 0 To 6 strMsg = strMsg & Space$(12) & Format$(intI) & Space$(6) strMsg = strMsg & Format$(Hits(intI)) & vbCrLf Next intI MsgBox strMsg, , "Lottery" End Sub Private Sub Form_Load() `Seed new random numbers Randomize randDemo.Shuffle Rnd `Set range of random integers randDemo.MinInt = 1 randDemo.MaxInt = MAXNUM `Center form Me.Left = (Screen.Width - Me.Width) \ 2 Me.Top = (Screen.Height - Me.Height) \ 2 `Hide sample command button for now cmdSample.Visible = False `Prepare tumble animation picTumble.Scale (0, 0)-(12, 12) picTumble.FillStyle = vbSolid picTumble.FillColor = vbWhite picTumble.ForeColor = vbRed End Sub Private Sub picTumble_Paint() Dim intI As Integer Dim sngX As Single Dim sngY As Single Dim strN As String `Erase previous tumble animation picTumble.Cls For intI = 1 To 6 `Determine whether ball has been selected If intPPBall(intI) > 0 Then sngX = intI * 2 - 1 sngY = 11 strN = Format$(intPPBall(intI)) Else sngX = Rnd * 10 + 1 sngY = Rnd * 8 + 3 strN = Format$(randDemo.RandomInt) End If `Draw each Ping-Pong ball picTumble.Circle (sngX, sngY), 1, vbWhite picTumble.CurrentX = sngX - picTumble.TextWidth(strN) / 2 picTumble.CurrentY = sngY - picTumble.TextHeight(strN) / 2 `Label each Ping-Pong ball picTumble.Print strN Next intI End Sub Private Sub tmrPingPong_Timer() picTumble_Paint End Sub Private Sub mnuAbout_Click() `Set properties About.Application = "Lottery" About.Heading = _ "Microsoft Visual Basic 6.0 Developer's Workshop" About.Copyright = "1998 John Clark Craig and Jeff Webb" About.Display End Sub Private Sub mnuExit_Click() Unload Me End Sub Private Sub mnuContents_Click() WinHelp hwnd, App.Path & "\..\..\Help\Mvbdw.hlp", _ cdlHelpContents, 0 End Sub Private Sub mnuSearch_Click() WinHelp hwnd, App.Path & "\..\..\Help\Mvbdw.hlp", _ cdlHelpPartialKey, 0 End Sub Private Sub GrabNext(intAry() As Integer) Dim intI As Integer Dim intJ As Integer `Store index in first array element intAry(0) = intAry(0) + 1 intI = intAry(0) `Get next unique Ping-Pong ball number Do intAry(intI) = randDemo.RandomInt If intI > 1 Then For intJ = 1 To intI - 1 If intAry(intI) = intAry(intJ) Then intAry(intI) = 0 End If Next intJ End If Loop Until intAry(intI) End Sub
Long(長整數)是本應用程式中最常見的資料型別,因此,我們用DefLng A-Z來預設所有的變數為長整數。
注意:
在本章中,我們用WinHelp API函式叫用說明檔功能,而在第三部份的某些應用程式中,我們則用通用對話方塊控制項來叫用說明檔。這兩種技巧都可以得到相同的效果,無孰優孰劣之分,純粹可依個人喜好來選擇。
RANDOM.CLS
Random物件的核心技術在於將亂數序列的長度予以延長,在程式中我們用了一個Double陣列來為亂數產生的動作加入洗牌和混合的效果,以期產生更具隨機性質的亂數。
以下是RANDOM.CLS裡的公用屬性:
RANDOM.CLS裡唯一的Public方法是Shuffle,它用來作亂數序列初始化的工作以產生"洗牌效果"。
很多人不是很清楚要如何將Visual Basic的亂數產生器初始化,才能得到重複的亂數序列。這裡提供了一個方法:呼叫Rnd函式時傳入一個負數,然後立即呼叫Randomize函式,如下例:
Randomize Rnd(-7)
每次傳入 -7給這兩個函式,Visual Basic的亂數產生器都會產生相同的亂數序列。在Random物件中的Shuffle方法中,我們就是使用修改後的這個技巧,如果每次都傳一個負數給Shuffle方法,每次都會得到一個重複的亂數序列,如果傳入0或正數,得到的結果則是完全不能預測的亂數序列。
RandomInt屬性程序將Random程序所傳回的值加以修改,使結果落在MinInt和MaxInt的範圍內。
Random物件類別模組有兩個私有程序Zap程序和Stir程序。Zap程序由Suffle程序呼叫,它對陣列及陣列的索引進行初始化的工作,另一個私有程序Stir則負責為亂數產生器作準備工作。
RANDOM.CLS原始程式碼
Option Explicit Const ARYCNT = 17 `Two simple R/W properties Public MinInt As Long Public MaxInt As Long `Module-level variables Private mdblSeed(ARYCNT - 1) As Double Private mintP As Integer Private mintQ As Integer `Method Public Sub Shuffle(dblX As Double) Dim strN As String Dim intI As Integer Zap strN = Str$(dblX) For intI = 1 To Len(strN) Stir 1 / Asc(Mid(strN, intI, 1)) Next intI Randomize Rnd(mdblSeed(mintP) * Sgn(dblX)) For intI = 1 To ARYCNT * 2.7 Stir Rnd Next intI End Sub Property Get Random() As Double mintP = (mintP + 1) Mod ARYCNT mintQ = (mintQ + 1) Mod ARYCNT mdblSeed(mintP) = mdblSeed(mintP) + mdblSeed(mintQ) + Rnd mdblSeed(mintP) = mdblSeed(mintP) - Int(mdblSeed(mintP)) Random = mdblSeed(mintP) End Property RandomInt = Int(Random() * (MaxInt - MinInt + 1)) + MinInt End Property Private Sub Zap() Dim intI As Integer For intI = 1 To ARYCNT - 1 mdblSeed(intI) = 1 / intI Next intI mintP = ARYCNT \ 2 mintQ = ARYCNT \ 3 If mintP = mintQ Then mintP = mintP + 1 End If End Sub Private Sub Stir(dblX As Double) mintP = (mintP + 1) Mod ARYCNT mintQ = (mintQ + 1) Mod ARYCNT mdblSeed(mintP) = mdblSeed(mintP) + mdblSeed(mintQ) + dblX mdblSeed(mintP) = mdblSeed(mintP) - Int(mdblSeed(mintP)) End Sub
MySaver應用程式
MySaver應用程式延伸
第二十五章"螢幕保護程式" 中的實例,我們加了很多圖形的選項,藉此增加視覺效果的多樣性,但並沒有增加大量程式碼。圖29-11所顯示的是MySaver螢幕保護程式執行的情形。MySaver螢幕保護程式與 第二十五章"螢幕保護程式" 中的範例有一個主要的差別,那就是MySaver多了一些程式碼,讓使用者可以在「顯示器內容」 - 「螢幕保護裝置」對話方塊中看見預覽視窗中的縮小圖形。當作業系統傳入參數 /P nnnn時,預覽視窗中的縮小圖形就可以被顯示出來,其中nnnn即是預覽視窗中hWnd。在後面的程式中,你可以看見我們在許多地方以全域變數gblnShow判斷圖形目前是應該在"顯示"模式(正常的全螢幕),還是在"預覽"模式(預覽視窗)中,這兩種模式的處理方式並不相同。圖29-12所顯示的是MySaver的預覽視窗。
圖29-11 執行中的MySaver應用程式 |
圖29-12 MySaver的預覽視窗 |
如圖29-13所示,這個專案只有兩張表單,MYSAVER.FRM是啟始表單,而當使用者按下Windows 95 「螢幕保護裝置」對話方塊中頁籤下的「設定」按鈕之後,MYSETUP.FRM才會顯示出來。
圖29-13 MySaver應用程式的專案視窗 |
MYSAVER.BAS
MYSAVER.BAS模組的主要任務是解析命令列參數,採取適當的處置。其中,Sub Main是整個MySaver應用程式的起始點。模組裡面宣告了相關的API函式,以便用這些API函式處理全螢幕的輸出或是處理預覽視窗。
MYSAVER.BAS模組的原始程式碼
`MySaver.bas Option Explicit `Rectangle data structure Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type `Constants for some API functions Private Const WS_CHILD = &H40000000 Private Const GWL_HWNDPARENT = (-8) Private Const GWL_STYLE = (-16) Private Const HWND_TOP = 0& Private Const SWP_NOZORDER = &H4 Private Const SWP_NOACTIVATE = &H10 Private Const SWP_SHOWWINDOW = &H40 `--- API functions Private Declare Function GetClientRect _ Lib "user32" ( _ ByVal hwnd As Long, _ lpRect As RECT _ ) As Long Private Declare Function GetWindowLong _ Lib "user32" Alias "GetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long _ ) As Long Private Declare Function SetWindowLong _ Lib "user32" Alias "SetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long _ ) As Long Private Declare Function 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 Declare Function SetParent _ Lib "user32" ( _ ByVal hWndChild As Long, _ ByVal hWndNewParent As Long _ ) As Long `Global Show/Preview flag Public gblnShow As Boolean `Module level variables Private mlngDisplayHwnd As Long Private recDisplay As RECT `Starting point Public Sub Main() Dim strCmd As String Dim strTwo As String Dim lngStyle As Long Dim lngPreviewHandle As Long Dim lngParam As Long `Process the command line strCmd = UCase(Trim(Command)) strTwo = Left(strCmd, 2) Select Case strTwo `Preview screen saver in small display window Case "/P" `Get HWND of display window mlngDisplayHwnd = Val(Mid(strCmd, 4)) `Get display rectangle dimensions GetClientRect mlngDisplayHwnd, recDisplay `Load form for preview gblnShow = False Load frmMySaver `Get HWND for display form lngPreviewHandle = frmMySaver.hwnd `Get current window style lngStyle = GetWindowLong(lngPreviewHandle, GWL_STYLE) `Append "WS_CHILD" style to the current window style lngStyle = lngStyle Or WS_CHILD `Add new style to display window SetWindowLong lngPreviewHandle, GWL_STYLE, lngStyle `Set display window as parent window SetParent lngPreviewHandle, mlngDisplayHwnd `Save the parent hWnd in the display form's window structure. SetWindowLong lngPreviewHandle, GWL_HWNDPARENT, _ mlngDisplayHwnd `Preview screensaver in the windowDear John, How Do I... SetWindowPos lngPreviewHandle, _ HWND_TOP, 0&, 0&, recDisplay.Right, recDisplay.Bottom, _ SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_SHOWWINDOW Exit Sub `Allow user to set up screen saver Case "/C" Load frmMySetup Exit Sub `Password - not implemented here Case "/A" MsgBox "No password is necessary for this Screen Saver", _ vbInformation, "Password Information" Exit Sub `Show screen saver in normal full screen mode Case "/S" gblnShow = True Load frmMySaver frmMySaver.Show Exit Sub `Unknown command line parameters Case Else Exit Sub End Select End Sub
MYSAVER.FRM
MYSAVER.FRM是螢幕保護程式中所有圖形進行"表演"的地方。我們把表單的WindowState屬性值設為"2 - 最大化"並且關閉了所有表單可以被看見的部份,例如,我們把MinButton和MaxButton的屬性值皆設為False,這使得表單的畫面可以涵蓋整個螢幕。
這張表單上唯一的一個控制項,如圖29-14所示,是一個計時器控制項。在表單的Load事件程序中,我們以一個持續執行的迴圈進行畫面更新的動作,在此情況下,如果我們讓程式在Load事件中結束,Visual Basic會發出錯誤訊息,因此,我們讓Timer事件程序來做表單載出(Unload)的動作。
圖29-14 設計階段中的MYSETUP.FRM |
以下這張表和程式列出了表單的設計內容。
MYSAVER.FRM物件與屬性設定 |
屬性 | 值 |
---|---|
Form | |
Name | frmMySaver |
BorderStyle | 0-None |
ControlBox | False |
MaxButton | False |
MinButton | False |
WindowState | 2-Maximized |
Timer | |
Name | tmrExitNotify |
Interval | 1 |
Enabled | False |
MYSAVER.FRM原始程式碼
`MySaver.frm Option Explicit `API function to hide/show the mouse pointer Private Declare Function ShowCursor _ Lib "user32" ( _ ByVal bShow As Long _ ) As Long `API function to signal activity to system Private Declare Function SystemParametersInfo _ Lib "user32" Alias "SystemParametersInfoA" ( _ ByVal uAction As Long, _ ByVal uParam As Long, _ ByRef lpvParam As Any, _ ByVal fuWinIni As Long _ ) As Long `Constant for API function Private Const SPI_SETSCREENSAVEACTIVE = 17 `Declare module-level variables Dim mlngXai As Long Dim mlngYai As Long Dim mlngXbi As Long Dim mlngYbi As Long Dim mlngLineCount As Long Dim mlngLineWidth As Long Dim mlngActionType As Long Dim mlngXmax As Long Dim mlngYmax As Long Dim mlngInc As Long Dim mlngColorNum() As Long Dim mlngDx1() As Double Dim mlngDx2() As Double Dim mlngDy1() As Double Dim mlngDy2() As Double Dim mlngXa() As Long Dim mlngXb() As Long Dim mlngYa() As Long Dim mlngYb() As Long Dim mblnQuit As Boolean Private Sub Form_Load() Dim lngRet As Long `Tell system that screen saver is active lngRet = SystemParametersInfo( _ SPI_SETSCREENSAVEACTIVE, 0, ByVal 0&, 0) `Go full screen if not in preview mode If gblnShow = True Then Me.WindowState = vbMaximized End If End Sub Private Sub Form_Paint() Dim lngX As Long `In preview mode, set AutoRedraw to True If gblnShow = False Then Me.AutoRedraw = True End If `Create different display each time Randomize `Set control values mlngInc = 5 mlngXmax = 300 mlngYmax = 300 `Get current user settings from Registry mlngActionType = Val(GetSetting("MySaver", "Options", _ "Action", "1")) mlngLineCount = Val(GetSetting("MySaver", "Options", _ "LineCount", "1")) mlngLineWidth = Val(GetSetting("MySaver", "Options", _ "LineWidth", "1")) `Initialize graphics With Me .BackColor = vbBlack .DrawWidth = mlngLineWidth End With Scale (-mlngXmax, -mlngYmax)-(mlngXmax, mlngYmax) `Size arrays ReDim mlngColorNum(0 To mlngLineCount) ReDim mlngXa(1 To mlngLineCount), mlngXb(1 To mlngLineCount) ReDim mlngYa(1 To mlngLineCount), mlngYb(1 To mlngLineCount) `Action types above 4 are a little different If mlngActionType < 5 Then ReDim mlngDx1(1 To mlngLineCount), _ mlngDx2(1 To mlngLineCount) ReDim mlngDy1(1 To mlngLineCount), _ mlngDy2(1 To mlngLineCount) Else ReDim mlngDx1(0), mlngDx2(0) ReDim mlngDy1(0), mlngDy2(0) mlngDx1(0) = Rnd * mlngInc mlngDx2(0) = Rnd * mlngInc mlngDy1(0) = Rnd * mlngInc mlngDy2(0) = Rnd * mlngInc End If `Hide mouse pointer, unless in preview mode If gblnShow = True Then lngX = ShowCursor(False) End If `Do main processing as a loop Do `Update display DoGraphics `Yield execution DoEvents Loop Until mblnQuit = True `Show mouse pointer, unless in preview mode If gblnShow = True Then lngX = ShowCursor(True) End If `Can't quit in this context; let timer do it tmrExitNotify.Enabled = True End Sub Private Sub Form_QueryUnload(Cancel As Integer, _ UnloadMode As Integer) `Using End here appears to prevent memory leaks End End Sub Private Sub Form_Click() `Quit if mouse is clicked, unless in preview mode If gblnShow = True Then mblnQuit = True End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) `Quit if any key is pressed, unless in preview mode If gblnShow = True Then mblnQuit = True End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Static sngTimer As Single `Bail out quickly if in preview mode If gblnShow = False Then Exit Sub `Quit any time after first .25 seconds If sngTimer = 0 Then sngTimer = Timer ElseIf Timer > sngTimer + 0.25 Then mblnQuit = True End If End Sub Private Sub tmrExitNotify_Timer() Dim lngRet As Long `Tell system that screen saver is done lngRet = SystemParametersInfo( _ SPI_SETSCREENSAVEACTIVE, 1, ByVal 0&, 0) `Time to quit End End Sub `~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ `This is where the real graphics drawing takes place `~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sub DoGraphics() Dim intI Static dblColorTime As Double `Shuffle line colors every so often If Timer > dblColorTime Then ColorReset If mlngLineCount < 5 Then dblColorTime = Timer + mlngLineCount * Rnd + 0.3 Else dblColorTime = Timer + 5 * Rnd + 0.3 End If End If `Process based on count of lines For intI = 1 To mlngLineCount `Handle action types below 5 with special procedures If mlngActionType < 5 Then `Keep ends of lines within bounds If mlngXa(intI) <= 0 Then mlngDx1(intI) = mlngInc * Rnd End If If mlngXb(intI) <= 0 Then mlngDx2(intI) = mlngInc * Rnd End If If mlngYa(intI) <= 0 Then mlngDy1(intI) = mlngInc * Rnd End If If mlngYb(intI) <= 0 Then mlngDy2(intI) = mlngInc * Rnd End If If mlngXa(intI) >= mlngXmax Then mlngDx1(intI) = -mlngInc * Rnd End If If mlngXb(intI) >= mlngXmax Then mlngDx2(intI) = -mlngInc * Rnd End If If mlngYa(intI) >= mlngYmax Then mlngDy1(intI) = -mlngInc * Rnd End If If mlngYb(intI) >= mlngYmax Then mlngDy2(intI) = -mlngInc * Rnd End If `Increment the coordinates of the line endpoints mlngXa(intI) = mlngXa(intI) + mlngDx1(intI) mlngXb(intI) = mlngXb(intI) + mlngDx2(intI) mlngYa(intI) = mlngYa(intI) + mlngDy1(intI) mlngYb(intI) = mlngYb(intI) + mlngDy2(intI) `Draw each line with a unique color ForeColor = mlngColorNum(intI) Else `Set action types 5 and 6 with the same color ForeColor = mlngColorNum(0) End If `Draw lines according to action type Select Case mlngActionType Case 1 Line (mlngXa(intI), mlngYa(intI))- _ (mlngXb(intI), mlngYb(intI)) Line (-mlngXa(intI), -mlngYa(intI))- _ (-mlngXb(intI), -mlngYb(intI)) Line (-mlngXa(intI), mlngYa(intI))- _ (-mlngXb(intI), mlngYb(intI)) Line (mlngXa(intI), -mlngYa(intI))- _ (mlngXb(intI), -mlngYb(intI)) Case 2 Line (mlngXa(intI), mlngYa(intI))- _ (mlngXb(intI), mlngYb(intI)), , B Line (-mlngXa(intI), -mlngYa(intI))- _ (-mlngXb(intI), -mlngYb(intI)), , B Line (-mlngXa(intI), mlngYa(intI))- _ (-mlngXb(intI), mlngYb(intI)), , B Line (mlngXa(intI), -mlngYa(intI))- _ (mlngXb(intI), -mlngYb(intI)), , B Case 3 Circle (mlngXa(intI), mlngYa(intI)), _ mlngXb(intI) Circle (-mlngXa(intI), -mlngYa(intI)), _ mlngXb(intI) Circle (-mlngXa(intI), mlngYa(intI)), _ mlngXb(intI) Circle (mlngXa(intI), -mlngYa(intI)), _ mlngXb(intI) Case 4 Line (mlngXa(intI), mlngYa(intI))- _ (mlngXb(intI), -mlngYb(intI)) Line -(-mlngXa(intI), -mlngYa(intI)) Line -(-mlngXb(intI), mlngYb(intI)) Line -(mlngXa(intI), mlngYa(intI)) `Handle action types above 4 a little differently Case 5, 6 If mlngActionType = 5 Then Line (mlngXa(intI), mlngYa(intI))- _ (mlngXb(intI), mlngYb(intI)), _ BackColor Else Line (mlngXa(intI), mlngYa(intI))- _ (mlngXb(intI), mlngYb(intI)), _ BackColor, B End If If mlngXai <= -mlngXmax Then mlngDx1(0) = mlngInc * Rnd + 1 End If If mlngXbi <= -mlngXmax Then mlngDx2(0) = mlngInc * Rnd + 1 End If If mlngYai <= -mlngYmax Then mlngDy1(0) = mlngInc * Rnd + 1 End If If mlngYbi <= -mlngYmax Then mlngDy2(0) = mlngInc * Rnd + 1 End If If mlngXai >= mlngXmax Then mlngDx1(0) = -mlngInc * Rnd + 1 End If If mlngXbi >= mlngXmax Then mlngDx2(0) = -mlngInc * Rnd + 1 End If If mlngYai >= mlngYmax Then mlngDy1(0) = -mlngInc * Rnd + 1 End If If mlngYbi >= mlngYmax Then mlngDy2(0) = -mlngInc * Rnd + 1 End If mlngXai = mlngXai + mlngDx1(0) mlngXbi = mlngXbi + mlngDx2(0) mlngYai = mlngYai + mlngDy1(0) mlngYbi = mlngYbi + mlngDy2(0) mlngXa(intI) = mlngXai mlngXb(intI) = mlngXbi mlngYa(intI) = mlngYai mlngYb(intI) = mlngYbi If mlngActionType = 5 Then Line (mlngXa(intI), mlngYa(intI))- _ (mlngXb(intI), mlngYb(intI)) Else Line (mlngXa(intI), mlngYa(intI))- _ (mlngXb(intI), mlngYb(intI)), , B End If End Select Next intI End Sub Sub ColorReset() Dim intI `Randomize set of colors If mlngActionType <= 4 Then For intI = 1 To mlngLineCount mlngColorNum(intI) = _ RGB(Rnd * 256, Rnd * 256, Rnd * 256) Next intI `Use bright colors for action types 5 or 6 Else mlngColorNum(0) = QBColor(Int(8 * Rnd) + 8) End If End Sub
這個程式以Shell命令列傳來的參數作為其處理的依據,其中 /C參數使MYSETUP表單顯現,而 /S參數則驅動處理圖形繪製的迴圈。關於對螢幕保護程式更深入的資訊,請參閱 第二十五章"螢幕保護程式" 。
我們在這個例子中設計了六種不同的動畫圖形,每一個選項下的線條寬度與線條數目都可以不一樣。雖然每一個選項所造成的效果大不相同,但大部份的程式碼卻只有些微的差別而已,例如,在Case 2底下,Line方法使用了B參數,使Line方法畫出一連串方盒形狀而不是對角線。
MYSETUP.FRM
前面提過,當使用者按下「螢幕保護裝置」頁籤下的「設定」按鈕時,MySetup表單會被顯示。MYSETUP.FRM本身是一個對話方塊,它讓你選擇六種圖形表現方式以及設定線條數目和線條的像素寬度,這些設定值皆以GetSetting和SaveSetting陳述式讀寫於系統登錄中。每當MySetup表單被開啟時,表單上所顯示的都是當前的設定。圖29-15顯示的是設計階段的MySetup表單。
圖29-15 設計階段中的MYSETUP.FRM |
以下這張表和後面的程式說明了MySetup表單的設計內容。
MYSETUP.FRM物件與屬性設定 |
編號 * | 屬性 | 值 |
---|---|---|
Form |
Name BorderStyle Caption ScaleMode |
frmMySetup 3-FixedDialog MySaver-Setup 3-Pixel |
Frame 1 |
Name Caption |
Frame1 Action |
Frame 2 |
Name Caption |
Frame2 Lines |
CommandButton 3 |
Name Caption |
cmdOK OK |
OptionButton 4 |
Name Index Caption |
optAction 0 Driftinglines,mirrored in each corner |
OptionButton 5 |
Name Index Caption |
optAction 1 Drifting boxes, mirrored in each corner |
OptionButton 6 |
Name Index Caption |
optAction 2 Circles, mirrored in each corner |
OptionButton 7 |
Name Index Caption |
optAction 3 Parallelograms, twisting and turning |
OptionButton 8 |
Name Index Captio |
optAction 4 A drifting line, caged by the screen |
OptionButton 9 |
Name Index Caption |
optAction 5 A drifting box, frenetically caged |
TextBox 10 |
Name | txtLineCount |
TextBox 11 |
Name | txtLineWidth |
Label 12 |
Name Caption |
Label1 Count: |
Label 13 |
Name Caption |
label2 Thickness: |
*"編號"欄中的號碼用來標示圖29-15中表單上物件的位置。
MYSETUP.FRM原始程式碼
`MySetup.frm Option Explicit Dim mstrAction As String Private Sub Form_Load() `Center this form Me.Left = (Screen.Width - Me.Width) \ 2 Me.Top = (Screen.Height - Me.Height) \ 2 `Get current settings from the Registry mstrAction = GetSetting("MySaver", "Options", "Action", "1") optAction(Val(mstrAction) - 1).Value = True txtLineCount.Text = GetSetting("MySaver", "Options", _ "LineCount", "5") txtLineWidth.Text = GetSetting("MySaver", "Options", _ "LineWidth", "1") Me.Show End Sub Private Sub cmdOK_Click() Dim lngN As Long `Check line count option lngN = Val(txtLineCount.Text) If lngN < 1 Or lngN > 1000 Then MsgBox "Line count should be a small positive integer", _ vbExclamation, "MySaver" Exit Sub End If `Check line thickness option lngN = Val(txtLineWidth.Text) If lngN < 1 Or lngN > 100 Then MsgBox _ "Line thickness should be a small positive integer", _ vbExclamation, "MySaver" Exit Sub End If `Save the settings SaveSetting "MySaver", "Options", "Action", mstrAction SaveSetting "MySaver", "Options", "LineCount", _ txtLineCount.Text SaveSetting "MySaver", "Options", "LineWidth", _ txtLineWidth.Text `Close the Setup dialog box Unload Me End Sub Private Sub optAction_Click(Index As Integer) mstrAction = Format(Index + 1) End Sub
在這張表單中,大部份的程式碼都在做讀寫登錄設定資料的動作;在GetSetting陳述式中,我們使用了預設值來確使GetSetting陳述式必定能得到有效的設定值。
如果要完成這個螢幕保護程式,你必須把它編譯成執行檔,以含SCR作為其附屬檔名,如MYSSAVOR.SCR。然後將它複製到Windows目錄中,這樣,你就可以在「顯示器內容」對話方塊中「螢幕保護裝置」頁籤下的「螢幕保護裝置」下拉式清單方塊中找到你的螢幕保護程式。
關於如何編譯螢幕保護程式的資訊,請參閱
第二十五章"螢幕保護程式" 。