Question

VB设计滚动字幕板，要求控制面板可以改变颜色，具体情况见补充

求程序源代码





Answer 1

首先要说的是，分太少了。。。。。

花了俺两个小时才写完测试好。

首先，新建一个工程

添加两个Form,分别为Form1和Form2

Form1中添加一个Frame1

Frame1中添加控件数组 Option1(0)和Option1(1) '分别是大字体和小字体

 

Form1中添加一个Frame2

Frame2中添加控件数组 Check1(0),Check1(1),Check1(2)和Check1(3)  '分别是 宋体，仿宋，楷书和黑体

Check1(0)-Check1(3)的Style属性全部选择为 1 - Graphical

 

From1中

添加一个Label1

添加一个控件数组Combo1(0)         '设置背景色

添加一个Label2

添加一个控件数组Combo1(1)         '设置前景色

添加一个Label3

添加一个Slider1  TickStyle属性设置为3 - sldNoTick

添加一个Text1  '用来显示和输入，保存字幕内容

添加一个Frame3

Frame3中添加控件数组 Check2(0-7)，分别对应可设置和修改的 1-8条预设字幕。

添加一个Frame4

Frame4中添加控件数组Option2(0-3)，分别对应“从左到右”，“从右到左”，“穿透式摆动”，“壁面反射”

添加一个Command1    '恢复设置

添加一个Command2   '开始 和 停止

添加一个Command3    '退出程序

添加一个Timer1           '用来控制字幕移动

**********以上为Form1中的控**********************************

Form2中添加一个Label1,放在窗体左上角，属性AutoSize 设置为True

 

控件添加完毕，下面是代码：

'**********Form1中的代码

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFilename As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFilename As String) As Long

Dim EnableCheck As Boolean
Dim tLeft As Boolean
Dim SetNum As Integer

Private Function INIRead(iAppName As String, iKeyName As String, iFileName As String) As String
Dim iStr$, aaa$
iStr = String(1000, Chr(0))
aaa = Left(iStr, GetPrivateProfileString(iAppName, ByVal iKeyName, "", iStr, Len(iStr), iFileName))
INIRead = IIf(InStr(aaa, Chr(0)) > 0, Replace(aaa, Chr(0), ""), aaa)
End Function

Private Sub Check1_Click(Index As Integer)
If EnableCheck = False Then
ClickCheck1 Index
End If

End Sub

Sub ClickCheck1(Index As Integer)
EnableCheck = True

For i = 0 To 3
If i = Index Then
Check1(i).Value = 1
Else
If Check1(i).Value = 1 Then Check1(i).Value = 0
End If
Next

Select Case Index
       Case 0
       Form2.Label1.Font = "宋体"
       Case 1
       Form2.Label1.Font = "仿宋_GB2312"    '由于本机没有隶书，所以改为了仿宋字体。
       Case 2
       Form2.Label1.Font = "楷体_GB2312"
       Case 3
       Form2.Label1.Font = "黑体"
End Select
EnableCheck = False

End Sub

 

Private Sub Check2_Click(Index As Integer)
If EnableCheck = False Then
ClickCheck2 Index
End If
End Sub

Sub ClickCheck2(Index As Integer)
EnableCheck = True

For i = 0 To 7
If i = Index Then
Check2(i).Value = 1
Else
If Check2(i).Value = 1 Then Check2(i).Value = 0
End If
Next
Text1.Text = INIRead("字幕", "字幕" & Index, App.Path & "\Config.ini")    '读取Config.ini文件，得到相对应的字幕内容。
If Text1.Text = "" Then
Timer1.Interval = 0
Command2.Caption = "开 始"
Form2.Hide
Else
If Option2(0).Value = True Or Option2(1).Value = True Then
Form2.Label1.Caption = Text1.Text & "     "
Else
Form2.Label1.Caption = Text1.Text
End If
End If
EnableCheck = False
End Sub

Private Sub Check3_Click()

End Sub

Private Sub Check4_Click()
If Check4.Value = 1 Then
Form2.WindowState = 2
Else
Form2.WindowState = 0
End If
End Sub

Private Sub Combo1_Click(Index As Integer)
Dim SetColor As Long
If Combo1(0).Text = Combo1(1).Text Then
Select Case Combo1(Index).Text
       Case "红色"
       Combo1((Index + 1) Mod 2).Text = "黑色"
       Case "黄色"
       Combo1((Index + 1) Mod 2).Text = "青色"
       Case "蓝色"
       Combo1((Index + 1) Mod 2).Text = "绿色"
       Case "绿色"
       Combo1((Index + 1) Mod 2).Text = "紫色"
       Case "紫色"
       Combo1((Index + 1) Mod 2).Text = "黄色"
       Case "青色"
       Combo1((Index + 1) Mod 2).Text = "黄色"
       Case "黑色"
       Combo1((Index + 1) Mod 2).Text = "红色"
       Case "白色"
       Combo1((Index + 1) Mod 2).Text = "蓝色"
End Select
End If
For i = 0 To 1
Select Case Combo1(i).Text
       Case "红色"
       SetColor = &HFF&
       Case "黄色"
       SetColor = &HFFFF&
       Case "蓝色"
       SetColor = &HFF0000
       Case "绿色"
       SetColor = &HFF00&
       Case "紫色"
       SetColor = &HFF00FF
       Case "青色"
       SetColor = &H8000&
       Case "黑色"
       SetColor = &H0&
       Case "白色"
       SetColor = &HFFFFFF
End Select
If i = 0 Then
Form2.BackColor = SetColor
Form2.Label1.BackColor = SetColor
Else
Form2.Label1.ForeColor = SetColor
End If
Next

      

End Sub

Private Sub Command1_Click()
'将所有设置全部初始化，但字幕内容未改变。(由于没有预设字幕)
Option1(0).Value = True
Form2.Label1.FontSize = Form2.ScaleHeight \ 24
Check1(0).Value = 0
Combo1(0).Text = "青色"
Combo1(1).Text = "黄色"
Slider1.Value = 5
Timer1.Interval = 1000 - (1000 - 50) * Slider1.Value \ 10
SetNum = Int((1000 / Timer1.Interval) * 3)
Option2(0).Value = True
Form2.Label1.Caption = Text1.Text & "     "
Check3.Value = 0
Check4.Value = 0
Form2.WindowState = 0
End Sub

Private Sub Command2_Click()
If Command2.Caption = "开 始" Then
If Text1.Text <> "" Then
If Option2(0).Value = True Or Option2(1).Value = True Then
Form2.Label1.Caption = Text1.Text & "     "
Else
Form2.Label1.Caption = Text1.Text
End If
Command2.Caption = "停 止"
Timer1.Interval = 1000 - (1000 - 50) * Slider1.Value \ 10
SetNum = Int((1000 / Timer1.Interval) * 3)
Form2.Show
Me.Hide
End If
Else
Command2.Caption = "开 始"
Timer1.Interval = 0
Form2.Hide
End If
End Sub

Private Sub Command3_Click()
End
End Sub

Private Sub Form_Load()
'*********给各控件赋值***********************
Form1.Caption = "滚动字幕控制台"
Form2.Caption = "滚动字幕板"

Frame1.Caption = "滚动字幕文字大小"
Option1(0).Caption = "大字体"
Option1(1).Caption = "小字体"
Option1(0).Value = True
Form2.Label1.FontSize = Form2.ScaleHeight \ 24

Frame2.Caption = "滚动字幕字体控制"
Check1(0).Caption = "宋体"
Check1(1).Caption = "仿宋"   '本机器上没有隶书体
Check1(2).Caption = "楷体"
Check1(3).Caption = "黑体"
Check1(0).Value = 1
Form2.Label1.Font = "宋体"

Label1.Caption = "背景色："
Label2.Caption = "前景色："
For i = 0 To 1
Combo1(i).AddItem "白色"
Combo1(i).AddItem "红色"
Combo1(i).AddItem "黄色"
Combo1(i).AddItem "蓝色"
Combo1(i).AddItem "绿色"
Combo1(i).AddItem "紫色"
Combo1(i).AddItem "青色"
Combo1(i).AddItem "黑色"

Next
Combo1(0).Text = "青色"
Combo1(1).Text = "黄色"

Label3.Caption = "滚动速度："
Slider1.Value = 5

Text1.Text = "请直接在此输入字幕文字"

Frame3.Caption = "选择字幕"
For i = 0 To 7
Check2(i).Caption = CStr(i + 1)
Next

Frame4.Caption = "屏幕滚动方向控制"
Option2(0).Caption = "从左到右"
Option2(1).Caption = "从右到左"
Option2(2).Caption = "穿透式摆动"
Option2(3).Caption = "壁面反射"
Option2(0).Value = True

Check3.Caption = "颜色自动变化"
Check4.Caption = "全屏幕显示"

Command1.Caption = "恢复设置"
Command2.Caption = "开 始"
Command3.Caption = "退 出"
Timer1.Interval = 0
'*********给各控件赋值***********************

tLeft = False   '初始化 tLeft ,使穿透式摆动和壁面反射时，先向右移动

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
Me.Hide
Form2.Show
End Sub

Private Sub Option1_Click(Index As Integer)
Form2.Label1.Left = 0
If Index = 0 Then
Form2.Label1.FontSize = Form2.ScaleHeight \ 24
Else
Form2.Label1.FontSize = Form2.ScaleHeight \ 50
End If
End Sub

 

Private Sub Option2_Click(Index As Integer)
If Index = 3 Or Index = 2 Then
Form2.Label1.Caption = Text1.Text
Else
Form2.Label1.Caption = Text1.Text & "      "
End If
End Sub

Private Sub Slider1_Click()
Timer1.Interval = 1000 - (1000 - 50) * Slider1.Value \ 10
SetNum = Int((1000 / Timer1.Interval) * 3)
End Sub

Private Sub Text1_LostFocus()
For i = 0 To 7
If Check2(i).Value = 1 Then
WritePrivateProfileString "字幕", "字幕" & CStr(i), Text1.Text, App.Path & "\Config.ini"    '当TextBox1中输入完成，鼠标点击其它控件，TextBox1失去焦点时，将Text1.Text保存到Config.ini文件中相对应所选择的Check2(i)的项中。
End If
Next
End Sub

Private Sub Timer1_Timer()
If Option2(0).Value = True Then
Form2.Label1.Caption = Right(Form2.Label1.Caption, 1) & Mid(Form2.Label1.Caption, 1, Len(Form2.Label1.Caption) - 1)
ElseIf Option2(1).Value = True Then
Form2.Label1.Caption = Mid(Form2.Label1.Caption, 2) & Mid(Form2.Label1.Caption, 1, 1)
ElseIf Option2(2).Value = True Then
If tLeft = False Then
If Form2.Label1.Left >= Form2.ScaleWidth Then tLeft = True: Form2.Label1.Left = Form2.Label1.Left - 200 Else Form2.Label1.Left = Form2.Label1.Left + 200
Else
If Form2.Label1.Left + Form2.Label1.Width <= 0 Then tLeft = False: Form2.Label1.Left = Form2.Label1.Left + 200 Else Form2.Label1.Left = Form2.Label1.Left - 200
End If
ElseIf Option2(3).Value = True Then
If tLeft = False Then
If Form2.Label1.Left + Form2.Label1.Width <= Form2.ScaleWidth Then Form2.Label1.Left = Form2.Label1.Left + 200 Else tLeft = True: Form2.Label1.Left = Form2.Label1.Left - 200
Else
If Form2.Label1.Left >= 0 Then Form2.Label1.Left = Form2.Label1.Left - 200 Else tLeft = False: Form2.Label1.Left = Form2.Label1.Left + 200
End If
End If
If Check3.Value = 1 Then
If SetNum > 0 Then
SetNum = SetNum - 1
Else
SetNum = Int((1000 / Timer1.Interval) * 3)
Select Case Form2.Label1.ForeColor
       Case &HFFFFFF
       SetColor = &HFF&
       Case &H0&
       SetColor = &HFFFF&
       Case &H8000&
       SetColor = &HFFFFFF
       Case &HFF00FF
       SetColor = &H8000&
       Case &HFF00&
       SetColor = &HFF00FF
       Case &HFF0000
       SetColor = &H8000&
       Case &HFFFF&
       SetColor = &HFF00&
       Case &HFF&
       SetColor = &H0&
End Select
Form2.BackColor = Form2.Label1.ForeColor
Form2.Label1.BackColor = Form2.Label1.ForeColor
Form2.Label1.ForeColor = SetColor
End If
End If

End Sub

 

 

'****************Form2中的代码******************

Private Sub Form_DblClick()
Form1.Show
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
Me.Hide
Form1.Show
Form1.Command2.Caption = "开 始"
Form1.Timer1.Interval = 0
Form2.Hide
End Sub

Private Sub Form_Resize()

If Form1.Option1(0).Value = True Then
Label1.FontSize = Form2.ScaleHeight \ 24
Else
Label1.FontSize = Form2.ScaleHeight \ 50
End If
End Sub

 

Private Sub Label1_DblClick()
Form1.Show
End Sub

 

'**************************就是以上部分了，运行即可************************