-
Notifications
You must be signed in to change notification settings - Fork 0
/
AdioMidiPlayer.ctl
1160 lines (947 loc) · 40.6 KB
/
AdioMidiPlayer.ctl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
VERSION 5.00
Object = "{0518EEBD-7F0E-4513-8491-A0221C9008A2}#2.1#0"; "midiio2k.ocx"
Object = "{4424C993-EABF-4A03-9BA9-369E0F07466E}#1.2#0"; "midifl2k.ocx"
Begin VB.UserControl AdioMidiPlayer
ClientHeight = 3600
ClientLeft = 0
ClientTop = 0
ClientWidth = 4800
InvisibleAtRuntime= -1 'True
ScaleHeight = 3600
ScaleWidth = 4800
Begin MidifileLib.MIDIFile MidiFile
Left = 2280
Top = 1080
_Version = 65538
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
Filename = ""
End
Begin MidiioLib.MIDIOutput MidiOutput
Left = 1680
Top = 1080
_Version = 131073
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
End
Begin VB.Timer Timer_Playing
Enabled = 0 'False
Interval = 500
Left = 600
Top = 720
End
Begin VB.HScrollBar HScrollPlayerTime
Height = 255
Left = 1440
TabIndex = 0
Top = 1800
Width = 1815
End
Begin VB.Image Image_Main
Height = 480
Left = 0
Picture = "AdioMidiPlayer.ctx":0000
Top = 0
Width = 480
End
End
Attribute VB_Name = "AdioMidiPlayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'// Enums
Public Enum PlayMethod
[VirtualMidiSync]
[Direct]
End Enum
'// Private vars
Private Const MB_OPTIONOPENDEFAULT = 0
Private Const MB_STREAMNUMBER = 1
Private Const MB_STREAMEMPTY = 2
Private Const MB_HSCROLLTIMESCALEOFFSET = 1000&
Private Const MB_HSCROLLMESSAGESCALEOFFSET = 10&
Private Const MB_STREAMNAME_1 = "stream"
Private Const MB_STREAMNAME_FF = "FFstream"
Private Runtime As Long
Private CurrentElapsedTime As Long
Private maxt As Integer
Private TrackVis(255) As Integer
Private TrackOffset As Long
Private TimeExpectedMessage As Long
Private TimeExpectedMessageRelToTempo As Long
Private TimeExpectedMessageRelToOpen As Long
Private TimeActualMessageRelToOpen As Long
Private MainStreamNumber As Integer
Private MainStreamGroup() As Integer
Private MainStreamOption As Integer
'// Public vars
Public State As enumAdioPlayState
Public RepeatMode As enumAdioRepeatMode
Public LoadedFile As String
Public NumberOfTracks As Integer
'// Events
Public Event Ready()
Public Event Playing()
Public Event StartPlay()
Public Event Paused()
Public Event Stopped()
Public Event MediaEnded()
Public Event NewMediaFile(File As String)
Public Event Error(Description As String, Code As Long)
Public Event MidiTrack(Name As String, TrackNr As Integer)
Public Event MidiTrackAudioLevelChange(TrackNr As Integer, level As Integer)
Private Function GetTrackName(track As Integer) As String
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Dim i As Long, bnk As Integer, map As Integer
Dim s1 As String
MidiFile.TrackNumber = track
bnk = 0: map = 0: TrackVis(track) = 1
For i = 1 To MidiFile.MessageCount ' 1-based scale
MidiFile.MessageNumber = i ' 1-based scale
'
'Meta Event
'
If (MidiFile.Message = 255) And (MidiFile.Data1 = 3 Or MidiFile.Data1 = 1) Then
If (MidiFile.MsgText = "") Then
GetTrackName = "Track" & Str(track) & " (null)"
Else
If GetTrackName = "" Then
GetTrackName = MidiFile.MsgText
End If
End If
End If
If (MidiFile.Message >= &HB0 And MidiFile.Data1 = &H0) Then
bnk = MidiFile.Data2
End If
If (MidiFile.Message >= &HB0 And MidiFile.Data1 = &H20) Then
map = MidiFile.Data2
End If
If (MidiFile.Message >= &HC0 And MidiFile.Message < &HD0) Then
' Use next line if desired :)
s1 = "Channel " + Str$(MidiFile.Message - &HC0 + 1) _
+ " - Patch: " + Str$(1 + MidiFile.Data1) _
+ " Bank/Map: " + Str$(bnk) + "/" + Trim$(Str$(map))
If GetTrackName = "" Then
GetTrackName = s1
End If
Exit Function
End If
Next i
If GetTrackName = "" And MidiFile.Message <> 255 Then
GetTrackName = "Channel " + Str$(1 + MidiFile.Message And &HF) + " - No Patch"
End If
If MidiFile.Message = 255 Then ' empty track
TrackVis(track) = 0
End If
Exit Function
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Function
Private Sub DisplayTrackNames()
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Dim m As Integer
Dim t As Integer
Dim i As Integer
If MidiFile.NumberOfTracks = 1 Then
TrackOffset = 1
Else
TrackOffset = 2
End If
maxt = MidiFile.NumberOfTracks
If maxt > 32 Then maxt = 32
t = 200
If maxt > 16 Then t = 200
For t = 1 To maxt
If (t >= 2) Or (MidiFile.NumberOfTracks = 1) Then
RaiseEvent MidiTrack(Trim(GetTrackName(t)), t - 1)
End If
Next t
Exit Sub
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Sub
Public Function GetProperties() As mdlAdioProperties
Dim ReturnModel As New mdlAdioProperties
ReturnModel.DurationInSeconds = Runtime
ReturnModel.DurationString = Ext.SecondsToTimeSerial(ReturnModel.DurationInSeconds, SmallTimeSerial)
ReturnModel.ElapsedInSeconds = CurrentElapsedTime
ReturnModel.ElapsedString = Ext.SecondsToTimeSerial(ReturnModel.ElapsedInSeconds, SmallTimeSerial)
ReturnModel.RemainingInSeconds = Runtime - CurrentElapsedTime
ReturnModel.RemainingString = Ext.SecondsToTimeSerial(ReturnModel.RemainingInSeconds, SmallTimeSerial)
Set GetProperties = ReturnModel
End Function
Private Sub StopStuckNote()
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
If MidiOutput.State = MIDISTATE_CLOSED Then GoTo ExitEnd ' not needed at close
MidiOutput.SendNoteOff (4) ' clear recent notes for stuck notes and sustain
Exit Sub
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Sub
Private Sub OpenQueueStream(ByRef mStreamNumber As Integer, ByRef cStreamName As String, ByRef MIDIOutput1 As MidiOutput)
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Dim backupelement As Integer
Call MidiStackPushCommon(backupelement, MidiOutput)
If Len(Trim$(cStreamName)) = 0 Then Err.Raise 1, , "missing name"
If mStreamNumber = 0 Then
MidiOutput.StreamNumber = mStreamNumber
MidiOutput.StreamName = cStreamName
If MidiOutput.StreamNumberTotal = MidiOutput.StreamNumberMax Then Err.Raise 1, , "too many streams"
MidiOutput.ActionStream = MIDIOUT_OPEN
mStreamNumber = MidiOutput.StreamNumber
End If
MidiOutput.StreamNumber = mStreamNumber
If MIDIOutput1.StateStreamEx(0) = MIDISTATE_CLOSED Then Err.Raise 1, , "" ' old stream is specified but not open properly ?
If MIDIOutput1.StreamName = "" Then Err.Raise 1, , ""
ExitSection:
Call MidiStackPopCommon(backupelement, MIDIOutput1)
Exit Sub
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Sub
Private Sub WaitSortStream(ByVal mStreamNumber As Integer)
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Dim mCount As Integer
Dim nMessageUBound As Long
Dim mStateSortStreamPercent As Long
Dim backupstreamnumber As Integer
backupstreamnumber = MidiOutput.StreamNumber ' alternative
MidiOutput.StreamNumber = mStreamNumber
nMessageUBound = MidiOutput.StreamMessageUBound
MidiOutput.StreamNumber = backupstreamnumber ' not needed anymore
mCount = 0
Do While MidiOutput.StateSortStreamEx(mStreamNumber) <> MIDISTATE_CLOSED
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Sleep MB_DOEVENTSPOLLING ' release resources enough so <5% cpu usage
If Int(mCount / 10) = mCount / 10 Then ' interval = 10 * MB_DOEVENTSPOLLING
mStateSortStreamPercent = MidiOutput.StateSortStreamPercentEx(mStreamNumber) ' may sort logarithmically slower
mCount = 0 ' reset so not overflow
End If
mCount = mCount + 1
Loop
ExitSection:
Exit Sub
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Sub
Private Sub QueueSong_ByMidi1Track()
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Dim i As Long
Dim backupscreenmousepointer As Integer
Dim backupstreammessagenumbermax As Long
Dim mGroupNumber As Integer
Dim mStreamNumber As Integer
Dim nLo As Long
Dim nHi As Long
Dim isEmpty As Boolean
Dim mTrackPhysical As Integer
Dim mTrackLogical As Integer
Dim isTrackMute As Boolean
Dim m As Long
Dim nMessageCount As Long
Dim nMessageTotal As Long
Dim mR As Long
Dim mC As Long
Dim MIDIOutput1_MP(0 To MIDIMP_UBOUND) As Long ' always start from zero
Dim nMP As Long
Dim tempmessage As Integer
Dim tempdata1 As Integer
Dim tempdata2 As Integer
Dim temptime As Long
Dim tempmessagetag As Long
Dim tempmessagestate As Integer
Dim templogonly As Boolean
Dim mMsgFF81TempoCount As Integer
Dim mMsgFF88TPQCount As Integer
Dim mMsgFF81TempoCountMax As Integer
Dim mMsgFF88TPQCountMax As Integer
Dim arMsgFF81Tempo() As Long
Dim arMsgFF88TPQ() As Long
Const MB_DIMENSION1UBOUND = 3
Const MB_TICK = 1
Const MB_VALUE = 2
Const MB_TICKNEXT = 3
Dim backuptempo As Long
Dim backupticksperquarternote As Integer
Dim backupnumerator As Integer
Dim backupdenominator As Integer
Dim dTicksPerMillisecond As Double
Dim nTicksBetweenEvents As Long
Dim nTicksRemaining As Long
Dim nMillisecondsBetweenEvents As Long
Dim nStreamTimeCurrent As Long
Dim nStreamTicksCurrent As Long
Dim isTrackTicks As Boolean
Dim nStreamTimeStart As Long
Dim isGlobal As Boolean
Dim isMsgFF81TempoChange As Boolean
Dim isMsgFF88TPQChange As Boolean
Dim isSortOutOfOrder As Boolean
Dim nStartRelativeToStream As Long
Dim nCurrentRelativeToStream As Long
Dim dTimeDifferenceOld As Double
Dim dTimeDifference100 As Double
Dim dTimeDifferenceNew As Double
Dim dTempo As Double
Dim nTempoCurrent As Long
Dim nTempoPrevious As Long
Dim isProcessTempo As Boolean
If (MidiFile.FileName = "") Then GoTo ExitEnd
Dim backupelement As Integer
Call MidiStackPushCommon(backupelement, MidiOutput)
backupscreenmousepointer = Screen.MousePointer
Screen.MousePointer = 11
ReDim MainStreamGroup(MidiFile.NumberOfTracks + 1, 2) ' 1-based scale, plus master track
If UBound(MainStreamGroup, 1) = 0 Then Err.Raise 1, , "Missing stream number."
For mGroupNumber = 1 To UBound(MainStreamGroup, 1)
isEmpty = False
If mGroupNumber <= MidiFile.NumberOfTracks Then
MidiFile.TrackNumber = mGroupNumber
If MidiFile.MessageCount = 0 Then
' empty track
isEmpty = True
End If
Else
' master track used as is
End If
MainStreamGroup(mGroupNumber, MB_STREAMEMPTY) = isEmpty
'If isEmpty = False Then ' skip if empty, but too complicated to handle later
mStreamNumber = 0 ' new stream
Call OpenQueueStream(mStreamNumber, MB_STREAMNAME_1, MidiOutput)
MainStreamGroup(mGroupNumber, MB_STREAMNUMBER) = mStreamNumber
MidiOutput.StreamNumber = mStreamNumber
' Clear any data if stream not new
MidiOutput.ActionStream = MIDIOUT_RESET
' Total for reference.
' Incl. global track, master track and empty track.
NumberOfTracks = Trim$(Str$(Val(NumberOfTracks) + 1))
Next mGroupNumber
' Get statistics
nMessageTotal = 0
backupstreammessagenumbermax = MidiOutput.StreamMessageNumberMax
For m = 1 To MidiFile.NumberOfTracks
MidiFile.TrackNumber = m
nMessageTotal = nMessageTotal + MidiFile.MessageCount
Next m
'Me.Caption = "MFPlayer Example - Loading - " & Trim$(Str$(Int(100 * nMessageCount / nMessageTotal))) & "%"
' Get global tags for reference.
' Assume in one track if midi file format 0.
' Assume in first track if midi file format 1. May be in others but not standard.
'{
' Get tempo info
MidiFile.TrackNumber = 1
MidiFile.MessageNumber = 0
backuptempo = MidiFile.Tempo
backupticksperquarternote = MidiFile.TicksPerQuarterNote
backupnumerator = MidiFile.Numerator
backupdenominator = 2 ^ MidiFile.Denominator
If backuptempo = 0 Then backuptempo = 600000 ' assume 100 beats per minute (tempo/2 = beats*2)
If backupticksperquarternote = 0 Then backupticksperquarternote = 480 ' assume 100 beats per minute
If backupnumerator = 0 Then backupnumerator = 4 ' assume time signature 4/4
If backupdenominator = 0 Then backupdenominator = 4
dTicksPerMillisecond = (CDbl(backupticksperquarternote) / CDbl(backuptempo)) * 1000#
ReDim arMsgFF81Tempo(MB_DIMENSION1UBOUND, 0 To 1000)
ReDim arMsgFF88TPQ(MB_DIMENSION1UBOUND, 0 To 1000)
mMsgFF81TempoCount = 0
arMsgFF81Tempo(MB_TICK, mMsgFF81TempoCount) = 0 ' tick zero
arMsgFF81Tempo(MB_VALUE, mMsgFF81TempoCount) = backuptempo
arMsgFF81Tempo(MB_TICKNEXT, mMsgFF81TempoCount) = 0 ' not yet
mMsgFF88TPQCount = 0
arMsgFF88TPQ(MB_TICK, mMsgFF88TPQCount) = 0 ' tick zero
arMsgFF88TPQ(MB_VALUE, mMsgFF88TPQCount) = backupticksperquarternote
arMsgFF88TPQ(MB_TICKNEXT, mMsgFF88TPQCount) = 0 ' not yet
nMessageCount = 0
isSortOutOfOrder = False
For mTrackPhysical = 1 To MidiFile.NumberOfTracks ' 1-based scale
MidiFile.TrackNumber = mTrackPhysical ' 1-based scale (first is global, second is track one)
mTrackLogical = mTrackPhysical - 1 ' 0-based scale (zero is global, first is track one)
nStreamTicksCurrent = 0
For m = 1 To MidiFile.MessageCount ' 1-based scale
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
MidiFile.MessageNumber = m ' 1-based scale
nTicksBetweenEvents = MidiFile.time
nStreamTicksCurrent = nStreamTicksCurrent + nTicksBetweenEvents ' always ticks, no rounding
tempmessage = MidiFile.Message
tempdata1 = MidiFile.Data1
If tempmessage <> META Then 'ignore
ElseIf tempdata1 = META_TEMPO Then ' tempo
mMsgFF81TempoCount = mMsgFF81TempoCount + 1
If mMsgFF81TempoCount > UBound(arMsgFF81Tempo, 2) Then _
ReDim Preserve arMsgFF81Tempo(MB_DIMENSION1UBOUND, UBound(arMsgFF81Tempo, 2) + 100) ' more space
arMsgFF81Tempo(MB_TICK, mMsgFF81TempoCount) = nStreamTicksCurrent
arMsgFF81Tempo(MB_VALUE, mMsgFF81TempoCount) = MidiFile.Tempo
arMsgFF81Tempo(MB_TICKNEXT, mMsgFF81TempoCount) = 0 ' not yet
arMsgFF81Tempo(MB_TICKNEXT, mMsgFF81TempoCount - 1) = nStreamTicksCurrent ' save for reference
If arMsgFF81Tempo(MB_TICK, mMsgFF81TempoCount) < arMsgFF81Tempo(MB_TICK, mMsgFF81TempoCount - 1) Then _
isSortOutOfOrder = True ' when message not in first track
ElseIf tempdata1 = 88 Then ' time sig
mMsgFF88TPQCount = mMsgFF88TPQCount + 1
If mMsgFF88TPQCount > UBound(arMsgFF88TPQ, 2) Then _
ReDim Preserve arMsgFF88TPQ(MB_DIMENSION1UBOUND, UBound(arMsgFF88TPQ, 2) + 100) ' more space
arMsgFF88TPQ(MB_TICK, mMsgFF88TPQCount) = nStreamTicksCurrent
arMsgFF88TPQ(MB_VALUE, mMsgFF88TPQCount) = MidiFile.TicksPerQuarterNote
arMsgFF88TPQ(MB_TICKNEXT, mMsgFF88TPQCount) = 0 ' not yet
arMsgFF88TPQ(MB_TICKNEXT, mMsgFF88TPQCount - 1) = nStreamTicksCurrent ' save for reference
If arMsgFF88TPQ(MB_TICK, mMsgFF88TPQCount) < arMsgFF88TPQ(MB_TICK, mMsgFF88TPQCount - 1) Then _
isSortOutOfOrder = True ' when message not in first track
End If
nMessageCount = nMessageCount + 1
If nMessageCount = backupstreammessagenumbermax Then Exit For ' reached limit
Next m
If nMessageCount = backupstreammessagenumbermax Then Exit For ' reached limit
Next mTrackPhysical
mMsgFF81TempoCountMax = mMsgFF81TempoCount
mMsgFF88TPQCountMax = mMsgFF88TPQCount
If isSortOutOfOrder = True Then
SortArray arMsgFF81Tempo _
, mDimensionToSort:=2, mPositionToSort:=MB_TICK, mSecondaryPositionToSort:=0 _
, nLo:=LBound(arMsgFF81Tempo, 2), nHi:=mMsgFF81TempoCountMax, isSortValue:=True _
, mDimensionX:=2
SortArray arMsgFF88TPQ _
, mDimensionToSort:=2, mPositionToSort:=MB_TICK, mSecondaryPositionToSort:=0 _
, nLo:=LBound(arMsgFF88TPQ, 2), nHi:=mMsgFF88TPQCountMax, isSortValue:=True _
, mDimensionX:=2
End If
nMessageCount = 0
For mTrackPhysical = 1 To MidiFile.NumberOfTracks ' 1-based scale
MidiFile.TrackNumber = mTrackPhysical ' 1-based scale (first is global, second is track one)
mTrackLogical = mTrackPhysical - 1 ' 0-based scale (zero is global, first is track one)
mGroupNumber = mTrackPhysical ' 1-based scale (zero is none, first is global, second is track one, last is master track)
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
isTrackMute = False
If isTrackMute = False Then
nStreamTicksCurrent = 0
nStreamTimeCurrent = 0
nStreamTimeStart = 0
nTempoPrevious = backuptempo
mMsgFF81TempoCount = 0
mMsgFF88TPQCount = 0
For m = 1 To MidiFile.MessageCount ' 1-based scale
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
MidiFile.MessageNumber = m ' 1-based scale
' Get next time
nTicksRemaining = MidiFile.time
' Insert global messages, if any
' if occurs before next message.
Do
' Assume not scan entire array for tempo since sequential and sorted.
isGlobal = False
isMsgFF81TempoChange = False
isMsgFF88TPQChange = False
If mMsgFF81TempoCount <> mMsgFF81TempoCountMax _
And nStreamTicksCurrent + nTicksRemaining >= arMsgFF81Tempo(MB_TICKNEXT, mMsgFF81TempoCount) Then
isGlobal = True
isMsgFF81TempoChange = True
mMsgFF81TempoCount = mMsgFF81TempoCount + 1
nTicksBetweenEvents = arMsgFF81Tempo(MB_TICK, mMsgFF81TempoCount) - nStreamTicksCurrent
ElseIf mMsgFF88TPQCount <> mMsgFF88TPQCountMax _
And nStreamTicksCurrent + nTicksRemaining >= arMsgFF88TPQ(MB_TICKNEXT, mMsgFF88TPQCount) Then
isGlobal = True
isMsgFF88TPQChange = True
mMsgFF88TPQCount = mMsgFF88TPQCount + 1
nTicksBetweenEvents = arMsgFF88TPQ(MB_TICK, mMsgFF88TPQCount) - nStreamTicksCurrent
End If
If isGlobal = False Then Exit Do ' none
' Get time
' Assuming all previous ticks were for one tempo only.
' Assuming shifting start time already compensated for.
' Assume tracking ticks is more accurate than tracking time.
nStreamTicksCurrent = nStreamTicksCurrent + nTicksBetweenEvents ' always ticks, no rounding
nStreamTimeCurrent = Round(nStreamTicksCurrent / dTicksPerMillisecond, 0) ' ticks to time
' Adjust for changes in tempo.
If isMsgFF81TempoChange = True Then
' New start time.
' Shift start time to compensate based on
' current time and tempo rate.
'{
' estimated message current time
nStartRelativeToStream = 0
nCurrentRelativeToStream = nStreamTimeCurrent
dTimeDifferenceOld = nCurrentRelativeToStream - nStartRelativeToStream
' get estimated current message time back to 100% tempo
' already determined
dTempo = CDbl(nTempoPrevious) / 600000# * 100# ' percent
dTimeDifference100 = dTimeDifferenceOld _
* (1# / (dTempo / 100#))
' 1/x from other to 100%
' get estimated starting time of new stream
nTempoCurrent = arMsgFF81Tempo(MB_VALUE, mMsgFF81TempoCount)
dTempo = CDbl(nTempoCurrent) / 600000# * 100# ' percent
dTimeDifferenceNew = dTimeDifference100 _
* (1# * (dTempo / 100#))
' 1*x from 100% to other
nStartRelativeToStream = nCurrentRelativeToStream - dTimeDifferenceNew
nStreamTimeStart = nStreamTimeStart + nStartRelativeToStream
nTempoPrevious = nTempoCurrent
'}
' New tempo.
dTicksPerMillisecond = (CDbl(arMsgFF88TPQ(MB_VALUE, mMsgFF88TPQCount)) / CDbl(nTempoCurrent)) * 1000#
'dTicksPerMillisecond = (CDbl(backupticksperquarternote) / CDbl(backuptempo)) * 1000# ' not applicable
ElseIf isMsgFF88TPQChange = True Then
' New time signature.
' Change tick scale but not speed of music.
nTempoCurrent = arMsgFF81Tempo(MB_VALUE, mMsgFF81TempoCount)
dTicksPerMillisecond = (CDbl(arMsgFF88TPQ(MB_VALUE, mMsgFF88TPQCount)) / CDbl(nTempoCurrent)) * 1000#
'dTicksPerMillisecond = (CDbl(backupticksperquarternote) / CDbl(backuptempo)) * 1000# ' not applicable
End If
nTicksRemaining = nTicksRemaining - nTicksBetweenEvents
'Exit Do
Loop
' Get next message
' store in variables for speed
tempmessagestate = MIDIMESSAGESTATE_ENABLED
templogonly = False
tempmessage = MidiFile.Message
tempdata1 = MidiFile.Data1
tempdata2 = MidiFile.Data2
' Tag notes to play on keyboard and VU meters
tempmessagetag = 0
If (tempmessage And &HF0) = NOTE_ON And tempdata2 <> 0 Then
tempmessagetag = tempdata2 + 1& + (mTrackLogical * 1000&)
End If
' Get next time
' Assuming all previous ticks were for one tempo only.
' Assuming shifting start time already compensated for different tempos.
nTicksBetweenEvents = nTicksRemaining
nStreamTicksCurrent = nStreamTicksCurrent + nTicksBetweenEvents ' always ticks, no rounding
nStreamTimeCurrent = Round(nStreamTicksCurrent / dTicksPerMillisecond, 0) ' ticks to time
temptime = nStreamTimeStart + nStreamTimeCurrent
' Get buffer (no temporary variable for speed)
If tempmessage = SYSEX Then ' SYSEX message
MidiOutput.buffer = Chr(SYSEX) & MidiFile.buffer
End If
' Queue with MessagePointer
MIDIOutput1_MP(MIDIMP_MESSAGESTATE) = tempmessagestate
MIDIOutput1_MP(MIDIMP_MESSAGE) = tempmessage
MIDIOutput1_MP(MIDIMP_DATA1) = tempdata1
MIDIOutput1_MP(MIDIMP_DATA2) = tempdata2
MIDIOutput1_MP(MIDIMP_TIME) = temptime
MIDIOutput1_MP(MIDIMP_MESSAGETAG) = tempmessagetag
MidiOutput.MessagePointer(MIDIOutput1_MP(0), UBound(MIDIOutput1_MP)) = 0
MidiOutput.MessageLogOnly = templogonly
' Add to output queue
MidiOutput.StreamMessageNumber = 0 ' append
MidiOutput.ActionStream = MIDIOUT_QUEUE
nMessageCount = nMessageCount + 1
If MidiOutput.StreamMessageNumber = backupstreammessagenumbermax Then Exit For ' reached limit
Next m
End If ' isTrackMute
If MidiOutput.StreamMessageNumber = backupstreammessagenumbermax Then Exit For ' reached limit
Next mTrackPhysical
mGroupNumber = UBound(MainStreamGroup, 1) ' last is master track
MainStreamGroup(mGroupNumber, MB_STREAMNUMBER) = mGroupNumber
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
' First message to describe stream for reference (optional)
MidiOutput.MessageState = MIDIMESSAGESTATE_ENABLED
MidiOutput.MessageLogOnly = True
MidiOutput.Message = META
MidiOutput.Data1 = META_MARKER ' pass type of marker (0 to 255)
MidiOutput.Data2 = 0 ' pass information (optional)
MidiOutput.buffer = "built at, " & time
MidiOutput.time = 0
MidiOutput.MessageTag = 0
MidiOutput.StreamMessageNumber = 0 ' append
MidiOutput.ActionStream = MIDIOUT_QUEUE
nLo = 0
nHi = 0
For mGroupNumber = 1 To UBound(MainStreamGroup, 1)
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
' Find common range in time.
If MidiOutput.StreamMessageLastTime(1) > nHi Then _
nHi = MidiOutput.StreamMessageLastTime(1)
Next mGroupNumber
For mGroupNumber = 1 To UBound(MainStreamGroup, 1)
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
MidiOutput.MessageState = MIDIMESSAGESTATE_ENABLED
MidiOutput.MessageLogOnly = True
MidiOutput.Message = META
MidiOutput.Data1 = META_MARKER ' pass type of marker (0 to 255)
MidiOutput.Data2 = 0 ' pass information (optional)
MidiOutput.buffer = "Lowest time"
MidiOutput.time = nLo
MidiOutput.MessageTag = 0
MidiOutput.StreamMessageNumber = 0 ' append
MidiOutput.ActionStream = MIDIOUT_QUEUE
MidiOutput.buffer = "Highest time"
MidiOutput.time = nHi
MidiOutput.StreamMessageNumber = 0 ' append
MidiOutput.ActionStream = MIDIOUT_QUEUE
Next mGroupNumber
''''''''''''''''''''''''''''''''''''''''''''''
' Sort stream
''''''''''''''''''''''''''''''''''''''''''''''
For mGroupNumber = 1 To UBound(MainStreamGroup, 1)
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
If MidiOutput.StreamMessageSortOutOfOrder = False Then ' already queuesort
ElseIf MidiOutput.StateStreamEx(0) = MIDISTATE_STARTED Then ' can only autosort
Debug.Print "PROGRAM WARNING 21095, autosort"
Else ' manualsort
Call MidiOutput.SortStreamEx(MidiOutput.StreamNumber, 1) ' modeless
Call WaitSortStream(MidiOutput.StreamNumber)
End If
If MidiOutput.StreamMessageSortOutOfOrder = True Then ' should have been sorted
Err.Raise 1, , "PROGRAM ERROR 3276"
End If
Next mGroupNumber
HScrollPlayerTime.max = nHi / 1000
Runtime = Round(nHi / 1000)
ExitSection:
Screen.MousePointer = 0 ' backupscreenmousepointer
Call MidiStackPopCommon(backupelement, MidiOutput)
Exit Sub
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Sub
Public Sub StartPlay()
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
If MidiOutput.State = MIDISTATE_CLOSED Then GoTo ExitEnd ' not needed at close
Dim mGroupNumber As Integer
Dim nTime As Long
Dim backupelement As Integer
Call MidiStackPushCommon(backupelement, MidiOutput)
If MainStreamOption <> MB_OPTIONOPENDEFAULT Then
If MainStreamNumber <> 0 Then
MidiOutput.StreamNumber = MainStreamNumber
If MidiOutput.StateStreamEx(0) = MIDISTATE_CLOSED Then ' no stream
ElseIf MidiOutput.StateStreamEx(0) <> MIDISTATE_STARTED Then
MidiOutput.FilterLateEventStreamMax = True ' may filter notes
MidiOutput.StreamTimeStartRelativeToOpen = MidiOutput.TimeRelativeToOpen - HScrollPlayerTime.Value * MB_HSCROLLTIMESCALEOFFSET * (MidiOutput.StreamTempoRate / 100)
MidiOutput.ActionStream = MIDIOUT_START
End If
End If
Else
For mGroupNumber = 1 To UBound(MainStreamGroup, 1)
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
If MidiOutput.StateStreamEx(0) = MIDISTATE_CLOSED Then ' no stream
ElseIf MidiOutput.StateStreamEx(0) <> MIDISTATE_STARTED Then
MidiOutput.FilterLateEventStreamMax = True ' may filter notes
If nTime = 0 Then ' get once, same for all streams
nTime = MidiOutput.TimeRelativeToOpen - HScrollPlayerTime.Value * MB_HSCROLLTIMESCALEOFFSET * (MidiOutput.StreamTempoRate / 100)
End If
MidiOutput.StreamTimeStartRelativeToOpen = nTime
MidiOutput.ActionStream = MIDIOUT_START
End If
Next mGroupNumber
End If
State = AdioPlaying
RaiseEvent StartPlay
RaiseEvent Playing
Timer_Playing.Enabled = True
ExitSection:
Call MidiStackPopCommon(backupelement, MidiOutput)
Exit Sub
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Sub
Public Sub StopPlay()
If Not State = AdioPlaying Then: Exit Sub
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
If MidiOutput.State = MIDISTATE_CLOSED Then GoTo ExitEnd ' not needed at close
Dim mGroupNumber As Integer
Dim isStop As Boolean
Dim backupelement As Integer
Call MidiStackPushCommon(backupelement, MidiOutput)
If MainStreamOption <> MB_OPTIONOPENDEFAULT Then
If MainStreamNumber <> 0 Then
MidiOutput.StreamNumber = MainStreamNumber
If MidiOutput.StateStreamEx(0) = MIDISTATE_CLOSED Then ' no stream
Else
MidiOutput.ActionStream = MIDIOUT_STOP
Call StopStuckNote
'Call ClearScrollBar
End If
End If
Else
isStop = False
For mGroupNumber = 1 To UBound(MainStreamGroup, 1)
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
If MidiOutput.StateStreamEx(0) = MIDISTATE_CLOSED Then ' no stream
Else
MidiOutput.ActionStream = MIDIOUT_STOP
Call StopStuckNote
isStop = True
End If
Next mGroupNumber
If isStop = True Then
Call StopStuckNote ' do again in case some streams were still processing
End If
End If
State = AdioStopped
RaiseEvent Stopped
HScrollPlayerTime.Value = 0
Timer_Playing.Enabled = False
ExitSection:
Call MidiStackPopCommon(backupelement, MidiOutput)
Exit Sub
ExitEnd: '
End Sub
Public Sub PausePlay()
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
If MidiOutput.State = MIDISTATE_CLOSED Then GoTo ExitEnd ' not needed at close
Dim mGroupNumber As Integer
Dim isPause As Boolean
Dim nTime As Long
Dim backupmessageventpause As Boolean
' Preserve passed data so not interfere with other functions
Dim backupelement As Integer
Call MidiStackPushCommon(backupelement, MidiOutput)
If MainStreamOption <> MB_OPTIONOPENDEFAULT Then
' Midi format 0
If MainStreamNumber <> 0 Then
MidiOutput.StreamNumber = MainStreamNumber
If MidiOutput.StateStreamEx(0) = MIDISTATE_CLOSED Then ' no stream
ElseIf MidiOutput.StateStreamEx(0) = MIDISTATE_STARTED Then ' started
MidiOutput.ActionStream = MIDIOUT_PAUSE
Call StopStuckNote
ElseIf MidiOutput.StateStreamEx(0) = MIDISTATE_STOPPED And MidiOutput.StreamTimeCurrent = 0 Then
' Start from stop with same pause button
' (not practical)
ElseIf MidiOutput.StateStreamEx(0) = MIDISTATE_STOPPED And MidiOutput.StreamTimeCurrent > 0 Then
MidiOutput.FilterLateEventStreamMax = True ' may filter notes
MidiOutput.ActionStream = MIDIOUT_START
End If
End If
Else
' Midi format 1
isPause = False
' Pause all streams at exact same time.
backupmessageventpause = MidiOutput.MessageEventPause
If MidiOutput.State <> MIDISTATE_CLOSED Then _
MidiOutput.MessageEventPause = True
For mGroupNumber = 1 To UBound(MainStreamGroup, 1)
MidiOutput.StreamNumber = MainStreamGroup(mGroupNumber, MB_STREAMNUMBER)
If MidiOutput.StateStreamEx(0) = MIDISTATE_CLOSED Then ' no stream
ElseIf MidiOutput.StateStreamEx(0) = MIDISTATE_STARTED Then ' started
' Pause from start
MidiOutput.ActionStream = MIDIOUT_PAUSE
Call StopStuckNote
isPause = True
ElseIf MidiOutput.StateStreamEx(0) = MIDISTATE_STOPPED And MidiOutput.StreamTimeCurrent = 0 Then
' Start from stop with same pause button
' (not practical)
ElseIf MidiOutput.StateStreamEx(0) = MIDISTATE_STOPPED And MidiOutput.StreamTimeCurrent > 0 Then
MidiOutput.FilterLateEventStreamMax = True ' may filter notes
If nTime = 0 Then ' get once, same for all streams
End If
MidiOutput.ActionStream = MIDIOUT_START
End If
Next mGroupNumber
If isPause = True Then Call StopStuckNote ' do again in case some streams were still processing
If MidiOutput.State <> MIDISTATE_CLOSED Then MidiOutput.MessageEventPause = backupmessageventpause ' restore
End If
State = AdioPaused
RaiseEvent Paused
ExitSection:
Call MidiStackPopCommon(backupelement, MidiOutput)
Exit Sub
ExitEnd: ' prevent multithreading issues caused by doevents or background processes
End Sub
Public Sub SeekBySeconds(Direction As enumAdioSeekDirection, Optional Seconds As Integer = 10)
Select Case Direction
Case enumAdioSeekDirection.AdioForward
HScrollPlayerTime.Value = HScrollPlayerTime.Value + Seconds
Case enumAdioSeekDirection.AdioRewind
If Seconds > HScrollPlayerTime.Value Then: Exit Sub
HScrollPlayerTime.Value = HScrollPlayerTime.Value - Seconds
End Select
Call ScrollBarPlayerTime_Forward0Common
End Sub
Public Sub InitComponent(DeviceId As Integer)
If MidiOutput.State <> MIDISTATE_CLOSED Then Call UnloadComponent
MidiOutput.DeviceId = DeviceId
MidiOutput.action = MIDIOUT_OPEN
If MidiOutput.ErrorCode = 0 Then: RaiseEvent Ready
State = AdioReady
End Sub
Private Sub UnloadComponent()
If MidiOutput.State <> MIDISTATE_CLOSED Then
StopPlay ' clear any stuck notes
MidiOutput.action = MIDIOUT_CLOSE
End If
End Sub
Public Function GetListOfMidiDevices() As Collection
Dim i As Integer
Dim MidiDevice As mdlAdioMidiDevice
Dim ListOfDevices As New Collection
For i = -1 To MidiOutput.DeviceCount - 1
Set MidiDevice = New mdlAdioMidiDevice
MidiOutput.DeviceId = i
MidiDevice.mId = i + 1
MidiDevice.mName = MidiOutput.ProductName
ListOfDevices.Add MidiDevice
Next i
Set GetListOfMidiDevices = ListOfDevices
End Function
Public Sub LoadFile(File As String)
MidiFile.action = MIDIFILE_CLOSE
MidiFile.ReadOnly = True
MidiFile.FileName = File
MidiFile.action = MIDIFILE_OPEN
Call DisplayTrackNames
Call QueueSong_ByMidi1Track
HScrollPlayerTime.Value = 0
MainStreamOption = 0
LoadedFile = File
RaiseEvent NewMediaFile(File)
End Sub
Private Sub MidiOutput_StreamSend()
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Dim MessageTag(TOTAL_MIDI_CHANNELS) As Long
Dim TrackNumber As Integer
Dim Intensity As Integer
Dim Channel As Integer
Dim m As Integer
Dim nTime As Long
Dim nTimeRelToTempo As Long
'
' Get last messagetag in each channel
'
nTime = MidiOutput.SendTime ' initialize
nTimeRelToTempo = MidiOutput.SendTimeRelativeToTempo ' initialize
Do While MidiOutput.MessageCount > 0 ' (optional)
If gisEnd = True Then GoTo ExitEnd ' not needed at shutdown
Channel = (MidiOutput.SendMessage And &HF) + 1
If MidiOutput.SendMessageTag = 0 Then ' no tag
ElseIf MidiOutput.SendMessageTag < MessageTag(Channel) Then ' not a peak
Else
' Overwrite and discard old message tags, if any
MessageTag(Channel) = MidiOutput.SendMessageTag
End If
' Track oldest message to reflect in scroll bar
' (optional)
If MidiOutput.SendTime < nTime Then nTime = MidiOutput.SendTime
If MidiOutput.SendTimeRelativeToTempo < nTimeRelToTempo Then nTimeRelToTempo = MidiOutput.SendTimeRelativeToTempo
MidiOutput.ActionStream = MIDIOUT_REMOVE
Loop
TimeExpectedMessage = nTime
TimeExpectedMessageRelToTempo = nTimeRelToTempo
For Channel = 1 To TOTAL_MIDI_CHANNELS
If MessageTag(Channel) = 0 Then ' no tag
ElseIf (MessageTag(Channel) < 0) Or (MessageTag(Channel) >= 32000) Then ' not applicable
Else
Intensity = MessageTag(Channel) Mod 1000
TrackNumber = Int(MessageTag(Channel) / 1000)
TrackNumber = TrackNumber + 1 ' restore to 1-based scale to match other arrays