介绍一个VB小的有趣的程序代码

'万花筒程序

'粘贴下面代码即可, 不用添加任何控件

Private WithEvents Timer1 As Timer

Dim r&, r1&, t&, a1!, a2!, xb!, yb!, s!, b#

Private Sub Form_Load()

      Me.Width = 4500: Me.Height = 4500

      Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2

      Me.AutoRedraw = True

      Me.Caption = "CBM666的万花筒"

      Set Timer1 = Controls.Add("vb.timer", "Timer1")

      Timer1.Interval = 10

End Sub

Private Sub Timer1_Timer()

      Randomize

      r = 340 * Rnd

      If r <> 0 Then

         r1 = 500

         s = r * Rnd

         b = RGB(256 * Rnd, 256 * Rnd, 256 * Rnd)

         For t = 1 To 10000

            a1 = t * 3.1415926 / 180

            a2 = (r1 / r) * a1

            xb = 500 + (-(r1 - r) * Cos(a1) - s * Cos(a2 - a1) + 420) * 4

            yb = 500 + ((r1 - r) * Sin(a1) - s * Sin(a2 - a1) + 380) * 4

            Me.PSet (xb, yb), b

         Next t

      End If

End Sub

'添加一个TextBox 设置其MultiLine=True 示例代码如下：

Private Sub Form_Click()

Dim a(1 To 100) As Integer

Randomize Timer

Print "随机产生的100个数据是："

For i = 1 To 100

a(i) = Int(Rnd * 90 + 10)

Print a(i)" "

If i Mod 10 = 0 Then Print

Next i

For i = 1 To 99

For j = i + 1 To 100

If a(i) >a(j) Then

c = a(i)

a(i) = a(j)

a(j) = c

End If

Next j

Next i

For i = 1 To 100

If a(i) >= 50 Then

Text1.Text = Text1.Text &a(i) &" "

b = b + 1

If b Mod 10 = 0 Then Text1.Text = Text1.Text &vbCrLf

End If

Next i

End Sub

给几个写的模块给你看看

Public Function LoadData(strSQL As String)

Dim rst As DAO.Recordset

Dim ctl As Control

Dim fld As Object

Set rst = CurrentDb.OpenRecordset(strSQL, , dbReadOnly)

If Not rst.EOF Then

For Each ctl In ctlFormName

If Not (TypeOf ctl Is Label Or TypeOf ctl Is CommandButton) Then

For Each fld In rst.Fields

If fld.Name = ctl.Name Then

ctl = rst(fld.Name)

Exit For

End If

Next

End If

Next

End If

rst.Close

Set rst = Nothing

End Function

Public Function AddData(TableName As String)

Dim rst As DAO.Recordset

Dim ctl As Control

Dim fld As Object

Set rst = CurrentDb.OpenRecordset(TableName, , dbReadOnly)

For Each ctl In ctlFormName

If Not (TypeOf ctl Is Label Or TypeOf ctl Is CommandButton) Then

For Each fld In rst.Fields

If fld.Name = ctl.Name Then

ctl = fld.DefaultValue

Exit For

End If

Next

End If

Next

rst.Close

Set rst = Nothing

End Function

Public Function SaveData(strSQL As String)

'On Error GoTo Err_SaveData

Dim rst As DAO.Recordset

Dim ctl As Control

Dim fld As Object

If MsgBox("您确认要保存吗?", vbOKCancel + vbInformation, "提示!!!") = vbOK Then

If AddTag = True Then

Set rst = CurrentDb.OpenRecordset(strSQL, , dbReadOnly)

rst.AddNew

Else

Set rst = CurrentDb.OpenRecordset(strSQL)

rst.Edit

End If

For Each ctl In ctlFormName

'Debug.Print ctl.Name

If Not (TypeOf ctl Is Label Or TypeOf ctl Is CommandButton) Then

For Each fld In rst.Fields

'Debug.Print fld.Name

If fld.Name = ctl.Name Then

rst(fld.Name) = ctl

Exit For

End If

Next

End If

Next

rst.Update

rst.Close

Set rst = Nothing

MsgBox "数据保存成功!", vbInformation, "提示!!!"

End If

Exit_SaveData:

Set rst = Nothing

Exit Function

Err_SaveData:

If Err = 3022 Then

MsgBox "同一节点下不能存在相同的子节点，请修改后再点保存！", vbCritical, "警告!!!"

Else

MsgBox Err.Source &" #" &Err &vbCrLf &vbCrLf &Err.Description, vbCritical

On Error Resume Next

End If

Resume Exit_SaveData

End Function

Public Function DelSource(Form As Form)

Dim ctl As Control

Form.RecordSource = ""

For Each ctl In Form

If Not (TypeOf ctl Is Label) Then

ctl.ControlSource = ""

End If

Next

End Function

Public Function DelData(strSQL As String)

Dim rst As New ADODB.Recordset

Dim i As Long

If MsgBox("你确定要删除当前记录吗？", vbOKCancel + vbQuestion, "删除!!!") = vbOK Then

'Debug.Print strSQL

rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

If rst.RecordCount >0 Then

For i = 1 To rst.RecordCount

rst.Delete

rst.Update

rst.MoveNext

Next

End If

rst.Close

Set rst = Nothing

End If

End Function

---