非常平滑的关于滚动字幕

weiyi75

'frm

1. Option Explicit
   
2. 
   
3. Private Sub Form_Load()
   
4. 
   
5.     Dim strTxtSource As String
   
6.     Dim lngArrayUbound As Long
   
7. 
   
8.     m_lngTxtTop = picShow.Height
   
9.     lblCredits = App.ProductName & " - Credits"
   
10.     lblCompany = App.CompanyName
    
11.     lblDescription = App.FileDescription
    
12.     lbVersion = "Version : " & App.Major & "." & App.Minor & "." & App.Revision
    
13. 
    
14.     strTxtSource = LoadText(App.Path & "\Credits.txt")
    
15.     m_astrTxtLine = Split(strTxtSource, vbCrLf)
    
16.     lngArrayUbound = UBound(m_astrTxtLine)
    
17.     ReDim Preserve m_astrTxtLine(lngArrayUbound)
    
18. 
    
19. End Sub
    
20. 
    
21. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
22. 
    
23.     lbClose.ForeColor = RGB(119, 60, 0)
    
24. 
    
25. End Sub
    
26. 
    
27. Private Sub lbClose_Click()
    
28. 
    
29.     Unload Me
    
30. 
    
31. End Sub
    
32. 
    
33. Private Sub lbClose_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
34. 
    
35.     lbClose.ForeColor = RGB(255, 128, 10)
    
36. 
    
37. End Sub
    
38. 
    
39. Private Sub lblPause_Click()
    
40. 
    
41.     tmrUpdate.Enabled = Not tmrUpdate.Enabled
    
42. 
    
43.     If tmrUpdate.Enabled = False Then
    
44. 
    
45.         lblPause.ForeColor = RGB(255, 128, 10)
    
46. 
    
47.     Else
    
48. 
    
49.         lblPause.ForeColor = RGB(119, 60, 0)
    
50. 
    
51.     End If
    
52. 
    
53. End Sub
    
54. 
    
55. Private Sub PicShow_Click()
    
56. 
    
57.     lblPause_Click
    
58. 
    
59. End Sub
    
60. 
    
61. Private Sub tmrUpdate_Timer()
    
62. 
    
63.     Dim i As Long
    
64.     Dim lngTxtTop As Long
    
65. 
    
66.     picShow.Cls
    
67.     lngTxtTop = m_lngTxtTop
    
68. 
    
69.     For i = 0 To UBound(m_astrTxtLine)
    
70. 
    
71.         If lngTxtTop > -50 And lngTxtTop < picShow.Height Then
    
72. 
    
73.             SendCredits picShow, m_astrTxtLine(i), 33, lngTxtTop, vbBlack, RGB(205, 128, 0), vbBlack, 1 / 6
    
74. 
    
75.         End If
    
76. 
    
77.         lngTxtTop = lngTxtTop + picShow.TextHeight(m_astrTxtLine(i))
    
78. 
    
79.     Next
    
80. 
    
81.     '到达顶部
    
82.     If m_lngTxtTop + 20 < -picShow.TextHeight("A") * UBound(m_astrTxtLine) Then
    
83. 
    
84.         m_lngTxtTop = picShow.Height
    
85. 
    
86.     End If
    
87. 
    
88.     m_lngTxtTop = m_lngTxtTop - 1
    
89. 
    
90. End Sub
    
91. 
    
92. Private Sub Form_Unload(Cancel As Integer)
    
93. 
    
94.     Dim intRet As Integer
    
95. 
    
96.     Erase m_astrTxtLine
    
97. 
    
98.     '是否复制作者网址
    
99.     intRet = MsgBox("( PLEASE GIVE FEEDBACK ) to improve this code.Click 'Ok' to copy the site address  to your clipboard", vbInformation + vbOKCancel, "Please Give FeedBack")
    
100. 
     
101.     If intRet = vbOK Then
     
102. 
     
103.         Clipboard.SetText ("http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=58396&lngWId=1")
     
104. 
     
105.     End If
     
106. 
     
107. End Sub

复制代码

'mod

1. Option Explicit
   
2. 
   
3. Public m_lngTxtTop As Long          '存储Text Top值
   
4. Public m_astrTxtLine() As String    '存放文本行
   
5. 
   
6. 'DrawText将文本描绘到指定的矩形中
   
7. '返回值
   
8. 'Long，描绘文字的高度
   
9. '参数表
   
10. '参数 类型及说明
    
11. 'hdc Long，欲在其中显示文字的一个设备场景的句柄
    
12. 'lpStr String，欲描绘的文本字串
    
13. 'nCount Long，欲描绘的字符数量。如果要描绘整个字串（直到空中止符），则可将这个参数设为-1
    
14. 'lpRect RECT，指定用于绘图的一个格式化矩形（采用逻辑坐标）
    
15. 'wFormat Long，一个标志位数组，决定了以何种形式执行绘图。
    
16. Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, _
    
17.                           ByVal lpStr As String, _
    
18.                           ByVal nCount As Long, _
    
19.                           lpRect As RECT, _
    
20.                           ByVal wFormat As Long) _
    
21.                           As Long
    
22. 
    
23. Private Type RECT
    
24.     Left As Long
    
25.     Top As Long
    
26.     Right As Long
    
27.     Bottom As Long
    
28. End Type
    
29. 
    
30. Private Const DT_NOPREFIX = &H800 '通常，函数认为 & 字符表示应为下一个字符加上下划线。该标志禁止这种行为
    
31. 
    
32. Public Function LoadText(FromFile As String) As String
    
33. 
    
34.     Dim strTxt As String
    
35.     Dim intFileNum As Integer
    
36. 
    
37.     On Error GoTo Handle
    
38. 
    
39.     If Dir(FromFile) = vbNullString Then
    
40. 
    
41.         MsgBox "The file " & FromFile & " not found.  Check if the file is Currently exists.", vbCritical, "Sorry"
    
42.         Exit Function
    
43. 
    
44.     End If
    
45. 
    
46.     intFileNum = FreeFile
    
47.     Open FromFile For Input As #intFileNum
    
48.     strTxt = StrConv(InputB(LOF(intFileNum), #intFileNum), vbUnicode)
    
49.     Close #intFileNum
    
50.     LoadText = strTxt
    
51.     Exit Function
    
52. 
    
53. Handle:
    
54. 
    
55.     MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical, "Error"
    
56. 
    
57. End Function
    
58. 
    
59. Public Function GetShade(ByVal StartCol As Long, ByVal EndCol As Long, ByVal ColDepth As Double) As Long
    
60. 
    
61.     Dim sRate As Double
    
62.     Dim cBlue As Long, cGreen As Long, cRed As Long
    
63.     Dim sBlue As Long, sGreen As Long, sRed As Long
    
64. 
    
65.     sRate = ColDepth
    
66.     GetRGB EndCol, sRed, sGreen, sBlue           '获取尾部颜色rgb值
    
67.     GetRGB StartCol, cRed, cGreen, cBlue         '获取手部颜色rgb值
    
68.     cRed = cRed + (sRed - cRed) * sRate
    
69.     cGreen = cGreen + (sGreen - cGreen) * sRate  '计算新渐变颜色
    
70.     cBlue = cBlue + (sBlue - cBlue) * sRate
    
71. 
    
72.     GetShade = RGB(Abs(cRed), Abs(cGreen), Abs(cBlue))
    
73. 
    
74. End Function
    
75. 
    
76. Private Sub GetRGB(ByVal LngCol As Long, R As Long, G As Long, B As Long)
    
77. 
    
78.     R = LngCol Mod 256
    
79.     G = (LngCol And vbGreen) / 256
    
80.     B = (LngCol And vbBlue) / 65536
    
81. 
    
82. End Sub
    
83. 
    
84. Public Function SendCredits(PicBox As PictureBox, Txt As String, _
    
85.                             ByVal X As Integer, ByVal Y As Integer, _
    
86.                             Optional StartCol As Long = 0, Optional MidCol As Long = &H1B207, _
    
87.                             Optional EndCol As Long = 0, Optional ByVal cRegion As Double)
    
88. 
    
89.     Dim hLength As Integer
    
90.     Dim DrawCol As Long
    
91.     Dim RC As RECT
    
92. 
    
93.     hLength = PicBox.Height * cRegion   '等分PIC高度，这里是1/6
    
94. 
    
95.     If Y <= hLength Then
    
96. 
    
97.         '顶部文字淡入
    
98.         DrawCol = GetShade(MidCol, EndCol, (hLength - Y) / (hLength + 20))      '获取渐变色
    
99. 
    
100.     ElseIf Y <= PicBox.Height And Y >= PicBox.Height * (1 - cRegion) Then      '要大于其余5/6
     
101. 
     
102.         '底部文字淡出
     
103.         DrawCol = GetShade(StartCol, MidCol, (PicBox.Height - Y) / hLength)    '获取渐变色
     
104. 
     
105.     Else
     
106. 
     
107.         DrawCol = MidCol    '中部文字
     
108. 
     
109.     End If
     
110. 
     
111.     With RC
     
112.         .Left = X
     
113.         .Top = Y
     
114.         .Right = PicBox.Width
     
115.         .Bottom = PicBox.Height
     
116.     End With
     
117. 
     
118.     PicBox.ForeColor = DrawCol  '设置输出前景色
     
119.     DrawText PicBox.hdc, Txt, -1, RC, DT_NOPREFIX
     
120. 
     
121. End Function

复制代码

评论，颜色幻数令我眼花，CPU占用稍微高些，N多代调试程序选这个软柿子吃了。

weiyi75

老外写的原注释基本看不明白，故remove,输出中文模板随意取的。

henserlu

测试了一下，觉得还是有闪烁和跳跃感……

VB爬虫

有没有办法使字幕镜像输出并滚动？

yangzn

不错，比我自个儿写的好多了。

tl319

非常好,感谢分享:)

zl90659064

建议把 源程序压缩文件包  贴出来
我正需要这个

[ 本帖最后由 zl90659064 于 2009-1-17 20:19 编辑 ]

yhj196697

谢谢了