VB 古诗欣赏系统

Option ExplicitPrivate Type Poetry    '自定义古诗类型 5句内容 和 图片NeiRong(0 To 4) As String * 50TuPian As String * 50
End TypeDim Poetrys() As Poetry    '声明古诗数组为  自定义类型
Dim Current As Integer    '当前第几首Private Sub Command1_Click()Current = 1Timer1.Interval = Val(Text1)Timer1.Enabled = TrueCommand1.Enabled = FalseCommand2.Enabled = FalseCommand3.Enabled = FalseCommand4.Enabled = False
End SubPrivate Sub Command2_Click()If Current > 1 Then Current = Current - 1    '上一首Timer1.Interval = Val(Text1)Timer1.Enabled = TrueCommand1.Enabled = FalseCommand2.Enabled = FalseCommand3.Enabled = FalseCommand4.Enabled = False
End SubPrivate Sub Command3_Click()If Current < UBound(Poetrys) Then Current = Current + 1    '上一首Timer1.Interval = Val(Text1)Timer1.Enabled = TrueCommand1.Enabled = FalseCommand2.Enabled = FalseCommand3.Enabled = FalseCommand4.Enabled = False
End SubPrivate Sub Command4_Click()Current = UBound(Poetrys)Timer1.Interval = Val(Text1)Timer1.Enabled = TrueCommand1.Enabled = FalseCommand2.Enabled = FalseCommand3.Enabled = FalseCommand4.Enabled = False
End SubPrivate Sub Command5_Click()If Len(Text2) <> 0 And Len(Text3) <> 0 Then    '如果古诗有内容，并且配图有内容则添加记录Dim tmptmp = Split(Trim(Text2), vbCrLf)    '通过vbcrlf打散字符串text2的内容,Trim函数去掉字符串左右的空白If UBound(tmp) <> 4 ThenMsgBox "古诗的内容必须是5行"Exit SubEnd IfList1.AddItem tmp(0)    '将text2的第一行内容显示在列表框中ReDim Preserve Poetrys(UBound(Poetrys) + 1)    '扩大古诗数组元素个数增1，并保持前面数据不丢失，所以要用 Preserve来修饰Poetrys(UBound(Poetrys)).NeiRong(0) = tmp(0)Poetrys(UBound(Poetrys)).NeiRong(1) = tmp(1)Poetrys(UBound(Poetrys)).NeiRong(2) = tmp(2)Poetrys(UBound(Poetrys)).NeiRong(3) = tmp(3)Poetrys(UBound(Poetrys)).NeiRong(4) = tmp(4)Poetrys(UBound(Poetrys)).TuPian = Text3fileWrite    ' 记录写入文件Text2 = ""Text3 = ""ElseMsgBox "古诗内容为空或配图为空，请检查"End If
End SubPrivate Sub Command6_Click()If Len(Text2) <> 0 And Len(Text3) <> 0 Then    '如果古诗有内容，并且配图有内容则添加记录Dim tmptmp = Split(Trim(Text2), vbCrLf)    '通过vbcrlf打散字符串text2的内容,Trim函数去掉字符串左右的空白If UBound(tmp) <> 4 ThenMsgBox "古诗的内容必须是5行"Exit SubEnd IfIf List1.ListIndex > -1 ThenList1.List(List1.ListIndex) = tmp(0)    '将text2的第一行内容替换列表框所选择的内容Poetrys(List1.ListIndex + 1).NeiRong(0) = tmp(0)Poetrys(List1.ListIndex + 1).NeiRong(1) = tmp(1)Poetrys(List1.ListIndex + 1).NeiRong(2) = tmp(2)Poetrys(List1.ListIndex + 1).NeiRong(3) = tmp(3)Poetrys(List1.ListIndex + 1).NeiRong(4) = tmp(4)Poetrys(List1.ListIndex + 1).TuPian = Text3fileWrite    ' 记录写入文件Text2 = ""Text3 = ""End IfElseMsgBox "古诗内容为空或配图为空，请检查"End If
End SubPrivate Sub Command7_Click()Dim i As IntegerIf List1.ListIndex > -1 ThenFor i = List1.ListIndex + 1 To UBound(Poetrys) - 1    '通过循环让i+1位置的内容覆盖i位置的内容,实现信息在数组中向前移Poetrys(i) = Poetrys(i + 1)NextReDim Preserve Poetrys(UBound(Poetrys) - 1)    '将数组最后一个元素删除fileWrite    ' 记录写入文件List1.RemoveItem List1.ListIndex    '将列表框所选择的内容移除Text2 = ""Text3 = ""End If
End SubPrivate Sub Form_Load()'Frame1显示，Frame2不可见Frame1.Visible = TrueFrame2.Visible = FalseMe.Width = 8400    '设置窗体的宽度ReDim Poetrys(0)    '程序刚加载时 古诗数组初始元素0个Current = 0fileRead    '导入信息If UBound(Poetrys) > 0 Then '如果导入文件有信息则处理以下内容Current = 1Timer1.Interval = 200Timer1.Enabled = TrueEnd If
End SubPrivate Sub List1_Click()    '将列表框对应的古诗信息显示在文本框2和3中Dim s(4) As StringDim s1 As StringDim c As StringDim i As IntegerDim j  As Integer'以下代码剔除无用字符For i = 0 To 4s(i) = ""For j = 1 To 50c = Mid(Poetrys(List1.ListIndex + 1).NeiRong(i), j, 1)If Asc(c) = 0 Then Exit Fors(i) = s(i) & cNexts(i) = Trim(s(i))Nexts1 = s(0) & vbCrLfs1 = s1 & s(1) & vbCrLfs1 = s1 & s(2) & vbCrLfs1 = s1 & s(3) & vbCrLfs1 = s1 & s(4)Text2 = s1    '显示古诗Text3 = Trim(Poetrys(List1.ListIndex + 1).TuPian)     '显示图片名称End SubPrivate Sub Timer1_Timer()Static n As IntegerDim i As IntegerDim s(5) As StringDim j As IntegerLabel1 = ""If n = 0 ThenPicture1.Picture = LoadPicture(App.Path & "\" & Trim(Poetrys(Current).TuPian))End IfFor i = 0 To n'以下代码剔除无用字符s(i) = ""For j = 1 To 50Dim c As Stringc = Mid(Poetrys(Current).NeiRong(i), j, 1)If Asc(c) = 0 Then Exit Fors(i) = s(i) & cNextLabel1 = Label1 & Trim(s(i)) & vbCrLfNextn = n + 1    '代表要显示几行If n = 5 Then    '如果5行显示完毕，则停止时钟，并且n从新置0Timer1.Enabled = FalseCommand1.Enabled = TrueCommand2.Enabled = TrueCommand3.Enabled = TrueCommand4.Enabled = Truen = 0End If
End SubPrivate Sub wh_Click()Frame2.Visible = TrueFrame1.Visible = FalseFrame2.Left = 140Frame2.Top = 300
End SubPrivate Sub xs_Click()Frame1.Visible = TrueFrame2.Visible = FalseFrame1.Left = 140Frame1.Top = 300
End SubPrivate Sub fileRead()    '功能将文件信息导入程序Dim i As IntegerDim Poetry As PoetryOpen App.Path & "\Poetrys.txt" For Random As #1 Len = Len(Poetry)    '打开随机文件方式操作Do While Not EOF(1)Get #1, , PoetryIf Asc(Trim(Poetry.NeiRong(0))) <> 0 ThenReDim Preserve Poetrys(UBound(Poetrys) + 1)Poetrys(UBound(Poetrys)) = PoetryList1.AddItem Poetrys(UBound(Poetrys)).NeiRong(0)End IfLoopClose #1
End SubPrivate Sub fileWrite()    '功能将信息写文件Dim i As IntegerIf Dir(App.Path & "\Poetrys.txt") <> "" Then Kill App.Path & "\Poetrys.txt"Open App.Path & "\Poetrys.txt" For Random As #1 Len = Len(Poetrys(0))    '打开随机文件方式操作For i = 1 To UBound(Poetrys)Put #1, , Poetrys(i)NextClose #1
End Sub