VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 4699|回复: 7

非常平滑的关于滚动字幕

[复制链接]
 楼主| 发表于 2007-12-18 17:10:43 | 显示全部楼层 |阅读模式
'frm

  1. Option Explicit

  2. Private Sub Form_Load()

  3.     Dim strTxtSource As String
  4.     Dim lngArrayUbound As Long

  5.     m_lngTxtTop = picShow.Height
  6.     lblCredits = App.ProductName & " - Credits"
  7.     lblCompany = App.CompanyName
  8.     lblDescription = App.FileDescription
  9.     lbVersion = "Version : " & App.Major & "." & App.Minor & "." & App.Revision

  10.     strTxtSource = LoadText(App.Path & "\Credits.txt")
  11.     m_astrTxtLine = Split(strTxtSource, vbCrLf)
  12.     lngArrayUbound = UBound(m_astrTxtLine)
  13.     ReDim Preserve m_astrTxtLine(lngArrayUbound)

  14. End Sub

  15. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  16.     lbClose.ForeColor = RGB(119, 60, 0)

  17. End Sub

  18. Private Sub lbClose_Click()

  19.     Unload Me

  20. End Sub

  21. Private Sub lbClose_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  22.     lbClose.ForeColor = RGB(255, 128, 10)

  23. End Sub

  24. Private Sub lblPause_Click()

  25.     tmrUpdate.Enabled = Not tmrUpdate.Enabled

  26.     If tmrUpdate.Enabled = False Then

  27.         lblPause.ForeColor = RGB(255, 128, 10)

  28.     Else

  29.         lblPause.ForeColor = RGB(119, 60, 0)

  30.     End If

  31. End Sub

  32. Private Sub PicShow_Click()

  33.     lblPause_Click

  34. End Sub

  35. Private Sub tmrUpdate_Timer()

  36.     Dim i As Long
  37.     Dim lngTxtTop As Long

  38.     picShow.Cls
  39.     lngTxtTop = m_lngTxtTop

  40.     For i = 0 To UBound(m_astrTxtLine)

  41.         If lngTxtTop > -50 And lngTxtTop < picShow.Height Then

  42.             SendCredits picShow, m_astrTxtLine(i), 33, lngTxtTop, vbBlack, RGB(205, 128, 0), vbBlack, 1 / 6

  43.         End If

  44.         lngTxtTop = lngTxtTop + picShow.TextHeight(m_astrTxtLine(i))

  45.     Next

  46.     '到达顶部
  47.     If m_lngTxtTop + 20 < -picShow.TextHeight("A") * UBound(m_astrTxtLine) Then

  48.         m_lngTxtTop = picShow.Height

  49.     End If

  50.     m_lngTxtTop = m_lngTxtTop - 1

  51. End Sub

  52. Private Sub Form_Unload(Cancel As Integer)

  53.     Dim intRet As Integer

  54.     Erase m_astrTxtLine

  55.     '是否复制作者网址
  56.     intRet = MsgBox("( PLEASE GIVE FEEDBACK ) to improve this code.Click 'Ok' to copy the site address  to your clipboard", vbInformation + vbOKCancel, "Please Give FeedBack")

  57.     If intRet = vbOK Then

  58.         Clipboard.SetText ("http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=58396&lngWId=1")

  59.     End If

  60. End Sub
复制代码


'mod

  1. Option Explicit

  2. Public m_lngTxtTop As Long          '存储Text Top值
  3. Public m_astrTxtLine() As String    '存放文本行

  4. 'DrawText将文本描绘到指定的矩形中
  5. '返回值
  6. 'Long,描绘文字的高度
  7. '参数表
  8. '参数 类型及说明
  9. 'hdc Long,欲在其中显示文字的一个设备场景的句柄
  10. 'lpStr String,欲描绘的文本字串
  11. 'nCount Long,欲描绘的字符数量。如果要描绘整个字串(直到空中止符),则可将这个参数设为-1
  12. 'lpRect RECT,指定用于绘图的一个格式化矩形(采用逻辑坐标)
  13. 'wFormat Long,一个标志位数组,决定了以何种形式执行绘图。
  14. Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, _
  15.                           ByVal lpStr As String, _
  16.                           ByVal nCount As Long, _
  17.                           lpRect As RECT, _
  18.                           ByVal wFormat As Long) _
  19.                           As Long

  20. Private Type RECT
  21.     Left As Long
  22.     Top As Long
  23.     Right As Long
  24.     Bottom As Long
  25. End Type

  26. Private Const DT_NOPREFIX = &H800 '通常,函数认为 & 字符表示应为下一个字符加上下划线。该标志禁止这种行为

  27. Public Function LoadText(FromFile As String) As String

  28.     Dim strTxt As String
  29.     Dim intFileNum As Integer

  30.     On Error GoTo Handle

  31.     If Dir(FromFile) = vbNullString Then

  32.         MsgBox "The file " & FromFile & " not found.  Check if the file is Currently exists.", vbCritical, "Sorry"
  33.         Exit Function

  34.     End If

  35.     intFileNum = FreeFile
  36.     Open FromFile For Input As #intFileNum
  37.     strTxt = StrConv(InputB(LOF(intFileNum), #intFileNum), vbUnicode)
  38.     Close #intFileNum
  39.     LoadText = strTxt
  40.     Exit Function

  41. Handle:

  42.     MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical, "Error"

  43. End Function

  44. Public Function GetShade(ByVal StartCol As Long, ByVal EndCol As Long, ByVal ColDepth As Double) As Long

  45.     Dim sRate As Double
  46.     Dim cBlue As Long, cGreen As Long, cRed As Long
  47.     Dim sBlue As Long, sGreen As Long, sRed As Long

  48.     sRate = ColDepth
  49.     GetRGB EndCol, sRed, sGreen, sBlue           '获取尾部颜色rgb值
  50.     GetRGB StartCol, cRed, cGreen, cBlue         '获取手部颜色rgb值
  51.     cRed = cRed + (sRed - cRed) * sRate
  52.     cGreen = cGreen + (sGreen - cGreen) * sRate  '计算新渐变颜色
  53.     cBlue = cBlue + (sBlue - cBlue) * sRate

  54.     GetShade = RGB(Abs(cRed), Abs(cGreen), Abs(cBlue))

  55. End Function

  56. Private Sub GetRGB(ByVal LngCol As Long, R As Long, G As Long, B As Long)

  57.     R = LngCol Mod 256
  58.     G = (LngCol And vbGreen) / 256
  59.     B = (LngCol And vbBlue) / 65536

  60. End Sub

  61. Public Function SendCredits(PicBox As PictureBox, Txt As String, _
  62.                             ByVal X As Integer, ByVal Y As Integer, _
  63.                             Optional StartCol As Long = 0, Optional MidCol As Long = &H1B207, _
  64.                             Optional EndCol As Long = 0, Optional ByVal cRegion As Double)

  65.     Dim hLength As Integer
  66.     Dim DrawCol As Long
  67.     Dim RC As RECT

  68.     hLength = PicBox.Height * cRegion   '等分PIC高度,这里是1/6

  69.     If Y <= hLength Then

  70.         '顶部文字淡入
  71.         DrawCol = GetShade(MidCol, EndCol, (hLength - Y) / (hLength + 20))      '获取渐变色

  72.     ElseIf Y <= PicBox.Height And Y >= PicBox.Height * (1 - cRegion) Then      '要大于其余5/6

  73.         '底部文字淡出
  74.         DrawCol = GetShade(StartCol, MidCol, (PicBox.Height - Y) / hLength)    '获取渐变色

  75.     Else

  76.         DrawCol = MidCol    '中部文字

  77.     End If

  78.     With RC
  79.         .Left = X
  80.         .Top = Y
  81.         .Right = PicBox.Width
  82.         .Bottom = PicBox.Height
  83.     End With

  84.     PicBox.ForeColor = DrawCol  '设置输出前景色
  85.     DrawText PicBox.hdc, Txt, -1, RC, DT_NOPREFIX

  86. End Function
复制代码


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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
 楼主| 发表于 2007-12-18 17:13:25 | 显示全部楼层
老外写的原注释基本看不明白,故remove,输出中文模板随意取的。
回复 支持 反对

使用道具 举报

发表于 2007-12-18 17:14:46 | 显示全部楼层
测试了一下,觉得还是有闪烁和跳跃感……
回复 支持 反对

使用道具 举报

发表于 2007-12-18 18:34:56 | 显示全部楼层
有没有办法使字幕镜像输出并滚动?
回复 支持 反对

使用道具 举报

发表于 2007-12-19 09:21:35 | 显示全部楼层
不错,比我自个儿写的好多了。
回复 支持 反对

使用道具 举报

发表于 2007-12-19 09:53:07 | 显示全部楼层
非常好,感谢分享:)
回复 支持 反对

使用道具 举报

发表于 2009-1-17 20:17:40 | 显示全部楼层
建议把 源程序压缩文件包  贴出来
我正需要这个

[ 本帖最后由 zl90659064 于 2009-1-17 20:19 编辑 ]
回复 支持 反对

使用道具 举报

发表于 2015-4-25 03:23:32 | 显示全部楼层
谢谢了
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-7-5 11:47

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表