提高.txt

vb编写的电子琴

Dim ds As String
Dim tonen As Single
Dim tonet As Single
Dim mcode As String
Dim mintime As Single
Dim notetime As Single
Dim yinhl As Integer
Dim num As Integer
Dim shelp As String

Dim pitch As String
Dim mcnum As String
Dim lists As String


Private Sub Form_Load()
         

    ds = "CcDdEFfGgAaB"

    mcode = "CDE#MJU&?:P)zZxXcvVbBnNmaAsSdfFgGhHjqQwWerRtTyYu1!2@34$5%6^78*9(0\"

    Opttone(0).Value = True

    Optmintone(0).Value = True

    Optyinhl(2).Value = True

    lists = ","

    shelp = "简谱 1 2 3 4 5 6 7 休止符 0" & Chr(13) & _
            "更低音 a 中音 s 高音 d 高音 z" & Chr(13) & _
            "更高音 x 最高音 c 分隔符 ," & Chr(13) & _
            "  1  2  3  4  5  6  7  0"
    Labelhelp.Caption = shelp
End Sub

Private Sub Cmdenter_Click()
    Call judge
    Textmusic.SetFocus
End Sub

Private Sub CmdSave_Click()
    Call savefile
    Textmusic.SetFocus
End Sub

Private Sub CmdOpen_Click()
    Call openfile
    Textmusic.SetFocus
End Sub

Private Sub Cmdclear_Click()
    Textbackshow.Text = ""
End Sub

Private Sub Frametime_DragDrop(Source As Control, X As Single, Y As Single)

End Sub


Private Sub Labelhelp_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If Button = 2 Then
      RS232Organ.Show
      musicedit.Hide
   End If
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If Button = 2 Then
      RS232Organ.Show
      musicedit.Hide
   End If
End Sub


                 
             



Private Sub CmdExit_Click()
    Form1.Show
    Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
   
    Unload Me
End Sub

Private Sub HScrolltone_Change()
    Labeltone.Caption = Diao(HScrolltone.Value)
    Textmusic.SetFocus
End Sub

Private Function Diao(i As Integer) As String
    Select Case i
           Case 0
                Diao = "C"
           Case 1
                Diao = "C#"
           Case 2
                Diao = "D"
           Case 3
                Diao = "D#"
           Case 4
                Diao = "E"
           Case 5
                Diao = "F"
           Case 6
                Diao = "F#"
           Case 7
                Diao = "G"
           Case 8
                Diao = "G#"
           Case 9
                Diao = "A"
           Case 10
                Diao = "A#"
           Case 11
                Diao = "B"
    End Select
End Function

Private Sub Opttone_Click(Index As Integer)
    Select Case Index
           Case 0
                tonen = 4 / 4
           Case 1
                tonen = 3 / 4
           Case 2
                tonen = 2 / 4
    End Select
    Call tonetcount
End Sub

Private Sub Optmintone_Click(Index As Integer)
    Select Case Index
           Case 0
                mintime = 1 / 8
                Checktime(0).Enabled = True
                Checktime(1).Enabled = True
                Checktime(2).Enabled = True
           Case 1
                mintime = 1 / 4
                Checktime(0).Enabled = False
                Checktime(1).Enabled = True
                Checktime(2).Enabled = True
           Case 2
                mintime = 1 / 2
                Checktime(0).Enabled = False
                Checktime(1).Enabled = False
                Checktime(2).Enabled = True
           Case 3
                mintime = 1
                Checktime(0).Enabled = False
                Checktime(1).Enabled = False
                Checktime(2).Enabled = False
    End Select
    Call tonetcount
End Sub

Sub tonetcount()
    Select Case tonen
           Case 4 / 4
           Select Case mintime
                  Case 1 / 8: tonet = 62
                  Case 1 / 4: tonet = 125
                  Case 1 / 2: tonet = 250
                  Case 1 / 1: tonet = 500
           End Select
           Case 3 / 4
           Select Case mintime
                  Case 1 / 8: tonet = 94
                  Case 1 / 4: tonet = 187
                  Case 1 / 2: tonet = 375
                  Case 1 / 1: tonet = 750
           End Select
           Case 2 / 4
           Select Case mintime
                  Case 1 / 8: tonet = 125
                  Case 1 / 4: tonet = 250
                  Case 1 / 2: tonet = 500
                  Case 1 / 1: tonet = 1000
           End Select
    End Select
    Labeltime.Caption = tonet & "ms"
End Sub

Private Sub Checktime_Click(Index As Integer)
    notetime = 0
    For Index = 0 To 5
        If Checktime(Index).Value = 1 Then
           notetime = notetime + 1 / 8 * 2 ^ Index
        Else
           notetime = notetime
        End If
    Next Index
    Textmusic.SetFocus
End Sub

Private Sub Optyinhl_Click(Index As Integer)
    Select Case Index
           Case 0
                pitch = "a"
           Case 1
                pitch = "s"
           Case 2
                pitch = "d"
           Case 3
                pitch = "z"
           Case 4
                pitch = "x"
           Case 5
                pitch = "c"
    End Select
End Sub

Sub judge()
Dim mscbf As String
Dim n As Integer
Dim i As Integer
Dim checkflag As Boolean
    If Textmusic.Text <> "" Then
       If Textmusic.Text = "0" Then
          checkflag = False
          For i = 0 To 5
              If Checktime(i).Value = 1 Then
                 checkflag = True
              End If
          Next i
          If checkflag = False Then
             Button = MsgBox("输入错误！请选择休止符的节拍", _
                      vbOKOnly + vbInformation, "提示信息")
             Textmusic.Text = ""
             Exit Sub
          End If
          GoTo mscnumshow
       ElseIf Val(Textmusic.Text) > 0 And Val(Textmusic.Text) < 8 Then
          checkflag = False
          For i = 0 To 5
              If Checktime(i).Value = 1 Then
                 checkflag = True
              End If
          Next i
          If checkflag = False Then
             Button = MsgBox("输入错误！请选择此音符的节拍", _
                      vbOKOnly + vbInformation, "提示信息")
             Textmusic.Text = ""
             Exit Sub
          End If
          GoTo mscnumshow
       Else
           Button = MsgBox("输入错误！请输入正确的音符", _
                      vbOKOnly + vbInformation, "提示信息")
           Textmusic.Text = ""
           Exit Sub
       End If
mscnumshow:
          n = notetime / mintime
          mcnum = Textmusic.Text
          mscbf = pitch & mcnum & lists
          For i = 1 To n
          Textbackshow.Text = Textbackshow.Text + mscbf
          Next i
          Textmusic.Text = ""
    Else
        Button = MsgBox("输入错误！没有简谱输入", _
                 vbOKOnly + vbInformation, "提示信息")
        Exit Sub
    End If
End Sub

Sub musicnum(mcnum As String)
           Select Case mcnum
                 Case "0": num = 0
                 Case "1": num = 1
                 Case "2": num = 3
                 Case "3": num = 5
                 Case "4": num = 6
                 Case "5": num = 8
                 Case "6": num = 10
                 Case "7": num = 12
          End Select
End Sub

Sub pitchnum(pitch As String)
    Select Case pitch
           Case "a"
                yinhl = 0
           Case "s"
                yinhl = 12
           Case "d"
                yinhl = 24
           Case "z"
                yinhl = 36
           Case "x"
                yinhl = 48
           Case "c"
                yinhl = 60
    End Select
End Sub

Sub msccode(so As String)
Dim i As Integer
Dim s As String
Dim st As String
    s = Textbackshow.Text
    so = ""
    For i = 1 To Len(s) Step 3
        st = Mid(s, i, 3)
    Call pitchnum(Left(st, 1))
    Call musicnum(Mid(st, 2, 1))
    If num = 0 Then
       num = Len(mcode)
    Else
       num = num + yinhl
    End If
    so = so + Mid(mcode, num, 1)
    Next i
End Sub

Sub savefile()
Dim mt As Integer
Dim so As String
    Call msccode(so)
    so = so & "\"
    mt = Val(Labeltime.Caption)
    CommonDialog1.DialogTitle = "保存"
    CommonDialog1.Filter = "All Files(*.*)|*.*|音乐文件|*.txt|"
    CommonDialog1.FilterIndex = 2
    CommonDialog1.Flags = 6
    CommonDialog1.Action = 2
    On Error GoTo SaveFile_Err
   
    Open CommonDialog1.FileName For Output As #1
         Write #1, Mid(ds, (HScrolltone.Value + 1), 1)
         Write #1, mt
         Write #1, so
         Write #1, tonen
         Write #1, mintime
    Close #1
    HScrolltone.Value = 0
    so = ""
SaveFile_Err:
    Exit Sub
End Sub

Sub pitchid(num As Integer)
    Select Case num
           Case Is <= 12
                pitch = "a"
           Case Is <= 24
                pitch = "s"
           Case Is <= 36
                pitch = "d"
           Case Is <= 48
                pitch = "z"
           Case Is <= 60
                pitch = "x"
           Case Is <= 65
                pitch = "c"
    End Select
End Sub

Sub nummusic(num As Integer)
    Select Case num
           Case 0: mcnum = "0"
           Case 1: mcnum = "1"
           Case 3: mcnum = "2"
           Case 5: mcnum = "3"
           Case 6: mcnum = "4"
           Case 8: mcnum = "5"
           Case 10: mcnum = "6"
           Case 12: mcnum = "7"
    End Select
End Sub

Sub openfile()
Dim i As Integer
Dim numt As Integer
Dim tm As String
Dim dm As String
Dim filebf As String
Dim mscbf As String
Dim showbf As String

    CommonDialog2.DialogTitle = "打开"
    CommonDialog2.Filter = "All File(*.*)|*.*|音乐文件|*.txt|"
    CommonDialog2.FilterIndex = 2
    CommonDialog2.Flags = 0
    CommonDialog2.Action = 1
    On Error GoTo OpenFile_Err

    Open CommonDialog2.FileName For Input As #2
         Input #2, dm
         Input #2, tm
         Input #2, filebf
         Input #2, tonen
         Input #2, mintime
    Close #2
    Select Case tonen
           Case 4 / 4: Opttone(0).Value = True
           Case 3 / 4: Opttone(1).Value = True
           Case 2 / 4: Opttone(2).Value = True
    End Select
    Select Case mintime
           Case 1 / 8: Optmintone(0).Value = True
           Case 1 / 4: Optmintone(1).Value = True
           Case 1 / 2: Optmintone(2).Value = True
           Case 1 / 1: Optmintone(3).Value = True
    End Select
    HScrolltone.Value = InStr(1, ds, dm) - 1
    Labeltime.Caption = tm & "ms"
    filebf = Left(filebf, (Len(filebf) - 1))
    showbf = ""
    Textbackshow.Text = ""
    For i = 1 To Len(filebf)
        If Mid(filebf, i, 1) = "\" Then
           numt = 0
        Else
           numt = InStr(1, mcode, Mid(filebf, i, 1))
        End If
        Call pitchid(numt)
        Call nummusic((numt Mod 12))
        mscbf = pitch & mcnum & lists
        showbf = showbf + mscbf
    Next i
    Textbackshow.Text = showbf
    showbf = ""

OpenFile_Err:
    Exit Sub
End Sub