txt2lrc.frm

文本文件自动转换为歌词文件Lrc

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   8925
   ClientLeft      =   60
   ClientTop       =   390
   ClientWidth     =   10995
   LinkTopic       =   "Form1"
   ScaleHeight     =   8925
   ScaleWidth      =   10995
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   615
      Left            =   840
      TabIndex        =   9
      Top             =   4920
      Width           =   1335
   End
   Begin VB.CommandButton cmdMain 
      Caption         =   "打开文件&转换"
      Height          =   855
      Left            =   600
      TabIndex        =   8
      Top             =   1560
      Width           =   1095
   End
   Begin VB.Frame Frame1 
      Caption         =   "输入时间："
      Height          =   975
      Left            =   360
      TabIndex        =   3
      Top             =   240
      Width           =   8895
      Begin VB.TextBox Text5 
         Height          =   495
         Left            =   6000
         TabIndex        =   11
         Text            =   "1"
         Top             =   240
         Width           =   1815
      End
      Begin VB.TextBox Text4 
         Height          =   495
         Left            =   3480
         TabIndex        =   7
         Text            =   "0"
         Top             =   360
         Width           =   975
      End
      Begin VB.TextBox Text3 
         Height          =   495
         Left            =   1200
         TabIndex        =   5
         Text            =   "0"
         Top             =   360
         Width           =   855
      End
      Begin VB.Label Label2 
         Caption         =   "字数："
         Height          =   495
         Left            =   5160
         TabIndex        =   10
         Top             =   240
         Width           =   1215
      End
      Begin VB.Label Label1 
         Caption         =   "秒："
         Height          =   375
         Left            =   3000
         TabIndex        =   6
         Top             =   360
         Width           =   495
      End
      Begin VB.Label Label3 
         Caption         =   "分钟："
         Height          =   375
         Left            =   240
         TabIndex        =   4
         Top             =   360
         Width           =   975
      End
   End
   Begin VB.TextBox Text2 
      Height          =   855
      Left            =   4560
      TabIndex        =   2
      Text            =   "Text2"
      Top             =   7320
      Width           =   2415
   End
   Begin VB.TextBox Text1 
      Height          =   4815
      Left            =   3000
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   1
      Text            =   "Txt2Lrc.frx":0000
      Top             =   1680
      Width           =   7095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   735
      Left            =   600
      TabIndex        =   0
      Top             =   3000
      Width           =   1215
   End
   Begin MSComDlg.CommonDialog CDLg1 
      Left            =   7920
      Top             =   5520
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdMain_Click()
    Dim fName As String
    Dim OutfName As String
    Dim ts As Integer
    Dim wTnum As Integer, wLnum As Integer
    Dim pt As Single
    Dim LTxt As String, TimeF As String
    Dim p1 As Integer
    
On Error Resume Next
    
    CDLg1.DialogTitle = "打开TXT文件"
    CDLg1.Filter = "文本文件|*.txt"
    CDLg1.FileName = ""
    CDLg1.ShowOpen

    If CDLg1.FileName <> "" Then
        If Err <> 32755 Then
            fName = CDLg1.FileName
        End If
    End If
    If fName = "" Then
        MsgBox " Please Open Txt file at first!", vbCritical, "Sorry!"
        Exit Sub
    End If
    

    ts = CInt(Text3.Text) * 60 + CInt(Text4.Text)     '总时间,最后10秒左右是结尾，先扣除
    wTnum = CInt(Text5.Text)                              '总单词数
    pt = ts / wTnum                                       '每个单词用时长度（秒）
    
    OutfName = Left(fName, Len(fName) - 3) & "lrc"

    Open fName For Input As #1
        TimeInc = 0
    Open OutfName For Output As #2
        p = InStr(1, OutfName, "/")
        
        Do While Not EOF(1)
            Line Input #1, LTxt
            If Len(LTxt) > 2 Then
                wLnum = LineWordNum(LTxt)
                
                If wLnum > 20 Then         '对于大于20个单词的行进行分行，以20字为1行
                    n = Fix(wLnum / 20)
                    p1 = 1
                    For i = 1 To n
                        t = CInt(pt * 20)
                        TimeInc = TimeInc + t
                        TimeF = ToTimeFormat(TimeInc)
                        endp = WordPos(LTxt, p1, 20)
                        txt20 = Mid(LTxt, p1, endp)
                        txt20 = TimeF & txt20
                        txt20 = txt20 + Chr(13) + Chr(10)
                        Print #2, txt20
                        p1 = p1 + endp
                    Next i
                    n1 = wLnum - n * 20
                    If n1 > 0 Then
                        t = CInt(pt * n1)
                        TimeInc = TimeInc + t
                        TimeF = ToTimeFormat(TimeInc)
                        txt20 = Right(LTxt, Len(Trim(LTxt)) - p1 + 1)
                        txt20 = TimeF & txt20
                        txt20 = txt20 + Chr(13) + Chr(10)
                        Print #2, txt20
                    End If
                Else
                    t = CInt(pt * wLnum)
                    TimeInc = TimeInc + t
                    TimeF = ToTimeFormat(TimeInc)
                    LTxt = TimeF & LTxt
                    LTxt = LTxt + Chr(13) + Chr(10)
                    Print #2, LTxt
                
                End If
           
            End If
        Loop
            
Close #1

Close #2



End Sub

Private Sub Command1_Click()
    
    ts = Text1.Text
 
    Text2.Text = CStr(c)

''Str1 = TimeSerial(0, 0, Text1.Text)
''Text2.Text = "[" & Str1 & ".00]"

End Sub

Private Sub Command2_Click()
x = Trim(Text1)
n = Len(x)
Text2.Text = n
End Sub

Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
End Sub
 
Function ToTimeFormat(t) As String
    a1 = Fix(t / 60)
    a2 = t - a1 * 60
    
    If a1 <= 9 Then
        minp = "0" & a1
    Else
        minp = a1
    End If
        
    If a2 <= 9 Then
        secp = "0" & a2
    Else
        secp = a2
    End If
     
   ToTimeFormat = "[" & minp & ":" & secp & ".00]"

End Function


Function LineWordNum(w As String) As Integer
    Dim nw As Integer
    nw = 0
    
    w = Trim(w)
    For K = 1 To Len(w) - 1
        c = Mid(w, K, 1)
        If c = " " Then
            nw = nw + 1
        End If
    Next K
    
    LineWordNum = nw + 1
     
End Function

Function WordPos(w As String, startP As Integer, n As Integer) As Integer
    Dim nw As Integer
    nw = 0
    
    w = Trim(w)
    For K = startP To Len(w) - 1
        If n > 0 Then
            c = Mid(w, K, 1)
            If c = " " Then
                nw = nw + 1
                n = n - 1
            End If
        Else
            Exit For
        End If
    Next K
    
    WordPos = K - startP
     
End Function