桌面歌词系统的卡拉OK效果代码

　　千千静听播放器在桌面显示歌词时，模仿了卡拉OK效果，笔者在网上查阅了这方面的资料，发现代码比较复杂，看得头发晕，于是自己编写了一个简单的代码，测试的效果还不错，发上来供各位参考。
　　编程思路是：将歌词用红色打印到Form3窗体后，再逐点测试是否为红色，如果是，就用白色替换。
　　如果歌曲速度很快，有可能某些歌词会来不及显示，这时，你可以修改lrc文件，将2句合并成一句，增加歌词句的时间长度，或者将字号设置为小一点的。

　　新建一个工程，在Form1上添加1个按纽、2个计时器。
计时器1设置：Enabled=False，Interval=50
计时器2设置：Enabled=False，Interval=1000

　　再添加一个窗体，改名为Form3，字体设置："楷体_GB2312"、28号粗体，其它属性设置：
BackColor=0: BorderStyle=0: ScaleMode=3。

Form1的代码：
--------------

Option Explicit

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim ms As String * 16 '音乐时间值
Dim Lyric As String   '歌词
Dim cx As Long        '歌词显示左起点
Dim longest As Long   '音乐时长
Dim kk As Long
Dim t1 As Long

Private Sub Command1_Click()
Dim mp3Name As String, lrcName As String, z As String

mp3Name = "D:\100.mp3"  '全路径mp3文件名
lrcName = "D:\100.lrc"  '全路径lrc文件名

mciSendString "open " & mp3Name & " alias music", 0&, 0, 0
mciSendString "status music length", ms, Len(ms), 0
longest = Val(ms)
If longest > 0 Then '如果能提取到播放时间长度
  Open lrcName For Input As #1
  Do Until EOF(1)
    Line Input #1, z
    If Len(z) > 0 Then Lyric = Lyric & z & vbCrLf
  Loop
  Close #1
  Lyric = arrangeLRC(Lyric):  kk = 1: Form3.Show
  Timer1.Enabled = True: Timer2.Enabled = True
  mciSendString "play music", 0&, 0, 0
Else
  mciSendString "Close music", 0&, 0, 0
End If
End Sub

Private Sub Timer1_Timer()
Dim t1 As Long, t2 As Long, k2 As Long, i As Long, j As Long, z As String
Dim dot As Long   '当前歌词一行的像素点数

mciSendString "status music position", ms, Len(ms), 0
t = Val(ms)

If t1=0 Then
  k2 = InStr(kk, Lyric, "[")       '查找时间字串
  If k2 = 0 Then Exit Sub
  t1 = Val(Mid$(Lyric, k2 + 1, 2)) * 60000 + Val(Mid$(Lyric, k2 + 4, 5)) * 1000
End If

If Abs(t1 - t) < 300 Then        '如果歌词与播放进度的时间差<300毫秒
  k2 = InStr(kk, Lyric, "]") + 1 '查找歌词文本起点
  kk = InStr(k2, Lyric, vbCrLf)  '查找歌词文本终点
  z = Mid$(Lyric, k2, kk - k2)
  kk = kk + 2
  k2 = InStr(kk, Lyric, "[")     '查找下一句时间字串
  If k2 > 0 Then t2 = Val(Mid$(Lyric, k2 + 1, 2)) * 60000 + Val(Mid$(Lyric, k2 + 4, 5)) * 1000
  If t2 = 0 Then t2 = longest
  With Form3
    .Cls
    .ForeColor = vbRed
    dot = .TextWidth(z)
    cx = (Screen.Width \ 15 - dot) \ 2
    .CurrentX = cx: .CurrentY = 0
    Form3.Print z
    t = (t2 - t1) / (dot + 100) '100是附加的宽度
    t1 = t2
    For i = cx To cx + dot
      For j = 0 To .TextHeight(z) - 1
        If .Point(i, j) = vbRed Then Form3.PSet (i, j), vbWhite
      Next
      Sleep t
      DoEvents
    Next
  End With
ElseIf t1 < t Then
  If k2 > 0 Then kk = InStr(k2, Lyric, vbCrLf) + 2
End If
End Sub

Private Sub Timer2_Timer()
mciSendString "status music mode", ms, Len(ms), 0
If Left$(ms, 7) = "stopped" Then
  mciSendString "Close music", 0&, 0, 0
  Timer1.Enabled = False: Timer2.Enabled = False
  Unload Form3
End If
End Sub

Private Function arrangeLRC(DAT As String) As String
Dim test As String, time As String
Dim i As Long, j As Long, k As Long, L As Integer, n As Integer
Dim tem1() As String, tem2() As String
Dim x As Integer 'tem2下标记数

i = 0
Do
  i = InStr(i + 1, DAT, "["): If i = 0 Then Exit Function
Loop Until IsNumeric(Mid(DAT, i + 1, 2)) '如果是时间字串就跳出
If i > 1 Then DAT = Mid(DAT, i): i = 1

Do
  k = InStr(i, DAT, vbCrLf)          '查找回车换行符
  If k = 0 Then Exit Do
  time = Mid(DAT, i, k - i)          '取出一行
  j = InStrRev(time, "]")            '从time后面查找"]"位置
  test = Mid(time, j + 1, k - j - 1) '取出time后面的歌词
  time = Mid(Left(time, j), 2)
  tem1 = Split(time, "[")
  n = UBound(tem1)                   '测试tem1中有几个时间参数
  ReDim Preserve tem2(x + n)
  For L = 0 To n: tem2(x) = tem1(L) & test: x = x + 1: Next
  i = k + 2
Loop Until i > Len(DAT) - 10

x = UBound(tem2)
For i = 0 To x - 1    '排序
  For j = i + 1 To x
    If StrComp(tem2(j), tem2(i)) < 0 Then time = tem2(j): tem2(j) = tem2(i): tem2(i) = time
  Next

Next

For i = 0 To x: tem2(i) = "[" & tem2(i): Next
arrangeLRC = Join(tem2, vbCrLf) & vbCrLf '连接
End Function



Form3的代码：
---------------

Option Explicit

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Sub Form_Load()
SetWindowLong hWnd, -20, &H80000
SetLayeredWindowAttributes hWnd, Me.BackColor, 0, 1 '将窗体背景设为透明
SetWindowPos hWnd, -1, 0, Screen.Height \ 15 - 70, Screen.Width \ 15, TextHeight("拿"), &H40
End Sub


2011.8.16