حالت موضوعی | حالت خطی

yeketaz

برنامه رو کامپایل و باز کنید،سپس فایل MIDI رو گرفته و به دورن برنامه بیندازید و اطلاعات را ذخیره کنید

کد: 
#Compile Exe "MidiDisAsm.exe"

#Dim All

#Register All

'**************************************

'from IncLean file

%WINAPI = 1

%TRUE = 1

%FALSE = 0

%MAX_PATH = 260 ' max. length of full pathname

%wm_destroy = &H2

%wm_initdialog = &H110

%wm_command = &H111

%WM_DROPFILES = &H233

%ws_popup = &H80000000

%ws_child = &H40000000

%ws_visible = &H10000000

%ws_clipsiblings = &H04000000

%ws_caption = &H00C00000 ' WS_BORDER OR WS_DLGFRAME

%ws_border = &H00800000

%ws_dlgframe = &H00400000

%ws_sysmenu = &H00080000

%ws_tabstop = &H00010000

%ws_minimizebox = &H00020000

%ws_ex_acceptfiles = &H00000010

%ws_ex_clientedge = &H00000200

%ws_ex_left = &H00000000

%ws_ex_ltrreading = &H00000000

%ws_ex_rightscrollbar = &H00000000

%ws_ex_controlparent = &H00010000

%HWND_DESKTOP = 0

%idcancel = 2

%mb_yesno = &H00000004&

%mb_iconhand = &H00000010&

%mb_iconasterisk = &H00000040&

%mb_iconerror = %mb_iconhand

%mb_iconinformation = %mb_iconasterisk

%idno = 7

%es_left = &H0&

%es_multiline = &H4&

%es_autovscroll = &H40&

%es_autohscroll = &H80&

%es_readonly = &H800&

%ss_center = &H00000001

%ds_3dlook = &H0004&

%ds_nofailcreate = &H0010&

%ds_setfont = &H0040& ' User specified font for Dlg controls

%ds_modalframe = &H0080& ' Can be combined with WS_CAPTION

%MAXPNAMELEN = 32 ' max product name length (including NULL)

%MMSYSERR_BASE = 0

%MMSYSERR_NOERROR = 0 ' no error

%MMSYSERR_BADDEVICEID = %MMSYSERR_BASE + 2 ' device ID out of range

%MMSYSERR_NODRIVER = %MMSYSERR_BASE + 6 ' no device driver present

%MMSYSERR_NOMEM = %MMSYSERR_BASE + 7 ' memory allocation error

%MMSYSERR_INVALPARAM = %MMSYSERR_BASE + 11 ' invalid parameter passed

Type MIDIOUTCAPS

 wMid As Word

 wPid As Word

 vDriverVersion As Dword

 szPname As Asciiz * %MAXPNAMELEN

 wTechnology As Word

 wVoices As Word

 wNotes As Word

 wChannelMask As Word

 dwSupport As Dword

End Type

Declare Function DragQueryFile Lib "SHELL32.DLL" Alias "DragQueryFileA" (ByVal hDrop As Dword, ByVal uiFile As Dword, lpStr As Asciiz, ByVal cch As Dword) As Dword

Declare Function midiOutGetDevCaps Lib "WINMM.DLL" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Dword, lpCaps As MIDIOUTCAPS, ByVal uSize As Dword) As Long

Declare Sub DragAcceptFiles Lib "SHELL32.DLL" Alias "DragAcceptFiles" (ByVal hwnd As Dword, ByVal fAccept As Long)

Declare Sub DragFinish Lib "SHELL32.DLL" Alias "DragFinish" (ByVal hDrop As Dword)

'**************************************

%Dlg = 101

%Lbl = 1001

%Txt = 1002

'REM out "%Abbreviate" if you want the full names of drum sounds and controllers

'to be Print#-ed instead of their abbreviations.

%Abbreviate = 1 '(this controls compiling not operation)

'de-REM "%SharpNotation" if you prefer that style

%SharpNotation = 1 '(this controls compiling not operation)

$MidiHeader = "MThd" & Chr$(0, 0, 0, 6)

$EventPrefix = "@"

$Caption = "TheirCorp's MIDI Disassembler"

$Help = "To use:" & $CrLf & _

 "In Windows Explorer, drop a file on the program's" & $CrLf & _

 "window or on it's icon." & $CrLf & _

 "From the command line, type: ""MidiDisAsm FileName""" & $CrLf & _

 "(The file extension can be omitted)"

$Ascii = Chr$(32 To 122)

#If %def(%SharpNotation)

 $Notes = "C,C#,D,D#,E,F,F#,G,G#,A,A#,B"

#Else

 $Notes = "C,Db,D,Eb,E,F,F#,G,G#,A,Bb,B"

#EndIf

'**************************************

Global hDlg As Dword

Global gs As String

Global fo As Long 'output file's handle

Global div As Dword 'division

Global tics As Dword 'ticks

Global tmpo As Dword 'tempo

Global tpq As Long 'ticks per quarter-note

Global sf As Double 'smpte format

Global sr As Double 'smpte resolution

Global moc As MIDIOUTCAPS

Global InFile As String

Global OutFile As String

'**************************************

Sub Msg(ps As String)

 Control Set Text hDlg, %Txt, ps

End Sub

'**************************************

#If %def(%Abbreviate)

'**************************************

'returns the GM drum sound for note number "nn"

Function GetGMDrumSound(nn As Long) As String

'These are numbered beginning at 35

Data Acou Bass Drum

Data Bass Drum1

Data Side Stk

Data Acou Snar

Data Clap

Data Elec Snar

Data Lo Flr Tom

Data Clsd Hi-Hat

Data Hi Flr Tom

Data Ped Hi-Hat

Data Lo Tom

Data Opn Hi-Hat

Data LoMid Tom

Data HiMid Tom

Data Crsh Cym1

Data Hi Tom

Data Rid Cym1

Data Chin Cym

Data Rid Bell

Data Tamb

Data Splsh Cym

Data Cwbell

Data Crsh Cym2

Data Vbrslp

Data Rid Cym2

Data Hi Bngo

Data Lo Bngo

Data Mut Hi Cnga

Data Opn Hi Cnga

Data Lo Cnga

Data Hi Timb

Data Lo Timb

Data Hi Agog

Data Lo Agog

Data Cabas

Data Marac

Data Shrt Whst

Data Lng Whst

Data Shrt Guir

Data Lng Guir

Data Clves

Data Hi Wd Blk

Data Lo Wd Blk

Data Mut Cuic

Data Opn Cuic

Data Mut Trngl

Data Opn Trngl

 Function = Read$(nn - 34)

End Function 'GetGMDrumSound

'**************************************

'get abbreviated controller name

'cn is a zero-based controller number

Function GetControllerName(cn As Long) As String

'Defined Controllers

Data Bank

Data Mod (crs)

Data Breath (crs)

Data

Data Foot (crs)

Data Porta (crs)

Data Data (crs)

Data Vol (crs)

Data Bal (crs)

Data

Data Pan (crs)

Data Expr (crs)

Data Eff1 (crs)

Data Eff2 (crs)

Data ,

Data Sldr1

Data Sldr2

Data Sldr3

Data Sldr4

Data ,,,,,,,,,,,

Data Bank (fin)

Data Mod (fin)

Data Breath (fin)

Data

Data Foot (fin)

Data Porta (fin)

Data Data (fin)

Data Vol (fin)

Data Bal (fin)

Data

Data Pan (fin)

Data Expr (fin)

Data Eff1 (fin)

Data Eff2 (fin)

Data ,,,,,,,,,,,,,,,,,

Data Hold (+/-)

Data Porta (+/-)

Data Sust (+/-)

Data Soft (+/-)

Data Legato (+/-)

Data Hold2 (+/-)

Data Varia

Data Timbre

Data Release

Data Attack

Data Bright

Data SndCtrl 6

Data SndCtrl 7

Data SndCtrl 8

Data SndCtrl 9

Data SndCtrl 10

Data But1 (+/-)

Data But2 (+/-)

Data But3 (+/-)

Data But4 (+/-)

Data ,,,,,,

Data Fx Lev

Data Tremu

Data Chorus

Data Celeste

Data Phaser

Data Data But+

Data Data But-

Data NonPar (fin)

Data NonPar (crs)

Data RegPar (fin)

Data RegPar (crs)

Data ,,,,,,,,,,,,,,,,,

Data AllSnds-

Data AllCtrls-

Data Loc Kbrd (+/-)

Data AllNotes-

Data Omni-

Data Omni+

Data MonoOper

Data PolyOper

Local ls As String

 ls = Read$(cn + 1)

 Function = IIf$(Len(ls), ls, "(Unk)")

End Function 'GetControllerName

#Else 'verbose string functions

'**************************************

'returns the GM drum sound for note number "nn"

Function GetGMDrumSound(nn As Long) As String

'These are numbered beginning at 35

Data Acoustic Bass Drum

Data Bass Drum 1

Data Side Stick

Data Acoustic Snare

Data Hand Clap

Data Electric Snare

Data Low Floor Tom

Data Closed Hi-Hat

Data High Floor Tom

Data Pedal Hi-Hat

Data Low Tom

Data Open Hi-Hat

Data Low-Mid Tom

Data Hi-Mid Tom

Data Crash Cymbal 1

Data High Tom

Data Ride Cymbal 1

Data Chinese Cymbal

Data Ride Bell

Data Tambourine

Data Splash Cymbal

Data Cowbell

Data Crash Cymbal 2

Data Vibraslap

Data Ride Cymbal 2

Data Hi Bongo

Data Low Bongo

Data Mute Hi Conga

Data Open Hi Conga

Data Low Conga

Data High Timbale

Data Low Timbale

Data High Agogo

Data Low Agogo

Data Cabasa

Data Maracas

Data Short Whistle

Data Long Whistle

Data Short Guiro

Data Long Guiro

Data Claves

Data Hi Wood Block

Data Low Wood Block

Data Mute Cuica

Data Open Cuica

Data Mute Triangle

Data Open Triangle

 Function = Read$(nn - 34)

End Function 'GetGMDrumSound

'**************************************

'get verbose controller name

'cn is a zero-based controller number

Function GetControllerName(cn As Long) As String

'Defined Controllers

Data Bank Select

Data Modulation Wheel (coarse)

Data Breath controller (coarse)

Data

Data Foot Pedal (coarse)

Data Portamento Time (coarse)

Data Data Entry (coarse)

Data Volume (coarse)

Data Balance (coarse)

Data

Data Pan position (coarse)

Data Expression (coarse)

Data Effect Control 1 (coarse)

Data Effect Control 2 (coarse)

Data ,

Data General Purpose Slider 1

Data General Purpose Slider 2

Data General Purpose Slider 3

Data General Purpose Slider 4

Data ,,,,,,,,,,,

Data Bank Select (fine)

Data Modulation Wheel (fine)

Data Breath controller (fine)

Data

Data Foot Pedal (fine)

Data Portamento Time (fine)

Data Data Entry (fine)

Data Volume (fine)

Data Balance (fine)

Data

Data Pan position (fine)

Data Expression (fine)

Data Effect Control 1 (fine)

Data Effect Control 2 (fine)

Data ,,,,,,,,,,,,,,,,,

Data Hold Pedal (on/off)

Data Portamento (on/off)

Data Sustenuto Pedal (on/off)

Data Soft Pedal (on/off)

Data Legato Pedal (on/off)

Data Hold 2 Pedal (on/off)

Data Sound Variation

Data Sound Timbre

Data Sound Release Time

Data Sound Attack Time

Data Sound Brightness

Data Sound Control 6

Data Sound Control 7

Data Sound Control 8

Data Sound Control 9

Data Sound Control 10

Data General Purpose Button 1 (on/off)

Data General Purpose Button 2 (on/off)

Data General Purpose Button 3 (on/off)

Data General Purpose Button 4 (on/off)

Data ,,,,,,

Data Effects Level

Data Tremulo Level

Data Chorus Level

Data Celeste Level

Data Phaser Level

Data Data Button increment

Data Data Button decrement

Data Non-registered Parameter (fine)

Data Non-registered Parameter (coarse)

Data Registered Parameter (fine)

Data Registered Parameter (coarse)

Data ,,,,,,,,,,,,,,,,,

Data All Sound Off

Data All Controllers Off

Data Local Keyboard (on/off)

Data All Notes Off

Data Omni Mode Off

Data Omni Mode On

Data Mono Operation

Data Poly Operation

Local ls As String

 ls = Read$(cn + 1)

 Function = IIf$(Len(ls), ls, "(Unk)")

End Function 'GetControllerName

#EndIf

'**************************************

'pn is the zero-based patch index

Function GetPatchName(pn As Long) As String

'----------------------------------

'Piano

Data Acoustic Grand

Data Bright Acoustic

Data Electric Grand

Data ***** - Tonk

Data Electric Piano 1

Data Electric Piano 2

Data Harpsichord

Data Clav

'----------------------------------

'Chromatic Percussion

Data Celesta

Data Glockenspiel

Data Music Box

Data Vibraphone

Data Marimba

Data Xylophone

Data Tubular Bells

Data Dulcimer

'----------------------------------

'Organ

Data Drawbar Organ

Data Percussive Organ

Data Rock Organ

Data Church Organ

Data Reed Organ

Data Accoridan

Data Harmonica

Data Tango Accordian

'----------------------------------

'Guitar

Data Acoustic Guitar(nylon)

Data Acoustic Guitar(steel)

Data Electric Guitar(jazz)

Data Electric Guitar(clean)

Data Electric Guitar(muted)

Data Overdriven Guitar

Data Distortion Guitar

Data Guitar Harmonics

'----------------------------------

'Bass

Data Acoustic Bass

Data Electric Bass(finger)

Data Electric Bass(pick)

Data Fretless Bass

Data Slap Bass 1

Data Slap Bass 2

Data Synth Bass 1

Data Synth Bass 2

'----------------------------------

'Solo Strings

Data Violin

Data Viola

Data Cello

Data Contrabass

Data Tremolo Strings

Data Pizzicato Strings

Data Orchestral Strings

Data Timpani

'----------------------------------

'Ensemble

Data String Ensemble 1

Data String Ensemble 2

Data SynthStrings 1

Data SynthStrings 2

Data Choir Aahs

Data Voice Oohs

Data Synth Voice

Data Orchestra Hit

'----------------------------------

'Brass

Data Trumpet

Data Trombone

Data Tuba

Data Muted Trumpet

Data French Horn

Data Brass Section

Data SynthBrass 1

Data SynthBrass 2

'----------------------------------

'Reed

Data Soprano Sax

Data Sax

Data Tenor Sax

Data Baritone Sax

Data Oboe

Data English Horn

Data Bassoon

Data Clarinet

'----------------------------------

'Pipe

Data Piccolo

Data Flute

Data Recorder

Data Pan Flute

Data Blown Bottle

Data Skakuhachi

Data Whistle

Data Ocarina

'----------------------------------

'Synth Lead

Data Lead 1 (square)

Data Lead 2 (sawtooth)

Data Lead 3 (calliope)

Data Lead 4 (chiff)

Data Lead 5 (charang)

Data Lead 6 (voice)

Data Lead 7 (fifths)

Data Lead 8 (bass + lead)

'----------------------------------

'Synth Pad

Data Pad 1 (new age)

Data Pad 2 (warm)

Data Pad 3 (polysynth)

Data Pad 4 (choir)

Data Pad 5 (bowed)

Data Pad 6 (metallic)

Data Pad 7 (halo)

Data Pad 8 (sweep)

'----------------------------------

'Synth Effects

Data FX 1 (rain)

Data FX 2 (soundtrack)

Data FX 3 (crystal)

Data FX 4 (atmosphere)

Data FX 5 (brightness)

Data FX 6 (goblins)

Data FX 7 (echoes)

Data FX 8 (sci-fi)

'----------------------------------

'Ethnic

Data Sitar

Data Banjo

Data Shamisen

Data Koto

Data Kalimba

Data Bagpipe

Data Fiddle

Data Shanai

'----------------------------------

'Percussive

Data Tinkle Bell

Data Agogo

Data Steel Drums

Data Woodblock

Data Taiko Drum

Data Melodic Tom

Data Synth Drum

Data Reverse Cymbal

'----------------------------------

'Sound Effects

Data Guitar Fret Noise

Data Breath Noise

Data Seashore

Data Bird Tweet

Data Telephone Ring

Data Helicopter

Data Applause

Data Gunshot

 Function = Read$(pn + 1)

End Function 'GetPatchName

'**************************************

'for SysEx events

'mn is a one-based, manufacturer's ID number

'(not sure how up to date the list is)

Function GetManufacturerName(mn As Long) As String

'Here are the Manufacturer which have ID numbers assigned:

Data Sequential Circuits

Data Big Briar

Data Octave / Plateau

Data Moog 4

Data Passport Designs

Data Lexicon

Data Kurzweil

Data Fender

Data Gulbransen

Data Delta Labs

Data Sound Comp.

Data General Electro

Data Techmar

Data Matthews Research

Data

Data Oberheim

Data PAIA

Data Simmons

Data DigiDesign

Data Fairlight

Data JL Cooper

Data Lowery

Data Lin

Data Emu

Data ,

Data Peavey

Data ,,,

Data Bon Tempi

Data S.I.E.L.

Data

Data SyntheAxe

Data Hohner

Data Crumar

Data Solton

Data Jellinghaus Ms

Data CTS

Data PPG

Data ,,,,

Data Elka

Data ,,,,,

Data Cheetah

Data ,,,,,,

Data Waldorf

Data

Data Kawai

Data Roland

Data Korg

Data Yamaha

Data Casio

Data Akai

Local ls As String

 Select Case mn

 Case < &H46 : ls = Read$(mn)

 Case = &H7E : ls = "Non-RealTime (universal)"

 Case = &H7F : ls = "RealTime (universal)"

 End Select

 Function = IIf$(Len(ls), ls, "(Unk)")

End Function 'GetManufacturerName

'**************************************

'returns a variable-length data value

'this modifies p to point it at the last byte of

'variable-length data

Function VarLen(tk As String, ByRef p As Long) As Long

Local b As Long

Local n As Long

Local td As Dword

 Do

 Incr n

 b = Asc(tk, p)

 Shift Left td, 7

 td = td + (b And 127)

 If (b And &H80) = 0 Then Exit Do

 Incr p

 Loop While (n < 5) And (p <= Len(tk))

 Function = td

End Function

'**************************************

'Octave| | Note Numbers

' # | |

' | | C | C# | D | D# | E | F | F# | G | G# | A | A# | B

'-----------------------------------------------------------------------------

' 0 | | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11

' 1 | | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23

' 2 | | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35

' 3 | | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47

' 4 | | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59

' 5 | | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71

' 6 | | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83

' 7 | | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95

' 8 | | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107

' 9 | | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119

' 10 | | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 |

Function GetNoteName(nn As Long) As String

 Function = Parse$($Notes, (nn Mod 12) + 1) & " (" & Format$(nn\12) & ")"

End Function 'GetNoteName

'**************************************

'returns a string to display the total

'delta-time ticks elapsed since the start of

'the current track

'resets the time if dt = &HFFFFFFFF???

Function FormatTime(dt As Dword) As String

Static tm As Quad

 If dt = &HFFFFFFFF??? Then tm = 0 : Exit Function 'reset the time

 tm = tm + dt 'update the time

 Function = Using$("#,", tm)

End Function 'FormatTime

'**************************************

'p must arrive pointing at the meta-event's code

Function DisMetaEvent(tk As String, ByVal p As Long, ByVal dt As Dword) As Long

Local ev As Long 'event code

Local n As Long

Local pf As Long '"Print#" flag

Local x As Long

Local ls As String

Local ts As String

Local td As Dword 'temporary DWord

 Dim ab(3) As Byte At VarPtr(td)

 'get the event code and channel number

 ev = Asc(tk, p)

 Incr p

 n = VarLen(tk, p)

 'get the event's data

 Incr p

 ls = Mid$(tk, p, n)

 Incr pf 'enable Print#-ing

 '----------------------------------

 'decode the event

 Select Case ev

 ' Set Track Sequence Number

 Case &H00

 td = CvWrd(ls)

 Swap ab(0), ab(1)

 ls = "Sequence= " & Format$(td)

 ' Text

 Case &H01

 ls = "Text {" & $Lf & ls & "}"

 ' Copyright Info

 Case &H02

 ls = "CopyRight {" & $Lf & ls & "}"

 ' Sequence or Track Name

 Case &H03

 ls = "TrackName {" & $Lf & ls & "}"

 ' Track Instrument Name

 Case &H04

 ls = "Instrument {" & $Lf & ls & "}"

 ' Lyric

 Case &H05

 ls = "Lyric {" & $Lf & ls & "}"

 ' Marker

 Case &H06

 ls = "Marker {" & $Lf & ls & "}"

 ' Cue Point

 Case &H07

 ls = "CuePoint {" & $Lf & ls & "}"

 ' MIDI Channel

 Case &H07

 ls = "MidiChannel= " & Format$(Asc(ls) + 1)

 ' Device Name Assigned to MIDI Port

 Case &H21

 x = Asc(ls)

 ls = "Error getting device name:" & $CrLf

 Select Case midiOutGetDevCaps(x, moc, SizeOf(MIDIOUTCAPS))

 Case %MMSYSERR_BADDEVICEID

 ls = ls & """The specified device identifier is out of range."""

 Case %MMSYSERR_INVALPARAM

 ls = ls & """The specified pointer or structure is invalid."""

 Case %MMSYSERR_NODRIVER

 ls = ls & """The driver is not installed."""

 Case %MMSYSERR_NOMEM

 ls = ls & """The system is unable to load mapper string description."""

 Case %MMSYSERR_NOERROR

 ls = "DeviceName= " & moc.szPname

 End Select

 ' End of Track

 Case &H2F

 ls = "EndOfTrack"

 ' Set Tempo

 Case &H51

 td = CvDwd(ls)

 GoSub ToggleEndian

 Shift Right td, 8

 tmpo = 60000000/td

 ls = "Tempo=" & Format$(tmpo) & " (" & Format$(td) & " mms per 1/4 note)"

 ' SMPTE Offset

 Case &H54 '(not implemented)

 ' Time Signature

 Case &H58

 ts = ls

 ls = "TimeSignature {" & $Lf

 ls = ls & Format$(Asc(ts, 1)) & "/" & Format$(2 ^ Asc(ts, 2)) & $Lf

 ls = ls & "Ticks/metronome click= " & Format$(Asc(ts, 3)) & $Lf

 ls = ls & "32nd notes/quarter= " & Format$(Asc(ts, 4)) & $Lf & "}"

 ' Key Signature

 Case &H59

 x = Asc(ls, 1)

 If Bit(x, 7) Then x = x Or &HFFFFFF00

 If x <> 0 Then

 ts = String$(Abs(x), IIf$(x > 0, "#", "b")) & IIf$(Asc(ls, 2), " Min", " Maj")

 Else

 ts = "(Nat)"

 End If

 ls = "KeySignature: " & ts

 ' Proprietary (sequencer-specific information)

 Case &H7F

 ts = ls

 ls = "Proprietary {" & $Lf

 ls = ls & "Program ID: " & Left$(ts, Min(4, Verify(ts, $Ascii) - 1)) & $Lf

 For x = 1 To Len(ts)

 ls = ls & Hex$(Asc(ts, x), 2) & $Spc

 If x Mod 16 = 0 Then ls = ls & $Lf

 Next x

 ls = ls & "}"

 Case Else

 ls = "UnkownMetaEvent: &H" & Hex$(ev, 2)

 End Select

 If pf Then

 Replace $Lf With $CrLf In ls

 Print# fo, FormatTime(dt) & $Tab & $EventPrefix & ls

 End If

 Function = p + n - 1

 Exit Function

ToggleEndian:

 Swap ab(0), ab(3)

 Swap ab(1), ab(2)

Return

End Function 'DisMetaEvent

'**************************************

Function DisTrack(tk As String) As Long

Local ev As Long

Local dt As Dword 'delta time

Local ch As Long 'channel

Local cn As Long 'controller number

Local nn As Long 'note number

Local ve As Long 'velocity

Local pn As Long 'patch number

Local pw As Long 'pitch wheel

Local nv As Long '"new value"

Local pf As Long '"Print#" flag

Local wf As Long 'warning flag

Local n As Long

Local p As Long

Local tc As String 'time and channel

Local ls As String

Local ts As String

 For p = 1 To Len(tk)

 dt = VarLen(tk, p) 'get the delta-time

 Incr p

 n = Asc(tk, p)

 'if no event byte is present, the last one is assumed to be intended

 If (n And 128) Then

 ev = n

 Incr p

 End If

 ch = (ev And 15) + 1

 ls = FormatTime(dt) & $Tab & "Ch=" & Format$(ch) & ": " & $EventPrefix

 Incr pf 'enable Print#-ing

 '----------------------------------

 'decode the event

 Select Case ev

 'just in case...

 Case < &H80

 ls = "Running Mode Error!"

 ' Note Off

 Case < &H90

 nn = Asc(tk, p)

 Incr p

 ve = Asc(tk, p)

 ls = Left$(ls, Len(ls) - 1) & " - " & IIf$(ch = 10, GetGMDrumSound(nn), GetNoteName(nn)) & $Tab & "V=" & Format$(ve)

 ' Note On

 Case < &HA0

 nn = Asc(tk, p)

 Incr p

 ve = Asc(tk, p)

 ls = Left$(ls, Len(ls) - 1) & IIf$(ve, "+ ", "z ") & IIf$(ch = 10, GetGMDrumSound(nn), GetNoteName(nn))

 ls = ls & IIf$(ve, $Tab & "V=" & Format$(ve), "")

 ' Key After-Touch

 Case < &HB0

 nn = Asc(tk, p)

 Incr p

 ve = Asc(tk, p)

 ls = ls & "Touch:" & $Tab & IIf$(ch = 10, GetGMDrumSound(nn), GetNoteName(nn)) & $Tab & "V=" & Format$(ve)

 ' Control Change

 Case < &HC0

 cn = Asc(tk, p)

 Incr p

 nv = Asc(tk, p)

 ls = ls & "Ctrl:" & GetControllerName(cn) & "=" & Format$(nv)

 ' Program (Patch) Change

 Case < &HD0

 pn = Asc(tk, p)

 ls = ls & "Patch= " & GetPatchName(pn)

 ' Channel Pressure

 Case < &HE0

 cn = Asc(tk, p)

 ls = ls & "ChanPress=" & Format$(cn)

 ' Pitch Wheel Change

 Case < &HF0

 pw = Asc(tk, p) And 127

 Incr p

 pw = pw + ((Asc(tk, p) And 127) * 128)

 ls = ls & "Wheel= " & Format$(pw - &H2000&)

 ' System Exclusive

 Case &HF0

 ls = FormatTime(dt) & $Tab & $EventPrefix & "SysEx: (hex format) {" & $CrLf

 n = p + VarLen(tk, p)

 ls = ls & "Manufacturer: " & GetManufacturerName(Asc(tk, p)) & $CrLf

 Do While p < n

 Incr p

 ls = ls & $Spc & Hex$(Asc(tk, p), 2)

 If (n - p) Mod 16 = 0 Then ls = ls & $CrLf

 Loop

 ls = ls & "}"

 'Song Position (not implemented)

 Case &HF2

 Incr wf

 ls = ls & "SongPosition"

 'Song Select (not implemented)

 Case &HF3

 Incr wf

 ls = ls & "SongSelect"

 'Unofficial Bus Select (not implemented)

 Case &HF5

 Incr wf

 ls = ls & "UnofficialBusSelect"

 'Tune Request (not implemented)

 Case &HF6

 Incr wf

 ls = ls & "TuneRequest"

 'End of SysEx

 'Case &HF7

 'this should always be caught in a SysEx event, so it's REM-ed out

 ' Incr wf

 ' ls = "}"

 'Timing Tick (not implemented)

 Case &HF8

 Incr wf

 ls = ls & "TimingTick"

 'Start Current Sequence (not implemented)

 Case &HFA

 Incr wf

 ls = ls & "StartCurrentSeq"

 'Continue Stopped Sequence (not implemented)

 Case &HFB

 Incr wf

 ls = ls & "ContinueSeq"

 'Stop Sequence (not implemented)

 Case &HFC

 Incr wf

 ls = ls & "StopSeq"

 'Active Sensing (not implemented)

 Case &HFE

 Incr wf

 ls = ls & "ActiveSensing"

 'Meta-Event

 Case &HFF

 p = DisMetaEvent(tk, p, dt)

 pf = 0

 End Select

 If pf Then Print# fo, ls

 If wf Then

 gs = "Found an unimplemented command, aborting track..."

 Msg gs

 Print# fo, gs

 Exit Function

 End If

 Next p

End Function

'**************************************

'if dr <> 0 then the file was dropped on to the

'dialog rather than dropped on the icon or entered

'at the command line.

Function MidiMain(dr As Long) As Long

Local fi As Long 'input file

Local n As Long

Local trks As Long 'number of tracks

Local tn As Long 'track number

Local tlen As Long 'track length

Local td As Dword 'temporary DWord

Local ls As String

Local tk As String

 Dim ab(3) As Byte At VarPtr(td)

 If dr = 0 Then

 If InStr(",H,HELP,-H,-HELP,/H,/HELP,", "," & UCase$(InFile) & ",") Then

 MsgBox $Help, %mb_iconinformation, $Caption

 Exit Function

 End If

 End If

 'add file extension if needed

 If InStr(InFile, ".") = 0 Then

 InFile = InFile & ".MID"

 ElseIf UCase$(Right$(InFile, 4)) <> ".MID" Then 'check file extension

 gs = "Error:" & $CrLf & "Incorrect file extension. It must be a "".MID"" file"

 If dr Then Msg gs Else MsgBox gs, %mb_iconerror, $Caption

 Exit Function

 End If

 If Len(Dir$(InFile)) = 0 Then

 gs = "Error: Couldn't find " & $CrLf & """" & InFile & """"

 If dr Then Msg gs Else MsgBox gs, %mb_iconerror, $Caption

 Exit Function

 End If

 OutFile = Left$(InFile, Len(InFile) - 3) & "txt"

 If Len(Dir$(OutFile)) Then

 If MsgBox("Over-write:" & $CrLf & OutFile & "?", %mb_yesno, $Caption) = %idno Then Exit Function

 End If

 '----------------------------------

 fi = FreeFile

 Open InFile For Binary As #fi

 fo = FreeFile

 Open OutFile For Output As #fo

 '----------------------------------

 Get$ #fi, 8, ls

 If ls <> $MidiHeader Then

 gs = "Error: bad header"

 If dr Then Msg gs Else MsgBox gs

 Exit Function

 End If

 '----------------------------------

 Get$ #fi, 2, ls 'get the track format

 Print# fo, "Format= " & Choose$(Asc(ls, 2) + 1, _

 "Single-Track", "Multi-Track, Synchronous", _

 "Multi-Track, Asynchronous")

 '----------------------------------

 Get$ #fi, 2, ls 'get number of tracks

 trks = (Asc(ls, 1) * 256) + Asc(ls, 2)

 Print# fo, "Tracks=" & Format$(trks)

 '-----------------------------------------------------------------------

 tmpo = 120 'set the default BPM

 Get$ #fi, 2, ls 'get the delta-time ticks per quarter note

 div = Asc(ls, 1)

 If Bit(div, 7) Then

 !'Note: This might not give correct results for SMPTE !

 sf = Abs(CLng(div Or &HFFFFFF00???))

 sr = Asc(ls, 2)

 tpq = sf * sr * 1000000.0

 ls = "SMPTE divisions per quarter-note= "

 Else

 tpq = (div * 256) + Asc(ls, 2)

 ls = "Delta-time ticks per quarter note= "

 End If

 Print# fo, ls & Format$(tpq)

 '----------------------------------

 'Dump the tracks

 Do

 '----------------------------------

 'get the track header

 Get$ #fi, 4, ls

 If ls <> "MTrk" Then Exit Do 'bad header

 Print# fo,

 Print# fo, "****************************************"

 '----------------------------------

 'get track's length in bytes

 Get$ #fi, 4, ls

 td = CvDwd(ls)

 Swap ab(0), ab(3)

 Swap ab(1), ab(2)

 tlen = td

 Print# fo, "Track=" & Format$(tn) & $Tab & "Bytes=" & Format$(tlen)

 Get$ #fi, tlen, tk 'get the track's contents

 FormatTime(&HFFFFFFFF???)

 DisTrack(tk)

 Incr tn 'next track number

 Loop Until Eof(1)

 Close# fi, #fo

 gs = "Done with """ & InFile & """." & $CrLf & "The output is in """ & OutFile & """"

 If dr Then Msg gs Else MsgBox gs

End Function 'MidiMain

'**************************************

CallBack Function ShowDlgProc()

Local n As Long

 Select Case As Long CbMsg

 Case %wm_initdialog

 Msg $Help

 DragAcceptFiles hDlg, %TRUE

 Case %WM_DROPFILES

 InFile = String$(%MAX_PATH, $Nul)

 n = DragQueryFile(CbWParam, -1, ByVal 0, 0)

 DragQueryFile CbWParam, 0, ByVal StrPtr(InFile), %MAX_PATH

 DragFinish CbWParam

 InFile = RTrim$(InFile, $Nul)

 Msg "Processing: """ & InFile & """"

 MidiMain 1

 Case %wm_command

 Select Case As Long CbCtl

 Case %idcancel

 Dialog End hDlg

 End Select

 End Select

End Function

'**************************************

Function PBMain() As Long

 Local lRslt As Long

 InFile = Trim$(Command$, Any " """)

 If Len(InFile) Then

 MidiMain 0

 Exit Function

 End If

 Dialog New %HWND_DESKTOP, $Caption, 286, 65, 189, 65, _

 %ws_popup Or %ws_border Or %ws_dlgframe Or %ws_caption Or _

 %ws_sysmenu Or %ws_minimizebox Or %ws_clipsiblings Or %ws_visible Or _

 %ds_modalframe Or %ds_3dlook Or %ds_nofailcreate Or %ds_setfont, _

 %ws_ex_acceptfiles Or %ws_ex_controlparent Or %ws_ex_left Or _

 %ws_ex_ltrreading Or %ws_ex_rightscrollbar, To hDlg

 Control Add Label, hDlg, %Lbl, "Drop "".MID"" files onto this window", _

 0, 4, 188, 14, %ws_child Or %ws_visible Or %ss_center, %ws_ex_left Or _

 %ws_ex_ltrreading

 Control Add TextBox, hDlg, %Txt, "", 0, 19, 188, 45, %ws_child Or _

 %ws_visible Or %ws_tabstop Or %es_left Or %es_multiline Or _

 %es_autohscroll Or %es_autovscroll Or %es_readonly, _

 %ws_ex_clientedge Or %ws_ex_left Or %ws_ex_ltrreading Or _

 %ws_ex_rightscrollbar

 Dialog Show Modal hDlg, Call ShowDlgProc To lRslt

 DragAcceptFiles hdlg, %FALSE

 Function = lRslt

End Function

'**************************************

حالت موضوعی \| حالت خطی دیس اسمبلر فایلهای midi
نویسنده	پیام