form1.frm

一个vb编写的程序

   End If
   aa0 = Me.List1.ListIndex
   DelRecord MyStr, "程序收集", Me.List1.Text, Me.Text1
  If ShanChu = 6 Then
   Me.List1.Clear
   MyNum = CountNum(MyStr, "程序收集")
   Me.Caption = "程序收集1.0" + "--共有" + Trim(Str(MyNum)) + "条记录"
   If aa0 + 1 > MyNum Then
    Me.List1.ListIndex = aa0 - 1
    Else
    Me.List1.ListIndex = aa0
   End If
  End If
  Case 3
  If Trim(Me.Text2) <> "" And Trim(Me.Text3) <> "" Then
   AddRecord MyStr, "程序收集", Trim(Me.Text2), Me.Text3
   command2(3).Enabled = False
   command2(9).Enabled = False
   Me.MNUBC.Enabled = False
   Me.MNUQX.Enabled = False
   Me.List1.Visible = True
   Me.Text1.Visible = True
   command2(0).Enabled = True
   command2(1).Enabled = True
   command2(2).Enabled = True
   Command1(0).Enabled = True
   Me.MNUSYT.Enabled = True
   Me.MNUXYT.Enabled = True
   Me.MNUZJ.Enabled = True
   Me.MNUSC.Enabled = True
   Me.Text2.Visible = False
   Me.Text3.Visible = False
   Me.List1.Clear
   MyNum = CountNum(MyStr, "程序收集")
   Me.Caption = "程序收集1.0" + "--共有" + Trim(Str(MyNum)) + "条记录"
   Me.List1.ListIndex = 0
  Else
   MsgBox "字段名称不能为空值，请重输！", 48
  End If
  Case 4
   frmAbout.Show
  Case 5
   ShellExecute 0&, vbNullString, "MailTo:[e-mail]", vbNullString, vbNullString, vbNormalFocus
  Case 6
   ShellExecute 0&, vbNullString, "Http:\\cehome.yeah.net", vbNullString, vbNullString, vbNormalFocus
  Case 7
   help0.Show
  Case 8
   End
  Case 9
   command2(3).Enabled = False
   command2(9).Enabled = False
   Me.MNUBC.Enabled = False
   Me.MNUQX.Enabled = False
   Me.List1.Visible = True
   Me.Text1.Visible = True
   Me.Text2.Visible = False
   Me.Text3.Visible = False
   command2(0).Enabled = True
   command2(1).Enabled = True
   command2(2).Enabled = True
   Command1(0).Enabled = True
   Me.MNUSYT.Enabled = True
   Me.MNUXYT.Enabled = True
   Me.MNUZJ.Enabled = True
   Me.MNUSC.Enabled = True
 End Select
End Sub

Private Sub Form_Load()
    FldVal1$ = "关于本软件"
    HH0$ = Chr$(13) + Chr$(10)
    SM$ = "     程序收集 1.0属免费软件。您是否为了找寻一篇下" + _
    "载的文章或程序不知放在那里而着急，是否对太多有价值的文章" + _
    "无法管理而头疼，作者在这方面有太多感触，由此，“程序收集”" + _
    "诞生了。这是作者编写的第一个真正意义上的自由软件，其余编写" + _
    "的大多为专业软件，现正主要参与开发“十三陵大坝安全监测管理" + _
    "系统”，此为忙里偷闲之作品，希望您能够喜欢。使用方法见帮助。" + _
    "如果您想要作者收集的VB程序，请到作者的主页：cehome.yeah.net" + _
    "下载；如果您想要该软件的源代码，也请来访问。希望您能够留言，" + _
    "提出宝贵意见，以便我改进该作品，也希望您能在此基础上写出更" + _
    "好的软件。您如是VB爱好者，请来信交流，我必尽己所能。作者" + _
    "自学VB一年有余，有时为某一功能的实现要花费许多时间，深知" + _
    "编程之苦、之乐。此为抛砖引玉，目的是希望更多的程序员公布" + _
    "自己的源代码，促进中" + _
    "国软件事业的发展。若您有疑问，可E-mail:[e-mail]" + HH0$
    SM$ = SM$ + "     " + HH0$
    SM$ = SM$ + "              海军最后修改于99年11月" + HH0$
    FldVal2$ = SM$
    MyNum = CountNum(MyStr, "程序收集")
    Me.Caption = Me.Caption + "--共有" + Trim(Str(MyNum)) + "条记录"
 If MyNum = 0 Then
   AddRecord MyStr, "程序收集", FldVal1$, FldVal2
   MyNum = CountNum(MyStr, "程序收集")
   Me.Caption = Me.Caption + "--共有" + Trim(Str(MyNum)) + "条记录"
  Else
   Dim I As Integer, StrZhi As String
   Dim MyDb As Database, MyTable As Recordset
   Set MyDb = Workspaces(0).OpenDatabase(MyStr)
   Set MyTable = MyDb.OpenRecordset("程序收集", dbOpenDynaset)
   StrZhi = "程序名称='关于本软件'"
   MyTable.FindFirst StrZhi
   If MyTable.NoMatch Then
    MyDb.Close
    AddRecord MyStr, "程序收集", FldVal1$, FldVal2
    Me.List1.Clear
    MyNum = CountNum(MyStr, "程序收集")
    Me.Caption = Me.Caption + "--共有" + Trim(Str(MyNum)) + "条记录"
    ViewGY
   Else
    ViewGY
   End If
 End If
End Sub

Private Sub Form_Resize()
On Error GoTo 1
If Me.Height = 0 And Me.Width = 0 Then Exit Sub
If Me.Width < 7440 Then Me.Width = 7440
SizeControls imgSplitter.Left
1
End Sub

Private Sub Form_Unload(Cancel As Integer)
 End
End Sub

Private Sub MNUABOUT_Click()
frmAbout.Show
End Sub

Private Sub MNUBZHU_Click()
 help0.Show
End Sub

Private Sub MNUEXIT_Click()
 Unload Me
End Sub

Private Sub MNUFW_Click()
 ShellExecute 0&, vbNullString, "Http:\\cehome.yeah.net", vbNullString, vbNullString, vbNormalFocus
End Sub

Private Sub MNUQX_Click()
 command2_Click (9)
End Sub

Private Sub MNUSC_Click()
 command2_Click (2)
End Sub

Private Sub MNUSYT_Click()
 If Me.List1.ListIndex = 0 Then
       Me.List1.ListIndex = 0
     Else
       Me.List1.ListIndex = Me.List1.ListIndex - 1
   End If
End Sub

Private Sub MNUXIE_Click()
 ShellExecute 0&, vbNullString, "MailTo:[e-mail]", vbNullString, vbNullString, vbNormalFocus
End Sub

Private Sub List1_Click()
  Me.Caption = "发动机资料" + "--共有" + Trim(Str(MyNum)) + "条记录" + "-这是第" + Trim(Str(Me.List1.ListIndex + 1)) + "条记录"
  ViewMemo MyStr, "程序收集"
End Sub
Sub ViewMemo(DatabaseName As String, TableName As String)
'显示备注中的内容,第一个参数是数据库名，第二个参数是表名
 Dim I As Integer
 Dim MyDb As Database, MyTable As Recordset
 Set MyDb = Workspaces(0).OpenDatabase(DatabaseName)
 Set MyTable = MyDb.OpenRecordset(TableName, dbOpenDynaset)
 num_processed = 0
 Do While Not MyTable.EOF
        num_processed = num_processed + 1
        If num_processed = Me.List1.ListIndex + 1 Then
         Me.Text1 = MyTable.Fields(1).Value
         Exit Do
        End If
        MyTable.MoveNext
 Loop
   MyTable.Close
   MyDb.Close
End Sub

Private Sub MNUXYT_Click()
 If Me.List1.ListIndex + 1 < MyNum Then
    Me.List1.ListIndex = Me.List1.ListIndex + 1
  End If
End Sub
Sub DelRecord(DatabaseName As String, TableName As String, FldVal1 As String, FldVal2 As String)
 '向表中删除记录：第一个参数是数据库名，第二个参数是表名，第三个参数是数组，其中的元素是记录
 '中的各字段的值
 ShanChu = MsgBox("确定要删除这条记录吗？", 36, "删除记录")
 If ShanChu = 6 Then
 Dim I As Integer, StrZhi As String
 Dim MyDb As Database, MyTable As Recordset
 Set MyDb = Workspaces(0).OpenDatabase(DatabaseName)
 Set MyTable = MyDb.OpenRecordset(TableName, dbOpenDynaset)
 StrZhi = "程序名称='" + FldVal1 + "'"
 MyTable.FindFirst StrZhi
 MyTable.Delete
 MyTable.MoveNext
 If MyTable.EOF Then
  MyTable.MoveLast
  Me.Text1 = MyTable.Fields(1).Value
 Else
  Me.Text1 = MyTable.Fields(1).Value
 End If
  MyDb.Close
End If
End Sub
Private Sub MNUZJ_Click()
command2_Click (1)
End Sub
Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    With imgSplitter
        picSplitter.Move .Left, .Top, .Width \ 2, .Height - 20
    End With
    picSplitter.Visible = True
    mbMoving = True
End Sub
Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim sglPos As Single
    If mbMoving Then
        sglPos = x + imgSplitter.Left
        If sglPos < sglSplitLimit Then
            picSplitter.Left = sglSplitLimit
        ElseIf sglPos > Me.Width - sglSplitLimit Then
            picSplitter.Left = Me.Width - sglSplitLimit
        Else
            picSplitter.Left = sglPos
        End If
    End If
End Sub
Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    SizeControls picSplitter.Left
    picSplitter.Visible = False
    mbMoving = False
End Sub
Sub SizeControls(x As Single)
    On Error Resume Next
    '设置 Width 属性
    If x < 2000 Then x = 3000
    If x > (Me.Width - 3000) Then x = Me.Width - 3000
    If List1.Visible = True Then
     List1.Width = x
    Else
     Text2.Width = x
    End If
    imgSplitter.Left = x
    imgSplitter.Top = Picture2.Height
    imgSplitter.Height = Me.Height - Picture2.Height
    picSplitter.Top = Picture2.Height
    picSplitter.Height = Me.Height - Picture2.Height
    If List1.Visible = True Then
     Text1.Left = x + 40
     Text1.Width = Me.Width - (List1.Width + 140)
     Label1.Width = List1.Width
     Label2.Left = Text1.Left
     Label2.Width = Text1.Width - 40
     List1.Top = Picture2.Height + picTitles.Height
     Text1.Top = List1.Top
     List1.Height = Me.ScaleHeight - Picture2.Top - 1000
     Text1.Height = List1.Height
     imgSplitter.Top = List1.Top
     imgSplitter.Height = List1.Height
     Else
     Text2.Left = 0
     Text3.Left = x + 40
     Text3.Width = Me.Width - (Text2.Width + 140)
     Label1.Width = Text2.Width
     Label2.Left = Text3.Left
     Label2.Width = Text3.Width - 40
     Text2.Top = Picture2.Height + Label1.Height
     Text3.Top = Text2.Top
     Text2.Height = Me.ScaleHeight - Picture2.Top - 1000
     Text3.Height = Text2.Height
     imgSplitter.Top = Text2.Top
    imgSplitter.Height = Text2.Height
    End If
End Sub


Private Sub list1_DragDrop(Source As Control, x As Single, y As Single)
    If Source = imgSplitter Then
        SizeControls x
    End If
End Sub
Private Sub text2_DragDrop(Source As Control, x As Single, y As Single)
    If Source = imgSplitter Then
        SizeControls x
    End If
End Sub
Sub ViewGY()
 Dim I As Integer
 Dim MyDb As Database, MyTable As Recordset
 Set MyDb = Workspaces(0).OpenDatabase(MyStr)
 Set MyTable = MyDb.OpenRecordset("程序收集", dbOpenDynaset)
 num_processed = 0
 Do While Not MyTable.EOF
        num_processed = num_processed + 1
        If MyTable.Fields(0).Value = "关于本软件" Then
         Me.List1.ListIndex = num_processed - 1
         Exit Do
        End If
        MyTable.MoveNext
 Loop
   MyTable.Close
   MyDb.Close
End Sub