■当前位置：首页 > VB 小程序 100-199 > VB 万花筒

　 　 　 105. VB 万花筒

　本程序用大圆叠加正弦波、大圆叠加小圆的方式，画出千变万化的万花筒图案。
　 程序运行截图：
http://s16/middle/b1879bb4xc9a9e643265f&690代码 VB 小程序：万花筒" TITLE="VB 代码 VB 小程序：万花筒" />

http://s9/middle/b1879bb4x7a90fd6a28c8&690代码 VB 小程序：万花筒" TITLE="VB 代码 VB 小程序：万花筒" />

http://s8/middle/b1879bb4x7a90fd6b1667&690代码 VB 小程序：万花筒" TITLE="VB 代码 VB 小程序：万花筒" />

http://s14/middle/b1879bb4xc9a9e63aa3ed&690代码 VB 小程序：万花筒" TITLE="VB 代码 VB 小程序：万花筒" />

http://s7/middle/b1879bb4xc9a9e6304586&690代码 VB 小程序：万花筒" TITLE="VB 代码 VB 小程序：万花筒" />

' ''以下是窗体代码，在 VB6 和 WinXP 下调试通过。
'直接将代码粘贴到窗体代码区，不用放置任何控件。

'本人原创，转载请注明来源：http://blog.sina.com.cn/s/blog_b1879bb401018mbu.html
Dim WithEvents Timer1 As Timer
Dim Pic As PictureBox, Comb() As ComboBox, Labe() As Label
Dim Chec As CheckBox, ctP360, C1, C2
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Form_Load()
   Me.Caption = "VB 万花筒"
   
   Set Pic = Controls.Add("vb.PictureBox", "Pic1")
   Pic.AutoRedraw = True: Pic.Visible = True
   Pic.BackColor = &HFFFFFF
   
   Set Chec = Controls.Add("vb.CheckBox", "Chec1")
   Chec.Visible = True: Chec.Caption = "显示单个图像"
   
   Dim I As Long, s As Long
   s = 8
   ReDim Comb(1 To s): ReDim Labe(1 To s)
   For I = 1 To UBound(Comb)
      Set Comb(I) = Controls.Add("vb.ComboBox", "Comb" & I)
      Set Labe(I) = Controls.Add("vb.Label", "Labe" & I)
   Next
   
   s = 1: Labe(s).Caption = "花瓣数"
   For I = 0 To 10
      If I = 0 Then Comb(s).AddItem I & " 随机"
      If I = 1 Then Comb(s).AddItem I & " 渐变"
      If I > 1 Then Comb(s).AddItem I & " 个"
   Next
   Comb(s).ListIndex = 0
   
   s = 2: Labe(s).Caption = "花瓣高度"
   For I = -1 To 11
      If I < 0 Then Comb(s).AddItem I & " 随机"
      If I > -1 And I < 11 Then Comb(s).AddItem I
      If I = 11 Then Comb(s).AddItem I & "  渐变"
   Next
   Comb(s).ListIndex = 0
   
   s = 3: Labe(s).Caption = "旋转"
   Comb(s).AddItem "0 旋转"
   Comb(s).AddItem "1 随机"
   Comb(s).AddItem "2 不旋转"
   Comb(s).ListIndex = 1
   
   s = 4: Labe(s).Caption = "绘图周期"
   For I = 1 To 10
      Comb(s).AddItem I & " 个"
   Next
   Comb(s).ListIndex = 5
   
   s = 5: Labe(s).Caption = "周期偏移"
   For I = -1 To 10
      If I = -1 Then Comb(s).AddItem I & " 随机"
      If I = 0 Then Comb(s).AddItem I & " 无"
      If I > 0 And I < 10 Then Comb(s).AddItem I
      If I = 10 Then Comb(s).AddItem I & " 渐变"
   Next
   Comb(s).ListIndex = 0
   
   s = 6: Labe(s).Caption = "线条宽度"
   For I = 0 To 10
      If I = 0 Then Comb(s).AddItem I & " 随机"
      If I > 0 Then Comb(s).AddItem I
   Next
   Comb(s).ListIndex = 0
   
   s = 7: Labe(s).Caption = "主圆半径"
   For I = 0 To 2
      If I = 0 Then Comb(s).AddItem I & " 随机"
      If I = 1 Then Comb(s).AddItem I & " 渐变"
      If I = 2 Then Comb(s).AddItem I & " 固定"
   Next
   Comb(s).ListIndex = 0
   
   s = 8: Labe(s).Caption = "图形叠加"
   For I = 0 To 2
      If I = 0 Then Comb(s).AddItem I & " 随机"
      If I = 1 Then Comb(s).AddItem I & " 正弦 大圆"
      If I = 2 Then Comb(s).AddItem I & " 小圆 大圆 "
   Next
   Comb(s).ListIndex = 0
   
   ctP360 = Atn(1) * 8
   Set Timer1 = Controls.Add("vb.timer", "Timer1")
   Timer1.Enabled = True: Timer1.Interval = 20
   Me.Move Screen.Width * 0.2, Screen.Height * 0.2, Screen.Width * 0.6, Screen.Height * 0.6
End Sub

Private Sub Form_Resize()
   Dim I As Long, L As Single, W As Single, H1 As Single, W1 As Single
   
  
   On Error Resume Next
   
   H1 = Comb(1).Height: W = H1 * 7
   L = Me.ScaleWidth - W - H1 * 0.5
  
   W1 = Me.TextHeight("A") * 4.5  'Labe 的宽度
   Chec.Move L, H1, W, H1
   For I = 1 To UBound(Comb)
      Labe(I).Move L, (I + 1) * H1 * 1.2 + H1 * 0.2, W1, H1
      Comb(I).Move L + W1, (I + 1) * H1 * 1.2, W - W1
      Comb(I).Visible = True: Labe(I).Visible = True
   Next
   If TypeName(Pic) = "PictureBox" Then Pic.Move 0, 0, Me.ScaleWidth - W - H1, Me.ScaleHeight
   W1 = Pic.CurrentX: H1 = Pic.CurrentY
   Pic.Cls
   Pic.CurrentX = W1:  Pic.CurrentY = H1
End Sub

Private Sub Timer1_Timer()
   Dim I As Long, IsSin As Boolean, Se As Long
   Dim J, J1, t, t1, r, a, b, s, K1, K2, X0, Y0, X, Y
   
   X0 = Pic.ScaleWidth * 0.5: Y0 = Pic.ScaleHeight * 0.5
   
   C1 = C1 + 0.01: C2 = C2 + 0.013
   If C1 > ctP360 Then C1 = C1 - ctP360
   If C2 > ctP360 Then C2 = C2 - ctP360
   K1 = Sin(C1): K2 = Sin(C2) 'K1 的变化量 -1 到 1
   
   Randomize
   I = Int(Val(Comb(7).Text)) '主圆半径
   If X0 > Y0 Then r = Y0 Else r = X0
   If I = 0 Then r = r * 0.5 * Rnd  '随机
   If I = 1 Then r = r * 0.5 * K1   '渐变
   If I = 2 Then r = r * 0.5        '固定
   b = 1  '纵横比
   
   Se = &HFFFFFF * Abs(K2)
   'Se = &HFFFFFF * Rnd
   
   I = Int(Val(Comb(6).Text))
   If I = 0 Then Pic.DrawWidth = 1 + Int(10 * Rnd)
   If I > 0 And I < 11 Then Pic.DrawWidth = I
   
   I = Int(Val(Comb(1).Text))  '圆弧上的花瓣数
   If I < 1 Then s = Rnd * 10  '随机
   If I = 1 Then s = K1 * 10   '渐变
   If I > 1 Then s = I         '指定个数
   
   I = Val(Comb(5).Text) '周期偏移
   If I < 0 Then I = -1
   If I < 0 Then s = s + Rnd '随机
   If I >= 0 And I < 10 Then s = s + I / 10 '指定
   If I >= 10 Then s = s + K1 '渐变
   
   I = Val(Comb(2).Text)     '花瓣高度
   If I < 0 Then a = Rnd    '随机
   If I > 10 Then a = K1    '渐变
   If I > -1 And I < 11 Then a = I / 10 '指定高度
   
   I = Val(Comb(3).Text) '旋转
   If I < 1 Then t1 = ctP360 * K1   '旋转
   If I = 1 Then t1 = ctP360 * Rnd  '随机旋转
   If I > 1 Then t1 = 0             '不旋转
   
   I = Val(Comb(4).Text) '绘图周期
   If I < 1 Then I = 1
   If I > 10 Then I = 10
   J1 = I 'ctP360 * I
  
   I = Val(Comb(8).Text) '图形叠加
   If I < 1 Then IsSin = Rnd > 0.5 '随机
   If I = 1 Then IsSin = True      '大圆正弦波
   If I > 1 Then IsSin = False     '大圆小圆
   If Not IsSin Then s = s + 1 '此时增加一个花瓣数
   
   If Chec.Value = 1 Then Pic.Cls
   GetXY 0, t1, r, s, a, b, X0, Y0, X, Y, IsSin
   Pic.PSet (X, Y), Se
   For J = 0 To J1 - 1
       Se = &HFFFFFF * Rnd
      For t = 0 To ctP360 Step 0.02
         GetXY J * ctP360 + t, t1, r, s, a, b, X0, Y0, X, Y, IsSin
         Pic.Line -(X, Y), Se
'         Sleep 1
'         DoEvents
      Next
   Next
   
'   GetXY J * ctP360, t1, r, s, a, b, X0, Y0, X, Y, IsSin
'   Pic.Line -(X, Y), Se
End Sub

Private Sub GetXY(t, t1, ByVal r, s, a, b, X0, Y0, X, Y, IsSin As Boolean)
   If IsSin Then '---- 大圆叠加正弦
      r = r * (1 + a * Sin(t * s)) '主圆半径按正弦规律变化
      X = X0 + r * Sin(t + t1): Y = Y0 + r * Cos(t + t1) * b
   Else '------------- 大圆叠加小圆
      '大圆
      X = r * Sin(t + t1): Y = r * Cos(t + t1) * b
      '叠加上小圆：半径为大圆的 a 倍， 周期为 S 倍
      r = r * a
      X = X0 + X + r * Sin(t * s): Y = Y0 + Y + r * Cos(t * s)
    End If
End Sub

■当前位置：首页 > VB 小程序 100-199 > VB 万花筒