├── .gitignore ├── .hg_archival.txt ├── .hgignore ├── .hgtags ├── CircBuf.pas ├── Debug App ├── MIDI_IO_Debug.bdsproj ├── MIDI_IO_Debug.dpr ├── MIDI_IO_Debug.dproj ├── MIDI_IO_Debug.exe.manifest ├── MIDI_IO_Debug.res ├── frmMain.dfm └── frmMain.pas ├── Examples ├── MidiMon.dpr ├── MidiMon.res ├── MidiMonP.dfm ├── MidiMonP.pas ├── MidiTest.dfm ├── MidiTest.pas ├── MonProcs.pas ├── MultiMNP.dfm ├── MultiMNP.pas ├── MultiMon.dpr ├── MultiMon.res ├── Project1.dpr └── Project1.res ├── MidiCallback.pas ├── MidiCons.pas ├── MidiDefs.pas ├── MidiDeviceComboBox.pas ├── MidiEventStreamer.pas ├── MidiFile.pas ├── MidiIn.pas ├── MidiKeyPatchArray.pas ├── MidiOut.pas ├── MidiScope.pas ├── MidiType.pas ├── Package ├── MidiComponents2010.dpk ├── MidiComponents2010.dproj ├── MidiComponents2010.res ├── MidiFile.dcr ├── MidiIn.dcr ├── MidiOut.dcr └── MidiScope.dcr └── README.txt /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | -------------------------------------------------------------------------------- /.hg_archival.txt: -------------------------------------------------------------------------------- 1 | repo: c350e3dc474ef370f51e1983e1df561c3569e037 2 | node: bc2dc727d9759e565c7768041d83769fd2726ebe 3 | branch: default 4 | latesttag: v7.0r4 5 | latesttagdistance: 1 6 | changessincelatesttag: 1 7 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | glob:__history 2 | glob:*.local 3 | glob:*.exe 4 | glob:*.dcu 5 | glob:*.identcache -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | 8d09d73d0782472a7b69a2e2333e749b74fa6c62 v7.0r1 2 | f5ed113bb8a80a212a55d1592ed3d3eec95a44ac v7.0r2 3 | c57e85e8068426b0ad24859a0d71577d62dc3591 7.0r3 4 | 812f8a26a1434f6c9780c115e356c6d85ff13978 v7.0r4 5 | -------------------------------------------------------------------------------- /CircBuf.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/CIRCBUF.PAS 2 10/06/97 7:33 Davec $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | (** 7 | * CircBuf.pas v2010-05r1 8 | **) 9 | 10 | (* ***** BEGIN LICENSE BLOCK ***** 11 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 12 | * 13 | * The contents of this file are subject to the Mozilla Public License Version 14 | * 1.1 (the "License"); you may not use this file except in compliance with 15 | * the License. You may obtain a copy of the License at 16 | * http://www.mozilla.org/MPL/ 17 | * 18 | * Software distributed under the License is distributed on an "AS IS" basis, 19 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 20 | * for the specific language governing rights and limitations under the 21 | * License. 22 | * 23 | * The Original Code is FIFO circular buffer. 24 | * 25 | * The Initial Developer of the Original Code is 26 | * David Churcher . 27 | * Portions created by the Initial Developer are Copyright (C) 1997 28 | * the Initial Developer. All Rights Reserved. 29 | * 30 | * Contributor(s): 31 | * Manuel Kroeber 32 | * 33 | * Alternatively, the contents of this file may be used under the terms of 34 | * either the GNU General Public License Version 3 or later (the "GPL"), or 35 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 36 | * in which case the provisions of the GPL or the LGPL are applicable instead 37 | * of those above. If you wish to allow use of your version of this file only 38 | * under the terms of either the GPL or the LGPL, and not to allow others to 39 | * use your version of this file under the terms of the MPL, indicate your 40 | * decision by deleting the provisions above and replace them with the notice 41 | * and other provisions required by the GPL or the LGPL. If you do not delete 42 | * the provisions above, a recipient may use your version of this file under 43 | * the terms of any one of the MPL, the GPL or the LGPL. 44 | * 45 | * ***** END LICENSE BLOCK ***** *) 46 | 47 | 48 | { A First-In First-Out circular buffer. 49 | Port of circbuf.c from Microsoft's Windows MIDI monitor example. 50 | I did do a version of this as an object (see Rev 1.1) but it was getting too 51 | complicated and I couldn't see any real benefits to it so I dumped it 52 | for an ordinary memory buffer with pointers. 53 | 54 | This unit is a bit C-like, everything is done with pointers and extensive 55 | use is made of the undocumented feature of the Inc() function that 56 | increments pointers by the size of the object pointed to. 57 | All of this could probably be done using Pascal array notation with 58 | range-checking turned off, but I'm not sure it's worth it. 59 | } 60 | 61 | Unit CircBuf; 62 | 63 | interface 64 | 65 | Uses Windows, MMSystem; 66 | 67 | type 68 | {$IFNDEF WIN32} 69 | { API types not defined in Delphi 1 } 70 | DWORD = Longint; 71 | HGLOBAL = THandle; 72 | UINT = Word; 73 | TFNTimeCallBack = procedure(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD); 74 | {$ENDIF} 75 | 76 | { MIDI input event } 77 | TMidiBufferItem = record 78 | timestamp: DWORD; { Timestamp in milliseconds after midiInStart } 79 | data: DWORD; { MIDI message received } 80 | sysex: PMidiHdr; { Pointer to sysex MIDIHDR, nil if not sysex } 81 | end; 82 | PMidiBufferItem = ^TMidiBufferItem; 83 | 84 | { MIDI input buffer } 85 | TCircularBuffer = record 86 | RecordHandle: HGLOBAL; { Windows memory handle for this record } 87 | BufferHandle: HGLOBAL; { Windows memory handle for the buffer } 88 | pStart: PMidiBufferItem; { ptr to start of buffer } 89 | pEnd: PMidiBufferItem; { ptr to end of buffer } 90 | pNextPut: PMidiBufferItem; { next location to fill } 91 | pNextGet: PMidiBufferItem; { next location to empty } 92 | Error: Word; { error code from MMSYSTEM functions } 93 | Capacity: Word; { buffer size (in TMidiBufferItems) } 94 | EventCount: Word; { Number of events in buffer } 95 | end; 96 | 97 | PCircularBuffer = ^TCircularBuffer; 98 | 99 | function GlobalSharedLockedAlloc( Capacity: Word; var hMem: HGLOBAL ): Pointer; 100 | procedure GlobalSharedLockedFree( hMem: HGLOBAL; ptr: Pointer ); 101 | 102 | function CircbufAlloc( Capacity: Word ): PCircularBuffer; 103 | procedure CircbufFree( PBuffer: PCircularBuffer ); 104 | function CircbufRemoveEvent( PBuffer: PCircularBuffer ): Boolean; 105 | function CircbufReadEvent( PBuffer: PCircularBuffer; PEvent: PMidiBufferItem ): Boolean; 106 | { Note: The PutEvent function is in the DLL } 107 | 108 | implementation 109 | 110 | { Allocates in global shared memory, returns pointer and handle } 111 | function GlobalSharedLockedAlloc( Capacity: Word; var hMem: HGLOBAL ): Pointer; 112 | var 113 | ptr: Pointer; 114 | begin 115 | { Allocate the buffer memory } 116 | hMem := GlobalAlloc(GMEM_SHARE Or GMEM_MOVEABLE Or GMEM_ZEROINIT, Capacity ); 117 | 118 | if (hMem = 0) then 119 | ptr := Nil 120 | else 121 | begin 122 | ptr := GlobalLock(hMem); 123 | if (ptr = Nil) then 124 | GlobalFree(hMem); 125 | end; 126 | 127 | Result := Ptr; 128 | end; 129 | 130 | procedure GlobalSharedLockedFree( hMem: HGLOBAL; ptr: Pointer ); 131 | begin 132 | if (hMem <> 0) then 133 | begin 134 | GlobalUnlock(hMem); 135 | GlobalFree(hMem); 136 | end; 137 | end; 138 | 139 | function CircbufAlloc( Capacity: Word ): PCircularBuffer; 140 | var 141 | NewCircularBuffer: PCircularBuffer; 142 | NewMIDIBuffer: PMidiBufferItem; 143 | hMem: HGLOBAL; 144 | begin 145 | { TODO: Validate circbuf size, <64K } 146 | NewCircularBuffer := 147 | GlobalSharedLockedAlloc( Sizeof(TCircularBuffer), hMem ); 148 | if (NewCircularBuffer <> Nil) then 149 | begin 150 | NewCircularBuffer^.RecordHandle := hMem; 151 | NewMIDIBuffer := 152 | GlobalSharedLockedAlloc( Capacity * Sizeof(TMidiBufferItem), hMem ); 153 | if (NewMIDIBuffer = Nil) then 154 | begin 155 | { TODO: Exception here? } 156 | GlobalSharedLockedFree( NewCircularBuffer^.RecordHandle, 157 | NewCircularBuffer ); 158 | NewCircularBuffer := Nil; 159 | end 160 | else 161 | begin 162 | NewCircularBuffer^.pStart := NewMidiBuffer; 163 | { Point to item at end of buffer } 164 | NewCircularBuffer^.pEnd := NewMidiBuffer; 165 | Inc(NewCircularBuffer^.pEnd, Capacity); 166 | { Start off the get and put pointers in the same position. These 167 | will get out of sync as the interrupts start rolling in } 168 | NewCircularBuffer^.pNextPut := NewMidiBuffer; 169 | NewCircularBuffer^.pNextGet := NewMidiBuffer; 170 | NewCircularBuffer^.Error := 0; 171 | NewCircularBuffer^.Capacity := Capacity; 172 | NewCircularBuffer^.EventCount := 0; 173 | end; 174 | end; 175 | CircbufAlloc := NewCircularBuffer; 176 | end; 177 | 178 | procedure CircbufFree( pBuffer: PCircularBuffer ); 179 | begin 180 | if (pBuffer <> Nil) then 181 | begin 182 | GlobalSharedLockedFree(pBuffer^.BufferHandle, pBuffer^.pStart); 183 | GlobalSharedLockedFree(pBuffer^.RecordHandle, pBuffer); 184 | end; 185 | end; 186 | 187 | { Reads first event in queue without removing it. 188 | Returns true if successful, False if no events in queue } 189 | function CircbufReadEvent( PBuffer: PCircularBuffer; PEvent: PMidiBufferItem ): Boolean; 190 | var 191 | PCurrentEvent: PMidiBufferItem; 192 | begin 193 | if (PBuffer^.EventCount <= 0) then 194 | CircbufReadEvent := False 195 | else 196 | begin 197 | PCurrentEvent := PBuffer^.PNextget; 198 | 199 | { Copy the object from the "tail" of the buffer to the caller's object } 200 | PEvent^.Timestamp := PCurrentEvent^.Timestamp; 201 | PEvent^.Data := PCurrentEvent^.Data; 202 | PEvent^.Sysex := PCurrentEvent^.Sysex; 203 | CircbufReadEvent := True; 204 | end; 205 | end; 206 | 207 | { Remove current event from the queue } 208 | function CircbufRemoveEvent(PBuffer: PCircularBuffer): Boolean; 209 | begin 210 | if (PBuffer^.EventCount > 0) then 211 | begin 212 | Dec( Pbuffer^.EventCount); 213 | 214 | { Advance the buffer pointer, with wrap } 215 | Inc( Pbuffer^.PNextGet ); 216 | If (PBuffer^.PNextGet = PBuffer^.PEnd) then 217 | PBuffer^.PNextGet := PBuffer^.PStart; 218 | 219 | CircbufRemoveEvent := True; 220 | end 221 | else 222 | CircbufRemoveEvent := False; 223 | end; 224 | 225 | end. 226 | -------------------------------------------------------------------------------- /Debug App/MIDI_IO_Debug.bdsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | MIDI_IO_Debug.dpr 14 | 15 | 16 | 7.0 17 | 18 | 19 | 8 20 | 0 21 | 1 22 | 1 23 | 0 24 | 0 25 | 1 26 | 1 27 | 1 28 | 0 29 | 0 30 | 1 31 | 0 32 | 1 33 | 0 34 | 1 35 | 0 36 | 0 37 | 0 38 | 0 39 | 0 40 | 1 41 | 0 42 | 1 43 | 1 44 | 1 45 | True 46 | True 47 | WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 48 | 49 | False 50 | 51 | True 52 | True 53 | True 54 | True 55 | True 56 | True 57 | True 58 | True 59 | True 60 | True 61 | True 62 | True 63 | True 64 | True 65 | True 66 | True 67 | True 68 | True 69 | True 70 | True 71 | True 72 | True 73 | True 74 | True 75 | True 76 | True 77 | True 78 | True 79 | True 80 | True 81 | True 82 | True 83 | True 84 | True 85 | True 86 | True 87 | True 88 | True 89 | True 90 | True 91 | True 92 | True 93 | True 94 | True 95 | True 96 | True 97 | False 98 | False 99 | False 100 | True 101 | True 102 | True 103 | True 104 | True 105 | True 106 | 107 | 108 | 109 | 0 110 | 0 111 | False 112 | 1 113 | False 114 | False 115 | False 116 | 16384 117 | 1048576 118 | 4194304 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | $(BDS)\lib\Debug;$(BDS)\Lib\Debug\Indy10 127 | 128 | 129 | 130 | False 131 | 132 | 133 | 134 | 135 | 136 | False 137 | 138 | 139 | True 140 | False 141 | 142 | 143 | 144 | $00000000 145 | 146 | 147 | 148 | True 149 | False 150 | 1 151 | 0 152 | 0 153 | 0 154 | True 155 | True 156 | False 157 | False 158 | False 159 | 1033 160 | 1252 161 | 162 | 163 | 164 | 165 | 1.0.0.0 166 | 167 | 168 | 169 | 170 | 171 | 1.0.0.0 172 | 173 | 174 | 175 | 176 | -------------------------------------------------------------------------------- /Debug App/MIDI_IO_Debug.dpr: -------------------------------------------------------------------------------- 1 | program MIDI_IO_Debug; 2 | 3 | uses 4 | Forms, 5 | frmMain in 'frmMain.pas' {FormMain}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.Title := 'MIDI I/O Debugger'; 12 | Application.CreateForm(TFormMain, FormMain); 13 | Application.Run; 14 | end. 15 | -------------------------------------------------------------------------------- /Debug App/MIDI_IO_Debug.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {F19DC442-5625-4C05-85C6-97ACD9BEFA0D} 4 | MIDI_IO_Debug.dpr 5 | Debug 6 | DCC32 7 | 12.0 8 | 9 | 10 | true 11 | 12 | 13 | true 14 | Base 15 | true 16 | 17 | 18 | true 19 | Base 20 | true 21 | 22 | 23 | $(BDS)\lib\Debug;$(BDS)\Lib\Debug\Indy10;$(DCC_UnitSearchPath) 24 | MIDI_IO_Debug.exe 25 | 00400000 26 | WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) 27 | false 28 | x86 29 | false 30 | true 31 | false 32 | 1 33 | false 34 | false 35 | 36 | 37 | false 38 | RELEASE;$(DCC_Define) 39 | 0 40 | false 41 | 42 | 43 | DEBUG;$(DCC_Define) 44 | 45 | 46 | 47 | MainSource 48 | 49 | 50 |
FormMain
51 | 52 | 53 | Base 54 | 55 | 56 | Cfg_2 57 | Base 58 | 59 | 60 | Cfg_1 61 | Base 62 | 63 | 64 | 65 | 66 | Delphi.Personality.12 67 | 68 | 69 | 70 | 71 | MIDI_IO_Debug.dpr 72 | 73 | 74 | False 75 | True 76 | False 77 | 78 | 79 | True 80 | False 81 | 1 82 | 0 83 | 0 84 | 0 85 | True 86 | True 87 | False 88 | False 89 | False 90 | 1033 91 | 1252 92 | 93 | 94 | 95 | 96 | 1.0.0.0 97 | 98 | 99 | 100 | 101 | 102 | 1.0.0.0 103 | 104 | 105 | 106 | 107 | 12 108 | 109 | 110 | -------------------------------------------------------------------------------- /Debug App/MIDI_IO_Debug.exe.manifest: -------------------------------------------------------------------------------- 1 |  2 | 3 | 8 | MIDI I/O components debug app 9 | 10 | 11 | 12 | 15 | 16 | 17 | 18 | 19 | 20 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /Debug App/MIDI_IO_Debug.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Debug App/MIDI_IO_Debug.res -------------------------------------------------------------------------------- /Debug App/frmMain.dfm: -------------------------------------------------------------------------------- 1 | object FormMain: TFormMain 2 | Left = 0 3 | Top = 0 4 | BorderIcons = [biSystemMenu, biMinimize] 5 | BorderStyle = bsSingle 6 | Caption = 'MIDI I/O Pass-Through/Debug' 7 | ClientHeight = 162 8 | ClientWidth = 560 9 | Color = clBtnFace 10 | Font.Charset = DEFAULT_CHARSET 11 | Font.Color = clWindowText 12 | Font.Height = -11 13 | Font.Name = 'Tahoma' 14 | Font.Style = [] 15 | FormStyle = fsStayOnTop 16 | OldCreateOrder = False 17 | OnCreate = FormCreate 18 | OnDestroy = FormDestroy 19 | PixelsPerInch = 96 20 | TextHeight = 13 21 | object gbInputMidiPod: TGroupBox 22 | Left = 8 23 | Top = 8 24 | Width = 281 25 | Height = 45 26 | Caption = ' Input Device ' 27 | TabOrder = 0 28 | object cbInputMIDIDevices: TComboBox 29 | Left = 7 30 | Top = 16 31 | Width = 267 32 | Height = 21 33 | Hint = 'Select Input MIDI Device (preferrable a virtual MIDI cable)' 34 | Style = csDropDownList 35 | ItemHeight = 13 36 | TabOrder = 0 37 | OnChange = cbInputMIDIDevicesChange 38 | end 39 | end 40 | object gbOutputMidiPod: TGroupBox 41 | Left = 8 42 | Top = 59 43 | Width = 281 44 | Height = 46 45 | Caption = ' Output Device ' 46 | TabOrder = 1 47 | object cbOutputMIDIDevices: TComboBox 48 | Left = 7 49 | Top = 16 50 | Width = 267 51 | Height = 21 52 | Hint = 'Select a MIDI Output Device (e.g. MS Software Synth)' 53 | Style = csDropDownList 54 | ItemHeight = 13 55 | TabOrder = 0 56 | OnChange = cbOutputMIDIDevicesChange 57 | end 58 | end 59 | object btnOpenAll: TButton 60 | Left = 168 61 | Top = 111 62 | Width = 58 63 | Height = 25 64 | Hint = 'Open both devices' 65 | Caption = 'Open' 66 | TabOrder = 2 67 | OnClick = btnOpenAllClick 68 | end 69 | object btnStopAll: TButton 70 | Left = 232 71 | Top = 111 72 | Width = 57 73 | Height = 25 74 | Hint = 'Close both devices' 75 | Caption = 'Close' 76 | TabOrder = 3 77 | OnClick = btnStopAllClick 78 | end 79 | object Button1: TButton 80 | Left = 8 81 | Top = 111 82 | Width = 89 83 | Height = 25 84 | Hint = 'Refresh Device List' 85 | Caption = 'Refresh Dev.' 86 | TabOrder = 4 87 | OnClick = Button1Click 88 | end 89 | object memoInputDebug: TMemo 90 | Left = 295 91 | Top = 8 92 | Width = 257 93 | Height = 128 94 | Font.Charset = OEM_CHARSET 95 | Font.Color = clWindowText 96 | Font.Height = -8 97 | Font.Name = 'Terminal' 98 | Font.Style = [] 99 | Lines.Strings = ( 100 | 'memoInputDebug') 101 | ParentFont = False 102 | ScrollBars = ssVertical 103 | TabOrder = 5 104 | end 105 | object Button2: TButton 106 | Left = 103 107 | Top = 111 108 | Width = 44 109 | Height = 25 110 | Hint = 'Send some notes to current open Output Device' 111 | Caption = 'Sound' 112 | TabOrder = 6 113 | OnClick = Button2Click 114 | end 115 | object StatusBar: TStatusBar 116 | Left = 0 117 | Top = 143 118 | Width = 560 119 | Height = 19 120 | AutoHint = True 121 | Panels = < 122 | item 123 | Text = ' Incomming messages in queue' 124 | Width = 300 125 | end 126 | item 127 | Text = ' Incomming messages in queue' 128 | Width = 165 129 | end 130 | item 131 | Width = 50 132 | end> 133 | ExplicitWidth = 528 134 | end 135 | object Timer1: TTimer 136 | OnTimer = Timer1Timer 137 | Left = 312 138 | Top = 32 139 | end 140 | end 141 | -------------------------------------------------------------------------------- /Debug App/frmMain.pas: -------------------------------------------------------------------------------- 1 | (* ***** BEGIN LICENSE BLOCK ***** 2 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 3 | * 4 | * The contents of this file are subject to the Mozilla Public License Version 5 | * 1.1 (the "License"); you may not use this file except in compliance with 6 | * the License. You may obtain a copy of the License at 7 | * http://www.mozilla.org/MPL/ 8 | * 9 | * Software distributed under the License is distributed on an "AS IS" basis, 10 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 11 | * for the specific language governing rights and limitations under the 12 | * License. 13 | * 14 | * The Original Code is MIDI I/O components debugger app. 15 | * 16 | * The Initial Developer of the Original Code is 17 | * Manuel Kroeber . 18 | * Portions created by the Initial Developer are Copyright (C) 2010 19 | * the Initial Developer. All Rights Reserved. 20 | * 21 | * Contributor(s): 22 | * None 23 | * 24 | * 25 | * Alternatively, the contents of this file may be used under the terms of 26 | * either the GNU General Public License Version 3 or later (the "GPL"), or 27 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 28 | * in which case the provisions of the GPL or the LGPL are applicable instead 29 | * of those above. If you wish to allow use of your version of this file only 30 | * under the terms of either the GPL or the LGPL, and not to allow others to 31 | * use your version of this file under the terms of the MPL, indicate your 32 | * decision by deleting the provisions above and replace them with the notice 33 | * and other provisions required by the GPL or the LGPL. If you do not delete 34 | * the provisions above, a recipient may use your version of this file under 35 | * the terms of any one of the MPL, the GPL or the LGPL. 36 | * 37 | * ***** END LICENSE BLOCK ***** *) 38 | 39 | unit frmMain; 40 | 41 | interface 42 | 43 | uses 44 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 45 | Dialogs, StdCtrls, 46 | 47 | MidiIn, 48 | MidiOut, 49 | MidiType, 50 | MidiCons, 51 | 52 | ExtCtrls, ComCtrls; 53 | 54 | type 55 | TFormMain = class(TForm) 56 | gbInputMidiPod: TGroupBox; 57 | cbInputMIDIDevices: TComboBox; 58 | gbOutputMidiPod: TGroupBox; 59 | cbOutputMIDIDevices: TComboBox; 60 | btnOpenAll: TButton; 61 | btnStopAll: TButton; 62 | Button1: TButton; 63 | memoInputDebug: TMemo; 64 | Timer1: TTimer; 65 | Button2: TButton; 66 | StatusBar: TStatusBar; 67 | procedure FormCreate(Sender: TObject); 68 | procedure Button1Click(Sender: TObject); 69 | procedure cbInputMIDIDevicesChange(Sender: TObject); 70 | procedure cbOutputMIDIDevicesChange(Sender: TObject); 71 | procedure Timer1Timer(Sender: TObject); 72 | procedure btnOpenAllClick(Sender: TObject); 73 | procedure btnStopAllClick(Sender: TObject); 74 | procedure FormDestroy(Sender: TObject); 75 | procedure Button2Click(Sender: TObject); 76 | private 77 | { Private-Deklarationen } 78 | FMidiIn: TMidiInput; 79 | FMidiOut: TMidiOutput; 80 | procedure UpdateStatusBar; 81 | procedure OnMidiInput(Sender: TObject); 82 | public 83 | { Public-Deklarationen } 84 | function ByteArrayToHexString(const InArr: array of Byte): string; 85 | end; 86 | 87 | var 88 | FormMain: TFormMain; 89 | 90 | implementation 91 | 92 | {$R *.dfm} 93 | 94 | procedure TFormMain.btnOpenAllClick(Sender: TObject); 95 | begin 96 | FMidiIn.OpenAndStart; 97 | UpdateStatusBar; 98 | FMidiOut.Open; 99 | end; 100 | 101 | procedure TFormMain.btnStopAllClick(Sender: TObject); 102 | begin 103 | FMidiIn.Stop; 104 | FMidiIn.Close; 105 | FMidiOut.Close; 106 | end; 107 | 108 | procedure TFormMain.Button1Click(Sender: TObject); 109 | var 110 | I: Integer; 111 | begin 112 | cbOutputMIDIDevices.Clear; 113 | 114 | if FMidiOut.Numdevs > 0 then 115 | begin 116 | for I := -1 to FMidiOut.Numdevs - 1 do 117 | begin 118 | FMidiOut.DeviceID := I; 119 | cbOutputMIDIDevices.Items.Add(FMidiOut.ProductName+' (ID '+IntToStr(i)+')'); 120 | end; 121 | 122 | FMidiOut.DeviceID := FMidiOut.Numdevs - 1; 123 | cbOutputMIDIDevices.ItemIndex := cbOutputMIDIDevices.Items.Count - 1; 124 | end 125 | else 126 | MessageDlg('No MIDI output devices found.', 127 | mtError, [mbOK], 0); 128 | 129 | 130 | cbInputMIDIDevices.Clear; 131 | 132 | if FMidiIn.DeviceCount > 0 then 133 | begin 134 | for I := 0 to FMidiIn.DeviceCount - 1 do 135 | begin 136 | FMidiIn.DeviceID := I; 137 | cbInputMIDIDevices.Items.Add(FMidiIn.ProductName+' (ID '+IntToStr(i)+')'); 138 | end; 139 | 140 | FMidiIn.DeviceID := FMidiIn.DeviceCount - 1; 141 | cbInputMIDIDevices.ItemIndex := cbInputMIDIDevices.Items.Count - 1; 142 | end 143 | else 144 | MessageDlg('No MIDI input devices found.', 145 | mtError, [mbOK], 0); 146 | end; 147 | 148 | procedure TFormMain.Button2Click(Sender: TObject); 149 | begin 150 | FMidiOut.ChangeInstrument(0, gmiDistortionGuitar); 151 | FMidiOut.NoteOn(0, 64, 127); 152 | Sleep(300); 153 | FMidiOut.NoteOn(0, 69, 127); 154 | Sleep(300); 155 | FMidiOut.NoteOn(0, 74, 127); 156 | Sleep(300); 157 | FMidiOut.NoteOff(0, 64, 64); 158 | FMidiOut.NoteOff(0, 69, 64); 159 | FMidiOut.NoteOff(0, 74, 64); 160 | end; 161 | 162 | function TFormMain.ByteArrayToHexString(const InArr: array of Byte): string; 163 | var 164 | tmpStrList: TStringList; 165 | i: Integer; 166 | begin 167 | tmpStrList := TStringList.Create; 168 | try 169 | for I := Low(InArr) to High(InArr) do 170 | begin 171 | tmpStrList.Append(IntToHex(InArr[i], 2)); 172 | end; 173 | tmpStrList.Delimiter := ' '; 174 | Result := tmpStrList.DelimitedText; 175 | finally 176 | tmpStrList.Free; 177 | end; 178 | end; 179 | 180 | procedure TFormMain.cbInputMIDIDevicesChange(Sender: TObject); 181 | begin 182 | FMidiIn.ChangeDevice(cbInputMIDIDevices.ItemIndex, False); 183 | end; 184 | 185 | procedure TFormMain.cbOutputMIDIDevicesChange(Sender: TObject); 186 | begin 187 | if (cbOutputMIDIDevices.ItemIndex - 1) < 0 then 188 | FMidiOut.ChangeDevice(MIDI_MAPPER, False) 189 | else 190 | FMidiOut.ChangeDevice(cbOutputMIDIDevices.ItemIndex - 1, False); 191 | end; 192 | 193 | procedure TFormMain.FormCreate(Sender: TObject); 194 | var 195 | I: Integer; 196 | begin 197 | FMidiOut := TMidiOutput.Create(nil); 198 | 199 | if FMidiOut.Numdevs > 0 then 200 | begin 201 | for I := -1 to FMidiOut.Numdevs - 1 do 202 | begin 203 | FMidiOut.DeviceID := I; 204 | cbOutputMIDIDevices.Items.Add(FMidiOut.ProductName+' (ID '+IntToStr(i)+')'); 205 | end; 206 | 207 | FMidiOut.DeviceID := FMidiOut.Numdevs - 1; 208 | cbOutputMIDIDevices.ItemIndex := cbOutputMIDIDevices.Items.Count - 1; 209 | end 210 | else 211 | MessageDlg('No MIDI output devices found.', 212 | mtError, [mbOK], 0); 213 | 214 | FMidiIn := TMidiInput.Create(nil); 215 | FMidiIn.SysexBufferSize := 64000-1; 216 | FMidiIn.OnMidiInput := OnMIDIInput; 217 | 218 | if FMidiIn.DeviceCount > 0 then 219 | begin 220 | for I := 0 to FMidiIn.DeviceCount - 1 do 221 | begin 222 | FMidiIn.DeviceID := I; 223 | cbInputMIDIDevices.Items.Add(FMidiIn.ProductName+' (ID '+IntToStr(i)+')'); 224 | end; 225 | 226 | FMidiIn.DeviceID := FMidiIn.DeviceCount - 1; 227 | cbInputMIDIDevices.ItemIndex := cbInputMIDIDevices.Items.Count - 1; 228 | end 229 | else 230 | MessageDlg('No MIDI input devices found.', 231 | mtError, [mbOK], 0); 232 | 233 | end; 234 | 235 | procedure TFormMain.FormDestroy(Sender: TObject); 236 | begin 237 | FMidiIn.Free; 238 | FMidiOut.Free; 239 | end; 240 | 241 | procedure TFormMain.OnMidiInput(Sender: TObject); 242 | var 243 | thisEvent: TMyMidiEvent; 244 | ReceivingInput: TMidiInput; 245 | OutStr: string; 246 | SysExArray: array of Byte; 247 | begin 248 | try 249 | if (Sender is TMidiInput) then 250 | begin 251 | ReceivingInput := (Sender as TMidiInput); 252 | 253 | while (ReceivingInput.MessageCount > 0) do 254 | begin 255 | UpdateStatusBar; 256 | { Get the event as an object } 257 | thisEvent := ReceivingInput.GetMidiEvent; 258 | try 259 | SetLength(SysExArray, thisEvent.SysexLength); 260 | Move(thisEvent.Sysex, SysExArray[0], thisEvent.SysexLength); 261 | 262 | OutStr := MidiMessageToStr(thisEvent.MidiMessage) + #13#10 + 263 | 'Channel: ' + IntToStr(thisEvent.MidiMessage and $0F) + #13#10 + 264 | 'Data1: ' + IntToStr(thisEvent.Data1) + #13#10 + 265 | 'Data2: ' + IntToStr(thisEvent.Data2) + #13#10 + 266 | 'Time: ' + IntToStr(thisEvent.Time) + #13#10 + 267 | 'SysexLength: ' + IntToStr(thisEvent.SysexLength) + #13#10 + 268 | 'Sysex: ' + #13#10 + ByteArrayToHexString(SysExArray) + #13#10; 269 | 270 | memoInputDebug.Lines.Text := OutStr; 271 | 272 | FMidiOut.PutMidiEvent(thisEvent); 273 | finally 274 | { Event was dynamically created by GetMidiEvent so must free it here } 275 | thisEvent.Free; 276 | end; 277 | end; 278 | end; 279 | except 280 | // ignore exeptions to continue after bad events 281 | end; 282 | end; 283 | 284 | procedure TFormMain.Timer1Timer(Sender: TObject); 285 | begin 286 | if Assigned(FMidiIn) then 287 | begin 288 | case FMidiIn.State of 289 | misOpen: gbInputMidiPod.Caption := ' Input (OPEN)'; 290 | misClosed: gbInputMidiPod.Caption := ' Input (CLOSED)'; 291 | misCreating: gbInputMidiPod.Caption := ' Input (CREATING)'; 292 | misDestroying: gbInputMidiPod.Caption := ' Input (DESTROYING)'; 293 | end; 294 | gbInputMidiPod.Caption := gbInputMidiPod.Caption + ' ' + FMidiIn.ProductName; 295 | UpdateStatusBar; 296 | end; 297 | 298 | if Assigned(FMidiOut) then 299 | begin 300 | case FMidiOut.State of 301 | mosOpen: gbOutputMidiPod.Caption := ' Output (OPEN)'; 302 | mosClosed: gbOutputMidiPod.Caption := ' Output (CLOSED)'; 303 | end; 304 | gbOutputMidiPod.Caption := gbOutputMidiPod.Caption + ' ' + FMidiOut.ProductName; 305 | end; 306 | end; 307 | 308 | procedure TFormMain.UpdateStatusBar; 309 | begin 310 | StatusBar.Panels[2].Text := IntToStr(FMidiIn.MessageCount); 311 | end; 312 | 313 | end. 314 | -------------------------------------------------------------------------------- /Examples/MidiMon.dpr: -------------------------------------------------------------------------------- 1 | { $Header: G:/delphi/midi/vcs/midimon.dpr 1.2 30 Apr 1996 19:05:38 DAVEC $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | program Midimon; 7 | 8 | uses 9 | Forms, 10 | Midimonp in 'MIDIMONP.PAS' {Form1}, 11 | Monprocs in 'MONPROCS.PAS'; 12 | 13 | {$R *.RES} 14 | 15 | begin 16 | Application.CreateForm(TForm1, Form1); 17 | Application.Run; 18 | end. 19 | -------------------------------------------------------------------------------- /Examples/MidiMon.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Examples/MidiMon.res -------------------------------------------------------------------------------- /Examples/MidiMonP.dfm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Examples/MidiMonP.dfm -------------------------------------------------------------------------------- /Examples/MidiMonP.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/MIDIMONP.PAS 3 28/02/01 11:24 Davec $ } 2 | 3 | { This demo shows how MidiInput and MidiOutput components can be used 4 | interactively at design time on a form. 5 | The monitor has one TMidiInput control whose device ID is set interactively 6 | at runtime using a combo box. 7 | Anything received on the input device, including sysex data, is displayed by 8 | the monitor and echoed to the selected output device. } 9 | 10 | unit Midimonp; 11 | 12 | interface 13 | 14 | uses 15 | SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, 16 | Forms, Dialogs, MMSystem, StdCtrls, MIDIIn, MidiOut, ExtCtrls, 17 | Menus, monprocs, MidiType; 18 | 19 | type 20 | TForm1 = class(TForm) 21 | lstLog: TListBox; 22 | pnlColumnHeading: TPanel; 23 | MidiOutput1: TMidiOutput; 24 | MainMenu1: TMainMenu; 25 | File1: TMenuItem; 26 | mnuExit: TMenuItem; 27 | Label1: TLabel; 28 | cmbInput: TComboBox; 29 | cmbOutput: TComboBox; 30 | Bevel1: TBevel; 31 | MIDIInput1: TMidiInput; 32 | procedure MIDIInput1MidiInput(Sender: TObject); 33 | procedure LogMessage(ThisEvent:TMyMidiEvent); 34 | procedure FormCreate(Sender: TObject); 35 | procedure FormResize(Sender: TObject); 36 | procedure FormClose(Sender: TObject; var Action: TCloseAction); 37 | procedure mnuExitClick(Sender: TObject); 38 | procedure cmbInputChange(Sender: TObject); 39 | procedure OpenDevs; 40 | procedure CloseDevs; 41 | private 42 | logItemMax: Integer; 43 | public 44 | { Public declarations } 45 | end; 46 | 47 | var 48 | Form1: TForm1; 49 | inh: HMidiIn; 50 | 51 | implementation 52 | 53 | {$R *.DFM} 54 | 55 | 56 | procedure TForm1.LogMessage(ThisEvent:TMyMidiEvent); 57 | { Logging MIDI messages with a Windows list box is rather slow and ugly, 58 | but it makes the example very simple. If you need a faster and less 59 | flickery log you could port the rest of Microsoft's MIDIMON.C example. } 60 | begin 61 | if logItemMax > 0 then 62 | begin 63 | With lstLog.Items do 64 | begin 65 | if Count >= logItemMax then 66 | Delete(0); 67 | Add(MonitorMessageText(ThisEvent)); 68 | end; 69 | end; 70 | end; 71 | 72 | procedure TForm1.MIDIInput1MidiInput(Sender: TObject); 73 | var 74 | thisEvent: TMyMidiEvent; 75 | begin 76 | with (Sender As TMidiInput) do 77 | begin 78 | while (MessageCount > 0) do 79 | begin 80 | 81 | { Get the event as an object } 82 | thisEvent := GetMidiEvent; 83 | 84 | { Log it } 85 | LogMessage(thisEvent); 86 | 87 | { Echo to the output device } 88 | MidiOutput1.PutMidiEvent(thisEvent); 89 | 90 | { Event was dynamically created by GetMyMidiEvent so must 91 | free it here } 92 | thisEvent.Free; 93 | 94 | end; 95 | end; 96 | end; 97 | 98 | procedure TForm1.OpenDevs; 99 | begin 100 | { Use selected devices } 101 | MidiInput1.ProductName := cmbInput.Text; 102 | MidiOutput1.ProductName := cmbOutput.Text; 103 | { Open devices } 104 | { DEBUG } 105 | MidiInput1.Open; 106 | MidiInput1.Start; 107 | MidiOutput1.Open; 108 | end; 109 | 110 | procedure TForm1.CloseDevs; 111 | begin 112 | MidiInput1.Close; 113 | MidiOutput1.Close; 114 | end; 115 | 116 | 117 | procedure TForm1.FormCreate(Sender: TObject); 118 | var 119 | thisDevice: Word; 120 | begin 121 | Cursor := crHourglass; 122 | 123 | { Load the lists of installed MIDI devices } 124 | cmbInput.Clear; 125 | for thisDevice := 0 To MidiInput1.NumDevs - 1 do 126 | begin 127 | MidiInput1.DeviceID := thisDevice; 128 | cmbInput.Items.Add(MidiInput1.ProductName); 129 | end; 130 | cmbInput.ItemIndex := 0; 131 | cmbOutput.Clear; 132 | for thisDevice := 0 To MidiOutput1.NumDevs - 1 do 133 | begin 134 | MidiOutput1.DeviceID := thisDevice; 135 | cmbOutput.Items.Add(MidiOutput1.ProductName); 136 | end; 137 | cmbOutput.ItemIndex := 0; 138 | OpenDevs; 139 | 140 | Cursor := crDefault; 141 | end; 142 | 143 | procedure TForm1.FormResize(Sender: TObject); 144 | const 145 | logMargin = 8; 146 | begin 147 | { Set maximum items that can be stored in the list box without scrolling } 148 | if lstLog.ItemHeight > 0 then 149 | begin 150 | logItemMax := (lstLog.Height div lstLog.ItemHeight)-1; 151 | { If there are currently more items than the max, remove them 152 | otherwise the list will have scrollbars when resized } 153 | with lstLog.Items do 154 | begin 155 | while (Count >= logItemMax) and (Count > 0) do 156 | Delete(0); 157 | end; 158 | end 159 | else 160 | logItemMax := 0; 161 | end; 162 | 163 | procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); 164 | begin 165 | { This is not strictly necessary since the objects close themselves 166 | when the form containing them is destroyed } 167 | CloseDevs; 168 | end; 169 | 170 | procedure TForm1.mnuExitClick(Sender: TObject); 171 | begin 172 | Application.Terminate; 173 | end; 174 | 175 | 176 | procedure TForm1.cmbInputChange(Sender: TObject); 177 | begin 178 | { Close and reopen devices with changed device selection } 179 | Cursor := crHourglass; 180 | CloseDevs; 181 | OpenDevs; 182 | Cursor := crDefault; 183 | end; 184 | 185 | end. 186 | -------------------------------------------------------------------------------- /Examples/MidiTest.dfm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Examples/MidiTest.dfm -------------------------------------------------------------------------------- /Examples/MidiTest.pas: -------------------------------------------------------------------------------- 1 | // Test application for TMidiFile 2 | 3 | unit MidiTest; 4 | 5 | interface 6 | 7 | uses 8 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 9 | StdCtrls, MidiFile, ExtCtrls, MidiOut, MidiType, MidiScope, Grids; 10 | type 11 | TMidiPlayer = class(TForm) 12 | OpenDialog1: TOpenDialog; 13 | Button1: TButton; 14 | Button3: TButton; 15 | Button4: TButton; 16 | MidiOutput1: TMidiOutput; 17 | cmbInput: TComboBox; 18 | MidiFile1: TMidiFile; 19 | MidiScope1: TMidiScope; 20 | Label3: TLabel; 21 | edtBpm: TEdit; 22 | Memo2: TMemo; 23 | edtTime: TEdit; 24 | Button2: TButton; 25 | TrackGrid: TStringGrid; 26 | TracksGrid: TStringGrid; 27 | edtLength: TEdit; 28 | procedure Button1Click(Sender: TObject); 29 | procedure MidiFile1MidiEvent(event: PMidiEvent); 30 | procedure Button3Click(Sender: TObject); 31 | procedure Button4Click(Sender: TObject); 32 | procedure FormCreate(Sender: TObject); 33 | procedure cmbInputChange(Sender: TObject); 34 | procedure MidiFile1UpdateEvent(Sender: TObject); 35 | procedure Button2Click(Sender: TObject); 36 | procedure edtBpmKeyPress(Sender: TObject; var Key: Char); 37 | procedure TracksGridSelectCell(Sender: TObject; Col, Row: Integer; 38 | var CanSelect: Boolean); 39 | procedure FormShow(Sender: TObject); 40 | private 41 | { Private declarations } 42 | MidiOpened : boolean; 43 | procedure SentAllNotesOff; 44 | 45 | procedure MidiOpen; 46 | procedure MidiClose; 47 | 48 | public 49 | { Public declarations } 50 | end; 51 | 52 | var 53 | MidiPlayer: TMidiPlayer; 54 | 55 | implementation 56 | 57 | {$R *.DFM} 58 | 59 | procedure TMidiPlayer.Button1Click(Sender: TObject); 60 | var 61 | i,j: integer; 62 | track : TMidiTrack; 63 | event : PMidiEvent; 64 | begin 65 | if opendialog1.execute then 66 | begin 67 | midifile1.filename := opendialog1.filename; 68 | midifile1.readfile; 69 | // label1.caption := IntToStr(midifile1.NumberOfTracks); 70 | edtBpm.text := IntToStr(midifile1.Bpm); 71 | // TracksGrid.cells.clear; 72 | for i := 0 to midifile1.NumberOfTracks-1 do 73 | begin 74 | track := midifile1.getTrack(i); 75 | TracksGrid.cells[0,i] := 'Tr: '+ track.getName + ' '+ track.getInstrument ; 76 | end; 77 | edtLength.Text := MyTimeToStr(MidiFile1.GetTrackLength); 78 | end; 79 | end; 80 | 81 | procedure TMidiPlayer.MidiFile1MidiEvent(event: PMidiEvent); 82 | var mEvent : TMyMidiEvent; 83 | begin 84 | mEvent := TMyMidiEvent.Create; 85 | if not (event.event = $FF) then 86 | begin 87 | mEvent.MidiMessage := event.event; 88 | mEvent.data1 := event.data1; 89 | mEvent.data2 := event.data2; 90 | midioutput1.PutMidiEvent(mEvent); 91 | end 92 | else 93 | begin 94 | if (event.data1 >= 1) and (event.data1 < 15) then 95 | begin 96 | memo2.Lines.add(IntToStr(event.data1) + ' '+ event.str); 97 | end 98 | end; 99 | midiScope1.MidiEvent(event.event,event.data1,event.data2); 100 | mEvent.Destroy; 101 | end; 102 | 103 | procedure TMidiPlayer.SentAllNotesOff; 104 | var mEvent : TMyMidiEvent; 105 | channel : integer; 106 | begin 107 | mEvent := TMyMidiEvent.Create; 108 | for channel:= 0 to 15 do 109 | begin 110 | mEvent.MidiMessage := $B0 + channel; 111 | mEvent.data1 := $78; 112 | mEvent.data2 := 0; 113 | if MidiOpened then 114 | midioutput1.PutMidiEvent(mEvent); 115 | midiScope1.MidiEvent(mEvent.MidiMessage,mEvent.data1,mEvent.data2); 116 | end; 117 | mEvent.Destroy; 118 | end; 119 | 120 | procedure TMidiPlayer.Button3Click(Sender: TObject); 121 | begin 122 | midifile1.StartPlaying; 123 | end; 124 | 125 | procedure TMidiPlayer.Button4Click(Sender: TObject); 126 | begin 127 | midifile1.StopPlaying; 128 | SentAllNotesOff; 129 | end; 130 | 131 | procedure TMidiPlayer.MidiOpen; 132 | begin 133 | if not (cmbInput.Text = '') then 134 | begin 135 | MidiOutput1.ProductName := cmbInput.Text; 136 | MidiOutput1.OPEN; 137 | MidiOpened := true; 138 | end; 139 | end; 140 | 141 | procedure TMidiPlayer.MidiClose; 142 | begin 143 | if MidiOpened then 144 | begin 145 | MidiOutput1.Close; 146 | MidiOpened := false; 147 | end; 148 | end; 149 | 150 | 151 | procedure TMidiPlayer.FormCreate(Sender: TObject); 152 | var thisDevice : integer; 153 | begin 154 | for thisDevice := 0 to MidiOutput1.NumDevs - 1 do 155 | begin 156 | MidiOutput1.DeviceID := thisDevice; 157 | cmbInput.Items.Add(MidiOutput1.ProductName); 158 | end; 159 | cmbInput.ItemIndex := 0; 160 | MidiOpened := false; 161 | MidiOpen; 162 | end; 163 | 164 | procedure TMidiPlayer.cmbInputChange(Sender: TObject); 165 | begin 166 | MidiClose; 167 | MidiOPen; 168 | end; 169 | 170 | procedure TMidiPlayer.MidiFile1UpdateEvent(Sender: TObject); 171 | begin 172 | edtTime.Text := MyTimeToStr(MidiFile1.GetCurrentTime); 173 | edtTime.update; 174 | if MidiFile1.ready then 175 | begin 176 | midifile1.StopPlaying; 177 | SentAllNotesOff; 178 | end; 179 | end; 180 | 181 | procedure TMidiPlayer.Button2Click(Sender: TObject); 182 | begin 183 | MidiFile1.ContinuePlaying; 184 | end; 185 | 186 | procedure TMidiPlayer.edtBpmKeyPress(Sender: TObject; var Key: Char); 187 | begin 188 | if Key = char(13) then 189 | begin 190 | MidiFile1.Bpm := StrToInt(edtBpm.Text); 191 | edtBpm.text := IntToStr(midifile1.Bpm); 192 | abort; 193 | end; 194 | 195 | end; 196 | 197 | procedure TMidiPlayer.TracksGridSelectCell(Sender: TObject; Col, 198 | Row: Integer; var CanSelect: Boolean); 199 | var 200 | MidiTrack : TMidiTrack; 201 | i : integer; 202 | j : integer; 203 | event : PMidiEvent; 204 | begin 205 | CanSelect := false; 206 | if Row < MidiFile1.NumberOfTracks then 207 | begin 208 | CanSelect := true; 209 | MidiTrack := MidiFile1.GetTrack(Row); 210 | TrackGrid.RowCount := 2; 211 | TrackGrid.RowCount := MidiTrack.getEventCount; 212 | j := 1; 213 | for i := 0 to MidiTrack.GetEventCount-1 do 214 | begin 215 | event := MidiTrack.getEvent(i); 216 | if not (event.len = -1) then 217 | begin // do not print when 218 | TrackGrid.cells[0,j] := IntToStr(i); 219 | TrackGrid.cells[1,j] := MyTimeToStr(event.time); 220 | TrackGrid.cells[2,j] := IntToHex(event.event,2); 221 | if not (event.event = $FF) then 222 | begin 223 | TrackGrid.cells[3,j] := IntToStr(event.len); 224 | TrackGrid.cells[4,j] := KeyToStr(event.data1); 225 | TrackGrid.cells[5,j] := IntToStr(event.data2); 226 | end 227 | else 228 | begin 229 | TrackGrid.cells[3,j] := IntToStr(event.data1); 230 | TrackGrid.cells[4,j] := ''; 231 | TrackGrid.cells[5,j] := event.str; 232 | end; 233 | inc(j); 234 | end; 235 | end; 236 | TrackGrid.RowCount := j; 237 | end; 238 | end; 239 | 240 | procedure TMidiPlayer.FormShow(Sender: TObject); 241 | begin 242 | TrackGrid.ColWidths[0] := 30; 243 | TrackGrid.ColWidths[2] := 30; 244 | TrackGrid.ColWidths[3] := 30; 245 | TrackGrid.ColWidths[4] := 30; 246 | TrackGrid.ColWidths[5] := 100; 247 | end; 248 | 249 | end. 250 | -------------------------------------------------------------------------------- /Examples/MonProcs.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/MONPROCS.PAS 2 10/06/97 7:33 Davec $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | 7 | unit Monprocs; 8 | 9 | interface 10 | 11 | uses Sysutils, MidiType, Midicons; 12 | 13 | type 14 | TEventNames = array[1..8] of string[24]; 15 | TSysMsgNames = array[1..16] of string[24]; 16 | const 17 | EventNames: TEventNames = ( 18 | 'Note Off', 19 | 'Note On', 20 | 'Key Aftertouch', 21 | 'Control Change', 22 | 'Program Change', 23 | 'Channel Aftertouch', 24 | 'Pitch Bend', 25 | 'System Message' ); 26 | SysMsgNames: TSysMsgNames = ( 27 | 'System Exclusive', 28 | 'MTC Quarter Frame', 29 | 'Song Position Pointer', 30 | 'Song Select', 31 | 'Undefined', 32 | 'Undefined', 33 | 'Tune Request', 34 | 'System Exclusive End', 35 | 'Timing Clock', 36 | 'Undefined', 37 | 'Start', 38 | 'Continue', 39 | 'Stop', 40 | 'Undefined', 41 | 'Active Sensing', 42 | 'System Reset'); 43 | 44 | format3 = '%4.4x%4.4x %2.2x %2.2x %2.2x %s'; 45 | format2 = '%4.4x%4.4x %2.2x %2.2x %s'; 46 | format1 = '%4.4x%4.4x %2.2x %s'; 47 | 48 | function BinaryToHexList( bin: PChar; binSize: Word ): String; 49 | function MonitorMessageText( ThisEvent: TMyMidiEvent ): String; 50 | 51 | implementation 52 | 53 | function BinaryToHexList( bin: PChar; binSize: Word ): String; 54 | var 55 | ctr: Word; 56 | thisChar: Char; 57 | begin 58 | if binSize > 200 then 59 | binSize := 200; 60 | 61 | Result := ''; 62 | for ctr := 0 to binSize-1 do 63 | begin 64 | thisChar := bin^; 65 | Result := Result + Format('%2.2x ', [Integer(thisChar)]); 66 | Inc(bin); 67 | end; 68 | end; 69 | 70 | { Converts MIDI event to text description. Straight out of Microsoft MIDIMON example } 71 | function MonitorMessageText( ThisEvent: TMyMidiEvent ): String; 72 | var 73 | bStatus: Byte; 74 | EventDesc: String; 75 | TimeLow: Word; 76 | TimeHigh: Word; 77 | begin 78 | bStatus := ThisEvent.MidiMessage And $f0; 79 | TimeHigh := Word(ThisEvent.Time Div 65536); 80 | TimeLow := Word(ThisEvent.Time MOD 65536); 81 | 82 | EventDesc := 'Unrecognized MIDI Event'; 83 | 84 | case bStatus of 85 | 86 | { 3-byte events } 87 | MIDI_NOTEOFF, 88 | MIDI_NOTEON, 89 | MIDI_KEYAFTERTOUCH, 90 | MIDI_CONTROLCHANGE, 91 | MIDI_PITCHBEND: 92 | begin 93 | { Note on with velocity of 0 is a Note Off } 94 | { if (bStatus = MIDI_NOTEON) And (ThisEvent.Data2 = 0) then 95 | bStatus := MIDI_NOTEOFF; } 96 | EventDesc := Format(format3, 97 | [TimeHigh, TimeLow, 98 | ThisEvent.MidiMessage, 99 | ThisEvent.Data1, 100 | ThisEvent.Data2, 101 | EventNames[ ((ThisEvent.MidiMessage-$80) Div 16) + 1 ]]); 102 | end; 103 | { 2-byte events } 104 | MIDI_PROGRAMCHANGE, 105 | MIDI_CHANAFTERTOUCH: 106 | begin 107 | EventDesc := Format(format2,[TimeHigh, TimeLow, 108 | ThisEvent.MidiMessage, 109 | ThisEvent.Data1, 110 | EventNames[ ((ThisEvent.MidiMessage-$80) Div 16) + 1 ]]); 111 | end; 112 | 113 | { System events $f0-$ff } 114 | MIDI_BEGINSYSEX: 115 | begin 116 | case ThisEvent.MidiMessage of 117 | MIDI_BEGINSYSEX: 118 | EventDesc := Format('Sysex (%d): ', [ThisEvent.SysexLength]) + 119 | BinaryToHexList(PWideChar(ThisEvent.Sysex), ThisEvent.SysexLength); 120 | 121 | {2-byte system events} 122 | MIDI_MTCQUARTERFRAME, 123 | MIDI_SONGSELECT: 124 | EventDesc := Format(format1,[TimeHigh, TimeLow, 125 | ThisEvent.MidiMessage, 126 | ThisEvent.Data1, 127 | SysMsgNames[ (ThisEvent.MidiMessage And $f) +1 ]]); 128 | 129 | {3-byte system events} 130 | MIDI_SONGPOSPTR: 131 | EventDesc := Format(format3,[TimeHigh, TimeLow, 132 | ThisEvent.MidiMessage, 133 | ThisEvent.Data1, 134 | ThisEvent.Data2, 135 | SysMsgNames[ (ThisEvent.MidiMessage And $f) +1 ]]); 136 | 137 | {1-byte system events} 138 | else 139 | EventDesc := Format(format1,[TimeHigh, TimeLow, 140 | ThisEvent.MidiMessage, 141 | SysMsgNames[ (ThisEvent.MidiMessage And $f) +1 ]]); 142 | end; 143 | end; 144 | end; 145 | Result := EventDesc; 146 | end; 147 | 148 | end. 149 | -------------------------------------------------------------------------------- /Examples/MultiMNP.dfm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Examples/MultiMNP.dfm -------------------------------------------------------------------------------- /Examples/MultiMNP.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Examples/MultiMNP.pas -------------------------------------------------------------------------------- /Examples/MultiMon.dpr: -------------------------------------------------------------------------------- 1 | { $Header: G:/delphi/midi/vcs/multimon.dpr 1.1 30 Apr 1996 19:05:38 DAVEC $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | program Multimon; 7 | 8 | uses 9 | Forms, 10 | Multimnp in 'MultiMNP.pas' {Form1}; 11 | 12 | {$R *.RES} 13 | 14 | begin 15 | Application.CreateForm(TForm1, Form1); 16 | Application.Run; 17 | end. 18 | -------------------------------------------------------------------------------- /Examples/MultiMon.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Examples/MultiMon.res -------------------------------------------------------------------------------- /Examples/Project1.dpr: -------------------------------------------------------------------------------- 1 | program Project1; 2 | 3 | uses 4 | Forms, 5 | MidiTest in 'MidiTest.pas' {MidiPlayer}; 6 | 7 | {$R *.RES} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.CreateForm(TMidiPlayer, MidiPlayer); 12 | Application.Run; 13 | end. 14 | -------------------------------------------------------------------------------- /Examples/Project1.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Examples/Project1.res -------------------------------------------------------------------------------- /MidiCallback.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/DELPHMCB.PAS 2 10/06/97 7:33 Davec $ } 2 | 3 | (** 4 | * DelphiMidiCallback.pas v2010-05r1 5 | **) 6 | 7 | (* ***** BEGIN LICENSE BLOCK ***** 8 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 9 | * 10 | * The contents of this file are subject to the Mozilla Public License Version 11 | * 1.1 (the "License"); you may not use this file except in compliance with 12 | * the License. You may obtain a copy of the License at 13 | * http://www.mozilla.org/MPL/ 14 | * 15 | * Software distributed under the License is distributed on an "AS IS" basis, 16 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 17 | * for the specific language governing rights and limitations under the 18 | * License. 19 | * 20 | * The Original Code is MIDI type definitions. 21 | * 22 | * The Initial Developer of the Original Code is 23 | * David Churcher . 24 | * Portions created by the Initial Developer are Copyright (C) 1997 25 | * the Initial Developer. All Rights Reserved. 26 | * 27 | * Contributor(s): 28 | * Manuel Kroeber 29 | * 30 | * Alternatively, the contents of this file may be used under the terms of 31 | * either the GNU General Public License Version 3 or later (the "GPL"), or 32 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 33 | * in which case the provisions of the GPL or the LGPL are applicable instead 34 | * of those above. If you wish to allow use of your version of this file only 35 | * under the terms of either the GPL or the LGPL, and not to allow others to 36 | * use your version of this file under the terms of the MPL, indicate your 37 | * decision by deleting the provisions above and replace them with the notice 38 | * and other provisions required by the GPL or the LGPL. If you do not delete 39 | * the provisions above, a recipient may use your version of this file under 40 | * the terms of any one of the MPL, the GPL or the LGPL. 41 | * 42 | * ***** END LICENSE BLOCK ***** *) 43 | 44 | {MIDI callback for Delphi, was DLL for Delphi 1} 45 | 46 | unit MidiCallback; 47 | 48 | { These segment options required for the MIDI callback functions } 49 | {$C PRELOAD FIXED PERMANENT} 50 | 51 | interface 52 | 53 | uses Windows, MMsystem, Circbuf, MidiDefs, MidiCons; 54 | 55 | {$IFDEF WIN32} 56 | procedure midiHandler( 57 | hMidiIn: HMidiIn; 58 | wMsg: UINT; 59 | dwInstance: DWORD; 60 | dwParam1: DWORD; 61 | dwParam2: DWORD); stdcall export; 62 | function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; stdcall; export; 63 | {$ELSE} 64 | procedure midiHandler( 65 | hMidiIn: HMidiIn; 66 | wMsg: Word; 67 | dwInstance: DWORD; 68 | dwParam1: DWORD; 69 | dwParam2: DWORD); export; 70 | function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; export; 71 | {$ENDIF} 72 | 73 | implementation 74 | 75 | { Add an event to the circular input buffer. } 76 | 77 | function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; 78 | begin 79 | if (PBuffer^.EventCount < PBuffer^.Capacity) then 80 | begin 81 | Inc(Pbuffer^.EventCount); 82 | 83 | { Todo: better way of copying this record } 84 | with PBuffer^.PNextput^ do 85 | begin 86 | Timestamp := PTheEvent^.Timestamp; 87 | Data := PTheEvent^.Data; 88 | Sysex := PTheEvent^.Sysex; 89 | end; 90 | 91 | { Move to next put location, with wrap } 92 | Inc(Pbuffer^.PNextPut); 93 | if (PBuffer^.PNextPut = PBuffer^.PEnd) then 94 | PBuffer^.PNextPut := PBuffer^.PStart; 95 | 96 | CircbufPutEvent := True; 97 | end 98 | else 99 | CircbufPutEvent := False; 100 | end; 101 | 102 | { This is the callback function specified when the MIDI device was opened 103 | by midiInOpen. It's called at interrupt time when MIDI input is seen 104 | by the MIDI device driver(s). See the docs for midiInOpen for restrictions 105 | on the Windows functions that can be called in this interrupt. } 106 | 107 | procedure midiHandler( 108 | hMidiIn: HMidiIn; 109 | wMsg: UINT; 110 | dwInstance: DWORD; 111 | dwParam1: DWORD; 112 | dwParam2: DWORD); 113 | 114 | var 115 | thisEvent: TMidiBufferItem; 116 | thisCtlInfo: PMidiCtlInfo; 117 | thisBuffer: PCircularBuffer; 118 | ProcessThisMessage: Boolean; 119 | 120 | begin 121 | case wMsg of 122 | 123 | mim_Open: {nothing}; 124 | 125 | mim_Error: {TODO: handle (message to trigger exception?) }; 126 | 127 | mim_Data, mim_Longdata, mim_Longerror: 128 | { Note: mim_Longerror included because there's a bug in the Maui 129 | input driver that sends MIM_LONGERROR for subsequent buffers when 130 | the input buffer is smaller than the sysex block being received } 131 | begin 132 | thisCtlInfo := PMidiCtlInfo(dwInstance); 133 | 134 | // Filter messages if enabled (is there a more efficient way? 135 | case dwParam1 of 136 | MIDI_ACTIVESENSING: ProcessThisMessage := not thisCtlInfo^.FilterAS; 137 | MIDI_TIMINGCLOCK: ProcessThisMessage := not thisCtlInfo^.FilterMTC; 138 | else 139 | ProcessThisMessage := True; 140 | end; 141 | 142 | if ProcessThisMessage then 143 | begin 144 | { The device driver passes us the instance data pointer we 145 | specified for midiInOpen. Use this to get the buffer address 146 | and window handle for the MIDI control } 147 | 148 | thisBuffer := thisCtlInfo^.PBuffer; 149 | 150 | { Screen out short messages if we've been asked to } 151 | if ((wMsg <> mim_Data) or (thisCtlInfo^.SysexOnly = False)) 152 | and (thisCtlInfo <> nil) and (thisBuffer <> nil) then 153 | begin 154 | with thisEvent do 155 | begin 156 | timestamp := dwParam2; 157 | if (wMsg = mim_Longdata) or 158 | (wMsg = mim_Longerror) then 159 | begin 160 | data := 0; 161 | sysex := PMidiHdr(dwParam1); 162 | end 163 | else 164 | begin 165 | data := dwParam1; 166 | sysex := nil; 167 | end; 168 | end; 169 | if CircbufPutEvent(thisBuffer, @thisEvent) then 170 | { Send a message to the control to say input's arrived } 171 | PostMessage(thisCtlInfo^.hWindow, mim_Data, 0, 0) 172 | else 173 | { Buffer overflow } 174 | PostMessage(thisCtlInfo^.hWindow, mim_Overflow, 0, 0); 175 | end; 176 | end; 177 | end; 178 | 179 | mom_Done: { Sysex output complete, dwParam1 is pointer to MIDIHDR } 180 | begin 181 | { Notify the control that its sysex output is finished. 182 | The control should call midiOutUnprepareHeader before freeing the buffer } 183 | PostMessage(PMidiCtlInfo(dwInstance)^.hWindow, mom_Done, 0, dwParam1); 184 | end; 185 | 186 | end; { Case } 187 | end; 188 | 189 | end. 190 | 191 | -------------------------------------------------------------------------------- /MidiCons.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/MIDICONS.PAS 2 10/06/97 7:33 Davec $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | (** 7 | * MidiCons.pas v2010-05r1 8 | **) 9 | 10 | (* ***** BEGIN LICENSE BLOCK ***** 11 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 12 | * 13 | * The contents of this file are subject to the Mozilla Public License Version 14 | * 1.1 (the "License"); you may not use this file except in compliance with 15 | * the License. You may obtain a copy of the License at 16 | * http://www.mozilla.org/MPL/ 17 | * 18 | * Software distributed under the License is distributed on an "AS IS" basis, 19 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 20 | * for the specific language governing rights and limitations under the 21 | * License. 22 | * 23 | * The Original Code is MIDI constants. 24 | * 25 | * The Initial Developer of the Original Code is 26 | * David Churcher . 27 | * Portions created by the Initial Developer are Copyright (C) 1997 28 | * the Initial Developer. All Rights Reserved. 29 | * 30 | * Contributor(s): 31 | * Manuel Kroeber 32 | * 33 | * Alternatively, the contents of this file may be used under the terms of 34 | * either the GNU General Public License Version 3 or later (the "GPL"), or 35 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 36 | * in which case the provisions of the GPL or the LGPL are applicable instead 37 | * of those above. If you wish to allow use of your version of this file only 38 | * under the terms of either the GPL or the LGPL, and not to allow others to 39 | * use your version of this file under the terms of the MPL, indicate your 40 | * decision by deleting the provisions above and replace them with the notice 41 | * and other provisions required by the GPL or the LGPL. If you do not delete 42 | * the provisions above, a recipient may use your version of this file under 43 | * the terms of any one of the MPL, the GPL or the LGPL. 44 | * 45 | * ***** END LICENSE BLOCK ***** *) 46 | 47 | { MIDI Constants } 48 | unit MidiCons; 49 | 50 | interface 51 | 52 | uses Messages, SysUtils; 53 | 54 | const 55 | MIDI_ALLNOTESOFF = $7B; 56 | MIDI_NOTEON = $90; 57 | MIDI_NOTEOFF = $80; 58 | MIDI_KEYAFTERTOUCH = $a0; 59 | MIDI_CONTROLCHANGE = $b0; 60 | MIDI_PROGRAMCHANGE = $c0; 61 | MIDI_CHANAFTERTOUCH = $d0; 62 | MIDI_PITCHBEND = $e0; 63 | MIDI_SYSTEMMESSAGE = $f0; 64 | MIDI_BEGINSYSEX = $f0; 65 | MIDI_MTCQUARTERFRAME = $f1; 66 | MIDI_SONGPOSPTR = $f2; 67 | MIDI_SONGSELECT = $f3; 68 | MIDI_ENDSYSEX = $F7; 69 | MIDI_TIMINGCLOCK = $F8; 70 | MIDI_START = $FA; 71 | MIDI_CONTINUE = $FB; 72 | MIDI_STOP = $FC; 73 | MIDI_ACTIVESENSING = $FE; 74 | MIDI_SYSTEMRESET = $FF; 75 | 76 | MIM_OVERFLOW = WM_USER; { Input buffer overflow } 77 | MOM_PLAYBACK_DONE = WM_USER+1; { Timed playback complete } 78 | 79 | { device ID for MIDI mapper - copied from MMSystem } 80 | MIDIMAPPER = LongWord(-1); // UINT = LongWord as in Windows.pas 81 | MIDI_MAPPER = LongWord(-1); 82 | 83 | function MidiMessageToStr(const MidiMessage: Byte): string; 84 | 85 | implementation 86 | 87 | function MidiMessageToStr(const MidiMessage: Byte): string; 88 | begin 89 | case (MidiMessage and $F0) of 90 | MIDI_ALLNOTESOFF : Result := 'MIDI_ALLNOTESOFF'; 91 | MIDI_NOTEON : Result := 'MIDI_NOTEON'; 92 | MIDI_NOTEOFF : Result := 'MIDI_NOTEOFF'; 93 | MIDI_KEYAFTERTOUCH : Result := 'MIDI_KEYAFTERTOUCH'; 94 | MIDI_CONTROLCHANGE : Result := 'MIDI_CONTROLCHANGE'; 95 | MIDI_PROGRAMCHANGE : Result := 'MIDI_PROGRAMCHANGE'; 96 | MIDI_CHANAFTERTOUCH : Result := 'MIDI_CHANAFTERTOUCH'; 97 | MIDI_PITCHBEND : Result := 'MIDI_PITCHBEND'; 98 | MIDI_SYSTEMMESSAGE : Result := 'MIDI_BEGINSYSEX or MIDI_SYSTEMMESSAGE'; 99 | MIDI_MTCQUARTERFRAME : Result := 'MIDI_MTCQUARTERFRAME'; 100 | MIDI_SONGPOSPTR : Result := 'MIDI_SONGPOSPTR'; 101 | MIDI_SONGSELECT : Result := 'MIDI_SONGSELECT'; 102 | MIDI_ENDSYSEX : Result := 'MIDI_ENDSYSEX'; 103 | MIDI_TIMINGCLOCK : Result := 'MIDI_TIMINGCLOCK'; 104 | MIDI_START : Result := 'MIDI_START'; 105 | MIDI_CONTINUE : Result := 'MIDI_CONTINUE'; 106 | MIDI_STOP : Result := 'MIDI_STOP'; 107 | MIDI_ACTIVESENSING : Result := 'MIDI_ACTIVESENSING'; 108 | MIDI_SYSTEMRESET : Result := 'MIDI_SYSTEMRESET'; 109 | else 110 | Result := 'Unknown MIDI Message 0x' + 111 | IntToHex(MidiMessage, 2) + ' | ' + 112 | IntToStr(MidiMessage); 113 | end; 114 | end; 115 | 116 | end. 117 | -------------------------------------------------------------------------------- /MidiDefs.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/MIDIDEFS.PAS 2 10/06/97 7:33 Davec $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | (** 7 | * MidiDefs.pas v2010-05r1 8 | **) 9 | 10 | (* ***** BEGIN LICENSE BLOCK ***** 11 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 12 | * 13 | * The contents of this file are subject to the Mozilla Public License Version 14 | * 1.1 (the "License"); you may not use this file except in compliance with 15 | * the License. You may obtain a copy of the License at 16 | * http://www.mozilla.org/MPL/ 17 | * 18 | * Software distributed under the License is distributed on an "AS IS" basis, 19 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 20 | * for the specific language governing rights and limitations under the 21 | * License. 22 | * 23 | * The Original Code is MIDI type definitons. 24 | * 25 | * The Initial Developer of the Original Code is 26 | * David Churcher . 27 | * Portions created by the Initial Developer are Copyright (C) 1997 28 | * the Initial Developer. All Rights Reserved. 29 | * 30 | * Contributor(s): 31 | * Manuel Kroeber 32 | * 33 | * Alternatively, the contents of this file may be used under the terms of 34 | * either the GNU General Public License Version 3 or later (the "GPL"), or 35 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 36 | * in which case the provisions of the GPL or the LGPL are applicable instead 37 | * of those above. If you wish to allow use of your version of this file only 38 | * under the terms of either the GPL or the LGPL, and not to allow others to 39 | * use your version of this file under the terms of the MPL, indicate your 40 | * decision by deleting the provisions above and replace them with the notice 41 | * and other provisions required by the GPL or the LGPL. If you do not delete 42 | * the provisions above, a recipient may use your version of this file under 43 | * the terms of any one of the MPL, the GPL or the LGPL. 44 | * 45 | * ***** END LICENSE BLOCK ***** *) 46 | 47 | { Common definitions used by DELPHMID.DPR and the MIDI components. 48 | This must be a separate unit to prevent large chunks of the VCL being 49 | linked into the DLL. } 50 | unit MidiDefs; 51 | 52 | interface 53 | 54 | uses Windows, MMsystem, CircBuf; 55 | 56 | type 57 | {-------------------------------------------------------------------} 58 | { This is the information about the control that must be accessed by 59 | the MIDI input callback function in the DLL at interrupt time } 60 | PMidiCtlInfo = ^TMidiCtlInfo; 61 | TMidiCtlInfo = record 62 | hMem: THandle; { Memory handle for this record } 63 | PBuffer: PCircularBuffer; { Pointer to the MIDI input data buffer } 64 | hWindow: HWnd; { Control's window handle } 65 | SysexOnly: Boolean; { Only process System Exclusive input } 66 | FilterMTC: Boolean; { Filter Midi Time Code messages out } 67 | FilterAS: Boolean; { Filter Active Sensing messages out } 68 | end; 69 | 70 | { Information for the output timer callback function, also required at 71 | interrupt time. } 72 | PMidiOutTimerInfo = ^TMidiOutTimerInfo; 73 | TMidiOutTimerInfo = record 74 | hMem: THandle; { Memory handle for this record } 75 | PBuffer: PCircularBuffer; { Pointer to MIDI output data buffer } 76 | hWindow: HWnd; { Control's window handle } 77 | TimeToNextEvent: DWORD; { Delay to next event after timer set } 78 | MIDIHandle: HMidiOut; { MIDI handle to send output to 79 | (copy of component's FMidiHandle property) } 80 | PeriodMin: Word; { Multimedia timer minimum period supported } 81 | PeriodMax: Word; { Multimedia timer maximum period supported } 82 | TimerId: Word; { Multimedia timer ID of current event } 83 | end; 84 | 85 | implementation 86 | 87 | end. 88 | -------------------------------------------------------------------------------- /MidiDeviceComboBox.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/MidiDeviceComboBox.pas -------------------------------------------------------------------------------- /MidiEventStreamer.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/MidiEventStreamer.pas -------------------------------------------------------------------------------- /MidiFile.pas: -------------------------------------------------------------------------------- 1 | { 2 | Load a midifile and get access to tracks and events 3 | I did build this component to convert midifiles to wave files 4 | or play the files on a software synthesizer which I'm currenly 5 | building. 6 | 7 | version 1.0 first release 8 | 9 | version 1.1 10 | added some function 11 | function KeyToStr(key : integer) : string; 12 | function MyTimeToStr(val : integer) : string; 13 | Bpm can be set to change speed 14 | 15 | version 1.2 16 | added some functions 17 | function GetTrackLength:integer; 18 | function Ready: boolean; 19 | 20 | version 1.3 21 | update by Chulwoong, 22 | He knows how to use the MM timer, the timing is much better now, thank you 23 | 24 | for comments/bugs 25 | F.Bouwmans 26 | fbouwmans@spiditel.nl 27 | 28 | if you think this component is nice and you use it, sent me a short email. 29 | I've seen that other of my components have been downloaded a lot, but I've 30 | got no clue wether they are actually used. 31 | Don't worry because you are free to use these components 32 | 33 | Timing has improved, however because the messages are handled by the normal 34 | windows message loop (of the main window) it is still influenced by actions 35 | done on the window (minimize/maximize ..). 36 | Use of a second thread with higher priority which only handles the 37 | timer message should increase performance. If somebody knows such a component 38 | which is freeware please let me know. 39 | 40 | interface description: 41 | 42 | procedure ReadFile: 43 | actually read the file which is set in Filename 44 | 45 | function GetTrack(index: integer) : TMidiTrack; 46 | 47 | property Filename 48 | set/read filename of midifile 49 | 50 | property NumberOfTracks 51 | read number of tracks in current file 52 | 53 | property TicksPerQuarter: integer 54 | ticks per quarter, tells how to interpret the time value in midi events 55 | 56 | property FileFormat: TFileFormat 57 | tells the format of the current midifile 58 | 59 | property Bpm:integer 60 | tells Beats per minut 61 | 62 | property OnMidiEvent:TOnMidiEvent 63 | called while playing for each midi event 64 | 65 | procedure StartPlaying; 66 | start playing the current loaded midifile from the beginning 67 | 68 | procedure StopPlaying; 69 | stop playing the current midifile 70 | 71 | procedure PlayToTime(time : integer); 72 | if playing yourself then events from last time to this time are produced 73 | 74 | 75 | function KeyToStr(key : integer) : string; 76 | give note string on key value: e.g. C4 77 | 78 | function MyTimeToStr(val : integer) : string; 79 | give time string from msec time 80 | 81 | function GetTrackLength:integer; 82 | gives the track lenght in msec (assuming the bpm at the start oof the file) 83 | 84 | function Ready: boolean; 85 | now you can check wether the playback is finished 86 | 87 | } 88 | 89 | unit MidiFile; 90 | 91 | interface 92 | 93 | uses 94 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 95 | stdctrls, ExtCtrls, MMSystem; 96 | type 97 | TChunkType = (illegal, header, track); 98 | TFileFormat = (single, multi_synch, multi_asynch); 99 | PByte = ^byte; 100 | 101 | TMidiEvent = record 102 | event: byte; 103 | data1: byte; 104 | data2: byte; 105 | str: string; 106 | dticks: integer; 107 | time: integer; 108 | mtime: integer; 109 | len: integer; 110 | end; 111 | PMidiEvent = ^TMidiEvent; 112 | 113 | TOnMidiEvent = procedure(event: PMidiEvent) of object; 114 | TEvent = procedure of object; 115 | 116 | TMidiTrack = class(TObject) 117 | protected 118 | events: TList; 119 | name: string; 120 | instrument: string; 121 | currentTime: integer; 122 | currentPos: integer; 123 | ready: boolean; 124 | trackLenght: integer; 125 | procedure checkReady; 126 | public 127 | OnMidiEvent: TOnMidiEvent; 128 | OnTrackReady: TEvent; 129 | constructor Create; 130 | destructor Destroy; override; 131 | 132 | procedure Rewind(pos: integer); 133 | procedure PlayUntil(pos: integer); 134 | procedure GoUntil(pos: integer); 135 | 136 | procedure putEvent(event: PMidiEvent); 137 | function getEvent(index: integer): PMidiEvent; 138 | function getName: string; 139 | function getInstrument: string; 140 | function getEventCount: integer; 141 | function getCurrentTime: integer; 142 | function getTrackLength: integer; 143 | function isReady:boolean; 144 | end; 145 | 146 | TMidiFile = class(TComponent) 147 | private 148 | { Private declarations } 149 | procedure MidiTimer(sender : TObject); 150 | procedure WndProc(var Msg : TMessage); 151 | protected 152 | { Protected declarations } 153 | midiFile: file of byte; 154 | chunkType: TChunkType; 155 | chunkLength: integer; 156 | chunkData: PByte; 157 | chunkIndex: PByte; 158 | chunkEnd: PByte; 159 | FPriority: DWORD; 160 | 161 | // midi file attributes 162 | FFileFormat: TFileFormat; 163 | numberTracks: integer; 164 | deltaTicks: integer; 165 | FBpm: integer; 166 | FBeatsPerMeasure: integer; 167 | FusPerTick: double; 168 | FFilename: string; 169 | 170 | Tracks: TList; 171 | currentTrack: TMidiTrack; 172 | FOnMidiEvent: TOnMidiEvent; 173 | FOnUpdateEvent: TNotifyEvent; 174 | 175 | // playing attributes 176 | playing: boolean; 177 | PlayStartTime: Cardinal; 178 | currentTime: Cardinal; // Current playtime in msec 179 | currentPos: Double; // Current Position in ticks 180 | 181 | procedure OnTrackReady; 182 | procedure setFilename(val: string); 183 | procedure ReadChunkHeader; 184 | procedure ReadChunkContent; 185 | procedure ReadChunk; 186 | procedure ProcessHeaderChunk; 187 | procedure ProcessTrackChunk; 188 | function ReadVarLength: integer; 189 | function ReadString(l: integer): string; 190 | procedure SetOnMidiEvent(handler: TOnMidiEvent); 191 | procedure SetBpm(val: integer); 192 | public 193 | { Public declarations } 194 | constructor Create(AOwner: TComponent); override; 195 | destructor Destroy; override; 196 | 197 | procedure ReadFile; 198 | function GetTrack(index: integer): TMidiTrack; 199 | 200 | procedure StartPlaying; 201 | procedure StopPlaying; 202 | procedure ContinuePlaying; 203 | 204 | procedure PlayToTime(time: Cardinal); 205 | procedure GoToTime(time: Cardinal); 206 | function GetCurrentTime: Cardinal; 207 | function GetFusPerTick : Double; 208 | function GetTrackLength:integer; 209 | function Ready: boolean; 210 | published 211 | { Published declarations } 212 | property Filename: string read FFilename write setFilename; 213 | property NumberOfTracks: integer read numberTracks; 214 | property TicksPerQuarter: integer read deltaTicks; 215 | property FileFormat: TFileFormat read FFileFormat; 216 | property Bpm: integer read FBpm write SetBpm; 217 | property OnMidiEvent: TOnMidiEvent read FOnMidiEvent write SetOnMidiEvent; 218 | property OnUpdateEvent: TNotifyEvent read FOnUpdateEvent write FOnUpdateEvent; 219 | end; 220 | 221 | function KeyToStr(key: integer): string; 222 | function MyTimeToStr(val: integer): string; 223 | procedure Register; 224 | 225 | implementation 226 | 227 | type TTimerProc=procedure(uTimerID,uMsg: Integer; dwUser,dwParam1,dwParam2:DWORD);stdcall; 228 | 229 | const TIMER_RESOLUTION=10; 230 | const WM_MULTIMEDIA_TIMER=WM_USER+127; 231 | 232 | var MIDIFileHandle : HWND; 233 | TimerProc : TTimerProc; 234 | MIDITimerID : Integer; 235 | TimerPeriod : Integer; 236 | 237 | procedure TimerCallBackProc(uTimerID,uMsg: Integer; dwUser,dwParam1,dwParam2:DWORD);stdcall; 238 | begin 239 | PostMessage(HWND(dwUser),WM_MULTIMEDIA_TIMER,0,0); 240 | end; 241 | 242 | procedure SetMIDITimer; 243 | var TimeCaps : TTimeCaps ; 244 | begin 245 | timeGetDevCaps(@TimeCaps,SizeOf(TimeCaps)); 246 | if TIMER_RESOLUTION < TimeCaps.wPeriodMin then 247 | TimerPeriod:=TimeCaps.wPeriodMin 248 | else if TIMER_RESOLUTION > TimeCaps.wPeriodMax then 249 | TimerPeriod:=TimeCaps.wPeriodMax 250 | else 251 | TimerPeriod:=TIMER_RESOLUTION; 252 | 253 | timeBeginPeriod(TimerPeriod); 254 | MIDITimerID:=timeSetEvent(TimerPeriod,TimerPeriod,@TimerProc, 255 | DWORD(MIDIFileHandle),TIME_PERIODIC); 256 | if MIDITimerID=0 then 257 | timeEndPeriod(TimerPeriod); 258 | end; 259 | 260 | procedure KillMIDITimer; 261 | begin 262 | timeKillEvent(MIDITimerID); 263 | timeEndPeriod(TimerPeriod); 264 | end; 265 | 266 | constructor TMidiTrack.Create; 267 | begin 268 | inherited Create; 269 | events := TList.Create; 270 | currentTime := 0; 271 | currentPos := 0; 272 | end; 273 | 274 | destructor TMidiTrack.Destroy; 275 | var 276 | i: integer; 277 | begin 278 | for i := 0 to events.count - 1 do 279 | Dispose(PMidiEvent(events.items[i])); 280 | events.Free; 281 | inherited Destroy; 282 | end; 283 | 284 | procedure TMidiTRack.putEvent(event: PMidiEvent); 285 | var 286 | command: integer; 287 | i: integer; 288 | pevent: PMidiEvent; 289 | begin 290 | if (event.event = $FF) then 291 | begin 292 | if (event.data1 = 3) then 293 | name := event.str; 294 | if (event.data1 = 4) then 295 | instrument := event.str; 296 | end; 297 | currentTime := currentTime + event.dticks; 298 | event.time := currentTime; // for the moment just add dticks 299 | event.len := 0; 300 | events.add(TObject(event)); 301 | command := event.event and $F0; 302 | 303 | if ((command = $80) // note off 304 | or ((command = $90) and (event.data2 = 0))) //note on with speed 0 305 | then 306 | begin 307 | // this is a note off, try to find the accompanion note on 308 | command := event.event or $90; 309 | i := events.count - 2; 310 | while i >= 0 do 311 | begin 312 | pevent := PMidiEvent(events[i]); 313 | if (pevent.event = command) and 314 | (pevent.data1 = event.data1) 315 | then 316 | begin 317 | pevent.len := currentTIme - pevent.time; 318 | i := 0; 319 | event.len := -1; 320 | end; 321 | dec(i); 322 | end; 323 | end; 324 | end; 325 | 326 | function TMidiTrack.getName: string; 327 | begin 328 | result := name; 329 | end; 330 | 331 | function TMidiTrack.getInstrument: string; 332 | begin 333 | result := instrument; 334 | end; 335 | 336 | function TMiditrack.getEventCount: integer; 337 | begin 338 | result := events.count; 339 | end; 340 | 341 | function TMiditrack.getEvent(index: integer): PMidiEvent; 342 | begin 343 | if ((index < events.count) and (index >= 0)) then 344 | result := events[index] 345 | else 346 | result := nil; 347 | end; 348 | 349 | function TMiditrack.getCurrentTime: integer; 350 | begin 351 | result := currentTime; 352 | end; 353 | 354 | procedure TMiditrack.Rewind(pos: integer); 355 | begin 356 | if currentPos = events.count then 357 | dec(currentPos); 358 | while ((currentPos > 0) and 359 | (PMidiEvent(events[currentPos]).time > pos)) 360 | do 361 | begin 362 | dec(currentPos); 363 | end; 364 | checkReady; 365 | end; 366 | 367 | procedure TMiditrack.PlayUntil(pos: integer); 368 | begin 369 | if assigned(OnMidiEvent) then 370 | begin 371 | while ((currentPos < events.count) and 372 | (PMidiEvent(events[currentPos]).time < pos)) do 373 | begin 374 | OnMidiEvent(PMidiEvent(events[currentPos])); 375 | inc(currentPos); 376 | end; 377 | end; 378 | checkReady; 379 | end; 380 | 381 | procedure TMidiTrack.GoUntil(pos: integer); 382 | begin 383 | while ((currentPos < events.count) and 384 | (PMidiEvent(events[currentPos]).time < pos)) do 385 | begin 386 | inc(currentPos); 387 | end; 388 | checkReady; 389 | end; 390 | 391 | procedure TMidiTrack.checkReady; 392 | begin 393 | if currentPos >= events.count then 394 | begin 395 | ready := true; 396 | if assigned(OnTrackReady) then 397 | OnTrackReady; 398 | end 399 | else 400 | ready := false; 401 | end; 402 | 403 | function TMidiTrack.getTrackLength: integer; 404 | begin 405 | result := PMidiEvent(events[events.count-1]).time 406 | end; 407 | 408 | function TMidiTrack.isReady: boolean; 409 | begin 410 | result := ready; 411 | end; 412 | 413 | constructor TMidifile.Create(AOwner: TComponent); 414 | begin 415 | inherited Create(AOWner); 416 | MIDIFileHandle:=Classes.AllocateHWnd(WndProc); 417 | chunkData := nil; 418 | chunkType := illegal; 419 | Tracks := TList.Create; 420 | TimerProc:=TimerCallBackProc; 421 | FPriority:=GetPriorityClass(MIDIFileHandle); 422 | end; 423 | 424 | destructor TMidifile.Destroy; 425 | var 426 | i: integer; 427 | begin 428 | if not (chunkData = nil) then FreeMem(chunkData); 429 | for i := 0 to Tracks.Count - 1 do 430 | TMidiTrack(Tracks.Items[i]).Free; 431 | Tracks.Free; 432 | SetPriorityClass(MIDIFileHandle,FPriority); 433 | 434 | if MIDITimerID<>0 then KillMIDITimer; 435 | 436 | Classes.DeallocateHWnd(MIDIFileHandle); 437 | 438 | inherited Destroy; 439 | end; 440 | 441 | function TMidiFile.GetTrack(index: integer): TMidiTrack; 442 | begin 443 | result := Tracks.Items[index]; 444 | end; 445 | 446 | procedure TMidifile.setFilename(val: string); 447 | begin 448 | FFilename := val; 449 | // ReadFile; 450 | end; 451 | 452 | procedure TMidifile.SetOnMidiEvent(handler: TOnMidiEvent); 453 | var 454 | i: integer; 455 | begin 456 | // if not (FOnMidiEvent = handler) then 457 | // begin 458 | FOnMidiEvent := handler; 459 | for i := 0 to tracks.count - 1 do 460 | TMidiTrack(tracks.items[i]).OnMidiEvent := handler; 461 | // end; 462 | end; 463 | 464 | procedure TMidifile.MidiTimer(Sender: TObject); 465 | begin 466 | if playing then 467 | begin 468 | PlayToTime(GetTickCount - PlayStartTime); 469 | if assigned(FOnUpdateEvent) then FOnUpdateEvent(self); 470 | end; 471 | end; 472 | 473 | procedure TMidifile.StartPlaying; 474 | var 475 | i: integer; 476 | begin 477 | for i := 0 to tracks.count - 1 do 478 | TMidiTrack(tracks[i]).Rewind(0); 479 | playStartTime := getTickCount; 480 | playing := true; 481 | 482 | SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS); 483 | 484 | SetMIDITimer; 485 | currentPos := 0.0; 486 | currentTime := 0; 487 | end; 488 | 489 | procedure TMidifile.ContinuePlaying; 490 | begin 491 | PlayStartTime := GetTickCount - currentTime; 492 | playing := true; 493 | 494 | SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS); 495 | 496 | SetMIDITimer; 497 | end; 498 | 499 | procedure TMidifile.StopPlaying; 500 | begin 501 | playing := false; 502 | KillMIDITimer; 503 | SetPriorityClass(MIDIFileHandle,FPriority); 504 | end; 505 | 506 | function TMidiFile.GetCurrentTime: Cardinal; 507 | begin 508 | Result := currentTime; 509 | end; 510 | 511 | procedure TMidifile.PlayToTime(time: Cardinal); 512 | var 513 | i: integer; 514 | pos: integer; 515 | deltaTime: integer; 516 | begin 517 | // calculate the pos in the file. 518 | // pos is actually tick 519 | // Current FusPerTick is uses to determine the actual pos 520 | 521 | deltaTime := time - currentTime; 522 | currentPos := currentPos + (deltaTime * 1000) / FusPerTick; 523 | pos := round(currentPos); 524 | 525 | for i := 0 to tracks.count - 1 do 526 | begin 527 | TMidiTrack(tracks.items[i]).PlayUntil(pos); 528 | end; 529 | currentTime := time; 530 | end; 531 | 532 | procedure TMidifile.GoToTime(time: Cardinal); 533 | var 534 | i: integer; 535 | pos: integer; 536 | begin 537 | // this function should be changed because FusPerTick might not be constant 538 | pos := round((time * 1000) / FusPerTick); 539 | for i := 0 to tracks.count - 1 do 540 | begin 541 | TMidiTrack(tracks.items[i]).Rewind(0); 542 | TMidiTrack(tracks.items[i]).GoUntil(pos); 543 | end; 544 | end; 545 | 546 | procedure TMidifile.SetBpm(val: integer); 547 | var 548 | us_per_quarter: integer; 549 | begin 550 | if not (val = FBpm) then 551 | begin 552 | us_per_quarter := 60000000 div val; 553 | 554 | FBpm := 60000000 div us_per_quarter; 555 | FusPerTick := us_per_quarter / deltaTicks; 556 | end; 557 | end; 558 | 559 | procedure TMidifile.ReadChunkHeader; 560 | var 561 | theByte: array[0..7] of byte; 562 | begin 563 | BlockRead(midiFile, theByte, 8); 564 | if (theByte[0] = $4D) and (theByte[1] = $54) then 565 | begin 566 | if (theByte[2] = $68) and (theByte[3] = $64) then 567 | chunkType := header 568 | else if (theByte[2] = $72) and (theByte[3] = $6B) then 569 | chunkType := track 570 | else 571 | chunkType := illegal; 572 | end 573 | else 574 | begin 575 | chunkType := illegal; 576 | end; 577 | chunkLength := theByte[7] + theByte[6] * $100 + theByte[5] * $10000 + theByte[4] * $1000000; 578 | end; 579 | 580 | procedure TMidifile.ReadChunkContent; 581 | begin 582 | if not (chunkData = nil) then 583 | FreeMem(chunkData); 584 | GetMem(chunkData, chunkLength + 10); 585 | BlockRead(midiFile, chunkData^, chunkLength); 586 | chunkIndex := chunkData; 587 | chunkEnd := PByte(integer(chunkIndex) + integer(chunkLength) - 1); 588 | end; 589 | 590 | procedure TMidifile.ReadChunk; 591 | begin 592 | ReadChunkHeader; 593 | ReadChunkContent; 594 | case chunkType of 595 | header: 596 | ProcessHeaderChunk; 597 | track: 598 | ProcessTrackCHunk; 599 | end; 600 | end; 601 | 602 | procedure TMidifile.ProcessHeaderChunk; 603 | begin 604 | chunkIndex := chunkData; 605 | inc(chunkIndex); 606 | if chunkType = header then 607 | begin 608 | case chunkIndex^ of 609 | 0: FfileFormat := single; 610 | 1: FfileFormat := multi_synch; 611 | 2: FfileFormat := multi_asynch; 612 | end; 613 | inc(chunkIndex); 614 | numberTracks := chunkIndex^ * $100; 615 | inc(chunkIndex); 616 | numberTracks := numberTracks + chunkIndex^; 617 | inc(chunkIndex); 618 | deltaTicks := chunkIndex^ * $100; 619 | inc(chunkIndex); 620 | deltaTicks := deltaTicks + chunkIndex^; 621 | end; 622 | end; 623 | 624 | procedure TMidifile.ProcessTrackChunk; 625 | var 626 | dTime: integer; 627 | event: integer; 628 | len: integer; 629 | str: string; 630 | midiEvent: PMidiEvent; 631 | us_per_quarter: integer; 632 | begin 633 | chunkIndex := chunkData; 634 | // inc(chunkIndex); 635 | event := 0; 636 | if chunkType = track then 637 | begin 638 | currentTrack := TMidiTrack.Create; 639 | currentTrack.OnMidiEvent := FOnMidiEvent; 640 | Tracks.add(currentTrack); 641 | while integer(chunkIndex) < integer(chunkEnd) do 642 | begin 643 | // each event starts with var length delta time 644 | dTime := ReadVarLength; 645 | if chunkIndex^ >= $80 then 646 | begin 647 | event := chunkIndex^; 648 | inc(chunkIndex); 649 | end; 650 | // else it is a running status event (just the same event as before) 651 | 652 | if event = $FF then 653 | begin 654 | case chunkIndex^ of 655 | $00: // sequence number, not implemented jet 656 | begin 657 | inc(chunkIndex); // $02 658 | inc(chunkIndex); 659 | end; 660 | $01 .. $0F: // text events FF ty len text 661 | begin 662 | New(midiEvent); 663 | midiEvent.event := $FF; 664 | midiEvent.data1 := chunkIndex^; // type is stored in data1 665 | midiEvent.dticks := dTime; 666 | 667 | inc(chunkIndex); 668 | len := ReadVarLength; 669 | midiEvent.str := ReadString(len); 670 | 671 | currentTrack.putEvent(midiEvent); 672 | end; 673 | $20: // Midi channel prefix FF 20 01 cc 674 | begin 675 | inc(chunkIndex); // $01 676 | inc(chunkIndex); // channel 677 | inc(chunkIndex); 678 | end; 679 | $2F: // End of track FF 2F 00 680 | begin 681 | inc(chunkIndex); // $00 682 | inc(chunkIndex); 683 | end; 684 | $51: // Set Tempo FF 51 03 tttttt 685 | begin 686 | inc(chunkIndex); // $03 687 | inc(chunkIndex); // tt 688 | inc(chunkIndex); // tt 689 | inc(chunkIndex); // tt 690 | inc(chunkIndex); 691 | end; 692 | $54: // SMPTE offset FF 54 05 hr mn se fr ff 693 | begin 694 | inc(chunkIndex); // $05 695 | inc(chunkIndex); // hr 696 | inc(chunkIndex); // mn 697 | inc(chunkIndex); // se 698 | inc(chunkIndex); // fr 699 | inc(chunkIndex); // ff 700 | inc(chunkIndex); 701 | end; 702 | $58: // Time signature FF 58 04 nn dd cc bb 703 | begin 704 | inc(chunkIndex); // $04 705 | inc(chunkIndex); // nn 706 | inc(chunkIndex); // dd 707 | inc(chunkIndex); // cc 708 | inc(chunkIndex); // bb 709 | inc(chunkIndex); 710 | end; 711 | $59: // Key signature FF 59 02 df mi 712 | begin 713 | inc(chunkIndex); // $02 714 | inc(chunkIndex); // df 715 | inc(chunkIndex); // mi 716 | inc(chunkIndex); 717 | end; 718 | $7F: // Sequence specific Meta-event 719 | begin 720 | inc(chunkIndex); 721 | len := ReadVarLength; 722 | str := ReadString(len); 723 | end; 724 | else // unknown meta event 725 | 726 | begin 727 | New(midiEvent); 728 | midiEvent.event := $FF; 729 | midiEvent.data1 := chunkIndex^; // type is stored in data1 730 | midiEvent.dticks := dTime; 731 | 732 | inc(chunkIndex); 733 | len := ReadVarLength; 734 | midiEvent.str := ReadString(len); 735 | currentTrack.putEvent(midiEvent); 736 | 737 | case midiEvent.data1 of 738 | $51: 739 | begin 740 | us_per_quarter := (integer(byte(midiEvent.str[1])) 741 | shl 16 + integer(byte(midiEvent.str[2])) shl 8 + integer 742 | (byte(midiEvent.str[3]))); 743 | FBpm := 60000000 div us_per_quarter; 744 | FusPerTick := us_per_quarter / deltaTicks; 745 | end; 746 | end; 747 | end; 748 | end; 749 | end 750 | else 751 | begin 752 | // these are all midi events 753 | New(midiEvent); 754 | midiEvent.event := event; 755 | midiEvent.dticks := dTime; 756 | // inc(chunkIndex); 757 | case event of 758 | $80..$8F, // note off 759 | $90..$9F, // note on 760 | $A0..$AF, // key aftertouch 761 | $B0..$BF, // control change 762 | $E0..$EF: // pitch wheel change 763 | begin 764 | midiEvent.data1 := chunkIndex^; inc(chunkIndex); 765 | midiEvent.data2 := chunkIndex^; inc(chunkIndex); 766 | end; 767 | $C0..$CF, // program change 768 | $D0..$DF: // channel aftertouch 769 | begin 770 | midiEvent.data1 := chunkIndex^; inc(chunkIndex); 771 | end; 772 | else 773 | // error 774 | end; 775 | currentTrack.putEvent(midiEvent); 776 | end; 777 | end; 778 | end; 779 | end; 780 | 781 | 782 | function TMidifile.ReadVarLength: integer; 783 | var 784 | i: integer; 785 | b: byte; 786 | begin 787 | b := 128; 788 | i := 0; 789 | while b > 127 do 790 | begin 791 | i := i shl 7; 792 | b := chunkIndex^; 793 | i := i + b and $7F; 794 | inc(chunkIndex); 795 | end; 796 | result := i; 797 | end; 798 | 799 | function TMidifile.ReadString(l: integer): string; 800 | var 801 | s: PChar; 802 | i: integer; 803 | begin 804 | GetMem(s, l + 1); ; 805 | s[l] := chr(0); 806 | for i := 0 to l - 1 do 807 | begin 808 | s[i] := Chr(chunkIndex^); 809 | inc(chunkIndex); 810 | end; 811 | result := string(s); 812 | end; 813 | 814 | procedure TMidifile.ReadFile; 815 | var 816 | i: integer; 817 | begin 818 | for i := 0 to Tracks.Count - 1 do 819 | TMidiTrack(Tracks.Items[i]).Free; 820 | Tracks.Clear; 821 | chunkType := illegal; 822 | 823 | AssignFile(midiFile, FFilename); 824 | FileMode := 0; 825 | Reset(midiFile); 826 | while not eof(midiFile) do 827 | ReadChunk; 828 | CloseFile(midiFile); 829 | numberTracks := Tracks.Count; 830 | end; 831 | 832 | function KeyToStr(key: integer): string; 833 | var 834 | n: integer; 835 | str: string; 836 | begin 837 | n := key mod 12; 838 | case n of 839 | 0: str := 'C'; 840 | 1: str := 'C#'; 841 | 2: str := 'D'; 842 | 3: str := 'D#'; 843 | 4: str := 'E'; 844 | 5: str := 'F'; 845 | 6: str := 'F#'; 846 | 7: str := 'G'; 847 | 8: str := 'G#'; 848 | 9: str := 'A'; 849 | 10: str := 'A#'; 850 | 11: str := 'B'; 851 | end; 852 | Result := str + IntToStr(key div 12); 853 | end; 854 | 855 | function IntToLenStr(val: integer; len: integer): string; 856 | var 857 | str: string; 858 | begin 859 | str := IntToStr(val); 860 | while Length(str) < len do 861 | str := '0' + str; 862 | Result := str; 863 | end; 864 | 865 | function MyTimeToStr(val: integer): string; 866 | var 867 | hour: integer; 868 | min: integer; 869 | sec: integer; 870 | msec: integer; 871 | begin 872 | msec := val mod 1000; 873 | sec := val div 1000; 874 | min := sec div 60; 875 | sec := sec mod 60; 876 | hour := min div 60; 877 | min := min mod 60; 878 | Result := IntToStr(hour) + ':' + IntToLenStr(min, 2) + ':' + IntToLenStr(sec, 2) + '.' + IntToLenStr(msec, 3); 879 | end; 880 | 881 | function TMidiFIle.GetFusPerTick : Double; 882 | begin 883 | Result := FusPerTick; 884 | end; 885 | 886 | function TMidiFIle.GetTrackLength:integer; 887 | var i,length : integer; 888 | time : extended; 889 | begin 890 | length := 0; 891 | for i := 0 to Tracks.Count - 1 do 892 | if TMidiTrack(Tracks.Items[i]).getTrackLength > length then 893 | length := TMidiTrack(Tracks.Items[i]).getTrackLength; 894 | time := length * FusPerTick; 895 | time := time / 1000.0; 896 | result := round(time); 897 | end; 898 | 899 | function TMidiFIle.Ready: boolean; 900 | var i : integer; 901 | begin 902 | result := true; 903 | for i := 0 to Tracks.Count - 1 do 904 | if not TMidiTrack(Tracks.Items[i]).isready then 905 | result := false; 906 | end; 907 | 908 | procedure TMidiFile.OnTrackReady; 909 | begin 910 | if ready then 911 | if assigned(FOnUpdateEvent) then FOnUpdateEvent(self); 912 | end; 913 | 914 | procedure TMidiFile.WndProc(var Msg : TMessage); 915 | begin 916 | with MSG do 917 | begin 918 | case Msg of 919 | WM_MULTIMEDIA_TIMER: 920 | begin 921 | try 922 | MidiTimer(self); 923 | except 924 | Application.HandleException(Self); 925 | end; 926 | end; 927 | else 928 | begin 929 | Result := DefWindowProc(MIDIFileHandle, Msg, wParam, lParam); 930 | end; 931 | end; 932 | end; 933 | end; 934 | 935 | procedure Register; 936 | begin 937 | RegisterComponents('MIDI I/O', [TMidiFile]); 938 | end; 939 | 940 | end. 941 | -------------------------------------------------------------------------------- /MidiIn.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/Midiin.pas 4 28/02/01 11:35 Davec $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | (** 7 | * MidiIn.pas v2010-05r1 8 | **) 9 | 10 | (* ***** BEGIN LICENSE BLOCK ***** 11 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 12 | * 13 | * The contents of this file are subject to the Mozilla Public License Version 14 | * 1.1 (the "License"); you may not use this file except in compliance with 15 | * the License. You may obtain a copy of the License at 16 | * http://www.mozilla.org/MPL/ 17 | * 18 | * Software distributed under the License is distributed on an "AS IS" basis, 19 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 20 | * for the specific language governing rights and limitations under the 21 | * License. 22 | * 23 | * The Original Code is MIDI constants. 24 | * 25 | * The Initial Developer of the Original Code is 26 | * David Churcher . 27 | * Portions created by the Initial Developer are Copyright (C) 1997 28 | * the Initial Developer. All Rights Reserved. 29 | * 30 | * Contributor(s): 31 | * turboPASCAL < http://www.delphipraxis.net/user13047.html > 32 | * Manuel Kroeber 33 | * 34 | * Alternatively, the contents of this file may be used under the terms of 35 | * either the GNU General Public License Version 3 or later (the "GPL"), or 36 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 37 | * in which case the provisions of the GPL or the LGPL are applicable instead 38 | * of those above. If you wish to allow use of your version of this file only 39 | * under the terms of either the GPL or the LGPL, and not to allow others to 40 | * use your version of this file under the terms of the MPL, indicate your 41 | * decision by deleting the provisions above and replace them with the notice 42 | * and other provisions required by the GPL or the LGPL. If you do not delete 43 | * the provisions above, a recipient may use your version of this file under 44 | * the terms of any one of the MPL, the GPL or the LGPL. 45 | * 46 | * ***** END LICENSE BLOCK ***** *) 47 | 48 | unit MidiIn; 49 | 50 | { 51 | Properties: 52 | DeviceID: Windows numeric device ID for the MIDI input device. 53 | Between 0 and NumDevs-1. 54 | Read-only while device is open, exception when changed while open 55 | 56 | MIDIHandle: The input handle to the MIDI device. 57 | 0 when device is not open 58 | Read-only, runtime-only 59 | 60 | MessageCount: Number of input messages waiting in input buffer 61 | 62 | Capacity: Number of messages input buffer can hold 63 | Defaults to 1024 64 | Limited to (64K/event size) 65 | Read-only when device is open (exception when changed while open) 66 | 67 | SysexBufferSize: Size in bytes of each sysex buffer 68 | Defaults to 10K 69 | Minimum 0K (no buffers), Maximum 64K-1 70 | 71 | SysexBufferCount: Number of sysex buffers 72 | Defaults to 16 73 | Minimum 0 (no buffers), Maximum (avail mem/SysexBufferSize) 74 | Check where these buffers are allocated? 75 | 76 | SysexOnly: True to ignore all non-sysex input events. May be changed while 77 | device is open. Handy for patch editors where you have lots of short MIDI 78 | events on the wire which you are always going to ignore anyway. 79 | 80 | DriverVersion: Version number of MIDI device driver. High-order byte is 81 | major version, low-order byte is minor version. 82 | 83 | ProductName: Name of product (e.g. 'MPU 401 In') 84 | 85 | MID and PID: Manufacturer ID and Product ID, see 86 | "Manufacturer and Product IDs" in MMSYSTEM.HLP for list of possible values. 87 | 88 | Methods: 89 | GetMidiEvent: Read Midi event at the head of the FIFO input buffer. 90 | Returns a TMyMidiEvent object containing MIDI message data, timestamp, 91 | and sysex data if applicable. 92 | This method automatically removes the event from the input buffer. 93 | It makes a copy of the received sysex buffer and puts the buffer back 94 | on the input device. 95 | The TMyMidiEvent object must be freed by calling MyMidiEvent.Free. 96 | 97 | Open: Opens device. Note no input will appear until you call the Start 98 | method. 99 | 100 | Close: Closes device. Any pending system exclusive output will be cancelled. 101 | 102 | Start: Starts receiving MIDI input. 103 | 104 | Stop: Stops receiving MIDI input. 105 | 106 | Events: 107 | OnMidiInput: Called when MIDI input data arrives. Use the GetMidiEvent to 108 | get the MIDI input data. 109 | 110 | OnOverflow: Called if the MIDI input buffer overflows. The caller must 111 | clear the buffer before any more MIDI input can be received. 112 | 113 | Notes: 114 | Buffering: Uses a circular buffer, separate pointers for next location 115 | to fill and next location to empty because a MIDI input interrupt may 116 | be adding data to the buffer while the buffer is being read. Buffer 117 | pointers wrap around from end to start of buffer automatically. If 118 | buffer overflows then the OnBufferOverflow event is triggered and no 119 | further input will be received until the buffer is emptied by calls 120 | to GetMidiEvent. 121 | 122 | Sysex buffers: There are (SysexBufferCount) buffers on the input device. 123 | When sysex events arrive these buffers are removed from the input device and 124 | added to the circular buffer by the interrupt handler in the DLL. When the sysex events 125 | are removed from the circular buffer by the GetMidiEvent method the buffers are 126 | put back on the input. If all the buffers are used up there will be no 127 | more sysex input until at least one sysex event is removed from the input buffer. 128 | In other words if you're expecting lots of sysex input you need to set the 129 | SysexBufferCount property high enough so that you won't run out of 130 | input buffers before you get a chance to read them with GetMidiEvent. 131 | 132 | If the synth sends a block of sysex that's longer than SysexBufferSize it 133 | will be received as separate events. 134 | TODO: Component derived from this one that handles >64K sysex blocks cleanly 135 | and can stream them to disk. 136 | 137 | Midi Time Code (MTC) and Active Sensing: The DLL is currently hardcoded 138 | to filter these short events out, so that we don't spend all our time 139 | processing them. 140 | TODO: implement a filter property to select the events that will be filtered 141 | out. 142 | } 143 | 144 | interface 145 | 146 | uses 147 | Classes, SysUtils, Messages, Windows, 148 | 149 | MMSystem, 150 | MidiDefs, MidiType, MidiCons, CircBuf, MidiCallback; 151 | 152 | type 153 | MidiInputState = (misOpen, misClosed, misCreating, misDestroying); 154 | EMidiInputError = class(Exception); 155 | 156 | {-------------------------------------------------------------------} 157 | TMidiInput = class(TMidiIO) 158 | private 159 | Handle: THandle; { Window handle used for callback notification } 160 | FDeviceID: Cardinal; { MIDI device ID } 161 | FMIDIHandle: HMIDIIn; { Handle to input device } 162 | FState: MidiInputState; { Current device state } 163 | 164 | FError: Word; 165 | FSysexOnly: Boolean; 166 | FMsgFilter: TMidiMsgFilter; 167 | 168 | { Stuff from MIDIINCAPS } 169 | FDriverVersion: Version; 170 | FProductName: string; 171 | FMID: Word; { Manufacturer ID } 172 | FPID: Word; { Product ID } 173 | 174 | { Queue } 175 | FCapacity: Word; { Buffer capacity } 176 | PBuffer: PCircularBuffer; { Low-level MIDI input buffer created by Open method } 177 | FNumDevs: Cardinal; { Number of input devices on system } 178 | 179 | { Events } 180 | FOnMIDIInput: TNotifyEvent; { MIDI Input arrived } 181 | FOnOverflow: TNotifyEvent; { Input buffer overflow } 182 | FOnDeviceChanged: TNotifyEvent; // after successfully changing the DeviceID 183 | { TODO: Some sort of error handling event for MIM_ERROR } 184 | 185 | { Sysex } 186 | FSysexBufferSize: Word; 187 | FSysexBufferCount: Word; 188 | MidiHdrs: Tlist; 189 | 190 | PCtlInfo: PMidiCtlInfo; { Pointer to control info for DLL } 191 | 192 | protected 193 | procedure Prepareheaders; 194 | procedure UnprepareHeaders; 195 | procedure AddBuffers; 196 | procedure SetDeviceID(DeviceID: Cardinal); 197 | procedure SetProductName(NewProductName: String); 198 | function GetEventCount: Word; 199 | procedure SetSysexBufferSize(const BufferSize: Word); 200 | procedure SetSysexBufferCount(const BufferCount: Word); 201 | procedure SetSysexOnly(const bSysexOnly: Boolean); 202 | procedure SetMsgFilter(const Value: TMidiMsgFilter); 203 | function MidiInErrorString(WError: Word): String; 204 | 205 | public 206 | constructor Create(AOwner: TComponent); override; 207 | destructor Destroy; override; 208 | 209 | property MIDIHandle: HMIDIIn read FMIDIHandle; 210 | 211 | property DriverVersion: Version read FDriverVersion; 212 | property MID: Word read FMID; { Manufacturer ID } 213 | property PID: Word read FPID; { Product ID } 214 | 215 | property NumDevs: Cardinal read FNumDevs; // Buffered output 216 | 217 | property MessageCount: Word read GetEventCount; 218 | property State: MidiInputState read FState; 219 | 220 | procedure Open; 221 | procedure Close; 222 | procedure Start; 223 | procedure Stop; 224 | 225 | function DeviceCount: Cardinal; override; 226 | 227 | procedure OpenAndStart; 228 | procedure StopAndClose; 229 | 230 | procedure ChangeDevice(const NewDeviceID: Cardinal; 231 | const OpenAndStartAfterChange: Boolean = True); 232 | 233 | { Get first message in input queue } 234 | function GetMidiEvent: TMyMidiEvent; 235 | procedure MidiInput(var AMessage: TMessage); 236 | procedure FlushQueue; // discard all queued events 237 | 238 | { Some functions to decode and classify incoming messages would be good } 239 | 240 | published 241 | { TODO: Property editor with dropdown list of product names } 242 | property ProductName: String read FProductName write SetProductName; 243 | 244 | property DeviceID: Cardinal read FDeviceID write SetDeviceID default 0; 245 | property Capacity: Word read FCapacity write FCapacity default 1024; 246 | property Error: Word read FError; 247 | property SysexBufferSize 248 | : Word read FSysexBufferSize write SetSysexBufferSize default 10000; 249 | property SysexBufferCount 250 | : Word read FSysexBufferCount write SetSysexBufferCount default 16; 251 | property SysexOnly 252 | : Boolean read FSysexOnly write SetSysexOnly default False; 253 | property FilteredMessages 254 | : TMidiMsgFilter read FMsgFilter write SetMsgFilter; 255 | 256 | 257 | { Events } 258 | property OnMidiInput: TNotifyEvent read FOnMIDIInput write FOnMIDIInput; 259 | property OnOverflow: TNotifyEvent read FOnOverflow write FOnOverflow; 260 | property OnDeviceChanged: TNotifyEvent 261 | read FOnDeviceChanged write FOnDeviceChanged; 262 | end; 263 | 264 | procedure Register; 265 | 266 | {====================================================================} 267 | implementation 268 | 269 | {-------------------------------------------------------------------} 270 | constructor TMidiInput.Create(AOwner:TComponent); 271 | begin 272 | inherited Create(AOwner); 273 | FState := misCreating; 274 | 275 | FSysexOnly := False; 276 | FNumDevs := midiInGetNumDevs; 277 | MidiHdrs := Nil; 278 | FMidiHandle := 0; 279 | 280 | { Set defaults } 281 | if FNumDevs > 0 then 282 | SetDeviceID(0); 283 | FCapacity := 1024; 284 | FSysexBufferSize := 4096; 285 | FSysexBufferCount := 16; 286 | 287 | { Create the window for callback notification } 288 | if not (csDesigning in ComponentState) then 289 | begin 290 | Handle := Classes.AllocateHWnd(MidiInput); 291 | end; 292 | 293 | PCtlInfo := nil; 294 | FMsgFilter := [msgActiveSensing, msgMidiTimeCode]; 295 | 296 | FState := misClosed; 297 | end; 298 | 299 | {-------------------------------------------------------------------} 300 | { Close the device if it's open } 301 | destructor TMidiInput.Destroy; 302 | begin 303 | if (FMidiHandle <> 0) then 304 | begin 305 | Close; 306 | FMidiHandle := 0; 307 | end; 308 | 309 | if (PCtlInfo <> nil) then 310 | GlobalSharedLockedFree( PCtlinfo^.hMem, PCtlInfo ); 311 | 312 | Classes.DeallocateHWnd(Handle); 313 | 314 | inherited Destroy; 315 | end; 316 | 317 | function TMidiInput.DeviceCount: Cardinal; 318 | begin 319 | FNumDevs := midiInGetNumDevs; 320 | Result := FNumDevs; 321 | end; 322 | 323 | procedure TMidiInput.FlushQueue; 324 | begin 325 | while (MessageCount > 0) do 326 | begin 327 | // get event and free it immediatly 328 | GetMidiEvent.Free; 329 | end; 330 | end; 331 | 332 | {-------------------------------------------------------------------} 333 | { Convert the numeric return code from an MMSYSTEM function to a string 334 | using midiInGetErrorText. TODO: These errors aren't very helpful 335 | (e.g. "an invalid parameter was passed to a system function") so 336 | sort out some proper error strings. } 337 | function TMidiInput.MidiInErrorString( WError: Word ): String; 338 | var 339 | errorDesc: PChar; 340 | begin 341 | errorDesc := Nil; 342 | try 343 | errorDesc := StrAlloc(MAXERRORLENGTH); 344 | if midiInGetErrorText(WError, errorDesc, MAXERRORLENGTH) = 0 then 345 | result := StrPas(errorDesc) 346 | else 347 | result := 'Specified error number is out of range'; 348 | finally 349 | if errorDesc <> Nil then StrDispose(errorDesc); 350 | end; 351 | end; 352 | 353 | {-------------------------------------------------------------------} 354 | { Set the sysex buffer size, fail if device is already open } 355 | procedure TMidiInput.SetSysexBufferSize(const BufferSize: Word); 356 | begin 357 | if FState = misOpen then 358 | raise EMidiInputError.Create('Change to SysexBufferSize while device was open') 359 | else 360 | { TODO: Validate the sysex buffer size. Is this necessary for WIN32? } 361 | FSysexBufferSize := BufferSize; 362 | end; 363 | 364 | {-------------------------------------------------------------------} 365 | { Set the sysex buffer count, fail if device is already open } 366 | procedure TMidiInput.SetSysexBufferCount(const BufferCount: Word); 367 | begin 368 | if FState = misOpen then 369 | raise EMidiInputError.Create('Change to SysexBufferCount while device was open') 370 | else 371 | { TODO: Validate the sysex buffer count } 372 | FSysexBufferCount := BufferCount; 373 | end; 374 | 375 | {-------------------------------------------------------------------} 376 | { Set the Sysex Only flag to eliminate unwanted short MIDI input messages } 377 | procedure TMidiInput.SetSysexOnly(const bSysexOnly: Boolean); 378 | begin 379 | FSysexOnly := bSysexOnly; 380 | { Update the interrupt handler's copy of this property } 381 | if PCtlInfo <> Nil then 382 | PCtlInfo^.SysexOnly := bSysexOnly; 383 | end; 384 | 385 | {-------------------------------------------------------------------} 386 | { Set the Device ID to select a new MIDI input device 387 | Note: If no MIDI devices are installed, throws an 'Invalid Device ID' exception } 388 | procedure TMidiInput.SetDeviceID(DeviceID: Cardinal); 389 | var 390 | MidiInCaps: TMidiInCaps; 391 | begin 392 | if FState = misOpen then 393 | raise EMidiInputError.Create('Change to DeviceID while device was open') 394 | else 395 | begin 396 | if (DeviceID >= midiInGetNumDevs) and (DeviceID <> MIDI_MAPPER) then 397 | raise EMidiInputError.Create('Invalid device ID') 398 | else 399 | begin 400 | FDeviceID := DeviceID; 401 | 402 | { Set the name and other MIDIINCAPS properties to match the ID } 403 | FError := 404 | midiInGetDevCaps(DeviceID, @MidiInCaps, sizeof(TMidiInCaps)); 405 | 406 | if Ferror <> MMSYSERR_NOERROR then 407 | raise EMidiInputError.Create(MidiInErrorString(FError)); 408 | 409 | FProductName := StrPas(MidiInCaps.szPname); 410 | FDriverVersion := MidiInCaps.vDriverVersion; 411 | FMID := MidiInCaps.wMID; 412 | FPID := MidiInCaps.wPID; 413 | 414 | if Assigned(FOnDeviceChanged) then 415 | FOnDeviceChanged(Self); 416 | end; 417 | end; 418 | end; 419 | 420 | procedure TMidiInput.SetMsgFilter(const Value: TMidiMsgFilter); 421 | begin 422 | FMsgFilter := Value; 423 | 424 | if (PCtlInfo <> nil) then 425 | begin 426 | PCtlInfo^.FilterMTC := (msgMidiTimeCode in FMsgFilter); 427 | PCtlInfo^.FilterAS := (msgActiveSensing in FMsgFilter); 428 | end; 429 | end; 430 | 431 | {-------------------------------------------------------------------} 432 | { Set the product name and put the matching input device number in FDeviceID. 433 | This is handy if you want to save a configured input/output device 434 | by device name instead of device number, because device numbers may 435 | change if users add or remove MIDI devices. 436 | Exception if input device with matching name not found, 437 | or if input device is open } 438 | procedure TMidiInput.SetProductName( NewProductName: String ); 439 | var 440 | MidiInCaps: TMidiInCaps; 441 | testDeviceID: Cardinal; 442 | testProductName: String; 443 | begin 444 | if FState = misOpen then 445 | raise EMidiInputError.Create('Change to ProductName while device was open') 446 | else 447 | { Don't set the name if the component is reading properties because 448 | the saved Productname will be from the machine the application was compiled 449 | on, which may not be the same for the corresponding DeviceID on the user's 450 | machine. The FProductname property will still be set by SetDeviceID } 451 | if not (csLoading in ComponentState) then 452 | begin 453 | begin 454 | for testDeviceID := 0 To (midiInGetNumDevs-1) do 455 | begin 456 | FError := 457 | midiInGetDevCaps(testDeviceID, @MidiInCaps, sizeof(TMidiInCaps)); 458 | if Ferror <> MMSYSERR_NOERROR then 459 | raise EMidiInputError.Create(MidiInErrorString(FError)); 460 | testProductName := StrPas(MidiInCaps.szPname); 461 | if testProductName = NewProductName then 462 | begin 463 | FProductName := NewProductName; 464 | Break; 465 | end; 466 | end; 467 | if FProductName <> NewProductName then 468 | raise EMidiInputError.Create('MIDI Input Device ' + 469 | NewProductName + ' not installed ') 470 | else 471 | SetDeviceID(testDeviceID); 472 | end; 473 | end; 474 | end; 475 | 476 | 477 | {-------------------------------------------------------------------} 478 | { Get the sysex buffers ready } 479 | procedure TMidiInput.PrepareHeaders; 480 | var 481 | ctr: Word; 482 | MyMidiHdr: TMyMidiHdr; 483 | begin 484 | if (FSysexBufferCount > 0) And (FSysexBufferSize > 0) 485 | And (FMidiHandle <> 0) then 486 | begin 487 | Midihdrs := TList.Create; 488 | for ctr := 1 to FSysexBufferCount do 489 | begin 490 | { Initialize the header and allocate buffer memory } 491 | MyMidiHdr := TMyMidiHdr.Create(FSysexBufferSize); 492 | 493 | { Store the address of the MyMidiHdr object in the contained MIDIHDR 494 | structure so we can get back to the object when a pointer to the 495 | MIDIHDR is received. 496 | E.g. see TMidiOutput.Output method } 497 | MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr); 498 | 499 | { Get MMSYSTEM's blessing for this header } 500 | FError := midiInPrepareHeader(FMidiHandle,MyMidiHdr.hdrPointer, 501 | sizeof(TMIDIHDR)); 502 | if Ferror <> MMSYSERR_NOERROR then 503 | raise EMidiInputError.Create(MidiInErrorString(FError)); 504 | 505 | { Save it in our list } 506 | MidiHdrs.Add(MyMidiHdr); 507 | end; 508 | end; 509 | 510 | end; 511 | 512 | {-------------------------------------------------------------------} 513 | { Clean up from PrepareHeaders } 514 | procedure TMidiInput.UnprepareHeaders; 515 | var 516 | ctr: Word; 517 | begin 518 | if (MidiHdrs<> Nil) then { will be Nil if 0 sysex buffers } 519 | begin 520 | for ctr := 0 To MidiHdrs.Count-1 do 521 | begin 522 | FError := midiInUnprepareHeader( FMidiHandle, 523 | TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer, 524 | sizeof(TMIDIHDR)); 525 | if Ferror <> MMSYSERR_NOERROR then 526 | raise EMidiInputError.Create(MidiInErrorString(FError)); 527 | TMyMidiHdr(MidiHdrs.Items[ctr]).Free; 528 | end; 529 | MidiHdrs.Free; 530 | MidiHdrs := Nil; 531 | end; 532 | end; 533 | 534 | {-------------------------------------------------------------------} 535 | { Add sysex buffers, if required, to input device } 536 | procedure TMidiInput.AddBuffers; 537 | var 538 | ctr: Word; 539 | begin 540 | if MidiHdrs <> Nil then { will be Nil if 0 sysex buffers } 541 | begin 542 | if MidiHdrs.Count > 0 Then 543 | begin 544 | for ctr := 0 To MidiHdrs.Count-1 do 545 | begin 546 | FError := midiInAddBuffer(FMidiHandle, 547 | TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer, 548 | sizeof(TMIDIHDR)); 549 | If FError <> MMSYSERR_NOERROR then 550 | raise EMidiInputError.Create(MidiInErrorString(FError)); 551 | end; 552 | end; 553 | end; 554 | end; 555 | 556 | {-------------------------------------------------------------------} 557 | procedure TMidiInput.Open; 558 | var 559 | hMem: THandle; 560 | begin 561 | try 562 | { Create the buffer for the MIDI input messages } 563 | if (PBuffer = Nil) then 564 | PBuffer := CircBufAlloc( FCapacity ); 565 | 566 | { Create the control info for the DLL } 567 | if (PCtlInfo = Nil) then 568 | begin 569 | PCtlInfo := GlobalSharedLockedAlloc( Sizeof(TMidiCtlInfo), hMem ); 570 | PctlInfo^.hMem := hMem; 571 | end; 572 | 573 | PctlInfo^.pBuffer := PBuffer; 574 | Pctlinfo^.hWindow := Handle; { Control's window handle } 575 | PCtlInfo^.SysexOnly := FSysexOnly; 576 | PCtlInfo^.FilterMTC := (msgMidiTimeCode in FMsgFilter); 577 | PCtlInfo^.FilterAS := (msgActiveSensing in FMsgFilter); 578 | 579 | FError := midiInOpen(@FMidiHandle, FDeviceId, 580 | DWORD(@midiHandler), 581 | DWORD(PCtlInfo), 582 | CALLBACK_FUNCTION); 583 | 584 | If (FError <> MMSYSERR_NOERROR) then 585 | { TODO: use CreateFmtHelp to add MIDI device name/ID to message } 586 | raise EMidiInputError.Create(MidiInErrorString(FError)); 587 | 588 | { Get sysex buffers ready } 589 | PrepareHeaders; 590 | 591 | { Add them to the input } 592 | AddBuffers; 593 | 594 | FState := misOpen; 595 | 596 | except 597 | if PBuffer <> Nil then 598 | begin 599 | CircBufFree(PBuffer); 600 | PBuffer := Nil; 601 | end; 602 | 603 | if PCtlInfo <> Nil then 604 | begin 605 | GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo); 606 | PCtlInfo := Nil; 607 | end; 608 | 609 | if ( FMidiHandle <> 0 ) then 610 | begin 611 | { Exception occurred after midiInOpen } 612 | FError := MidiInClose(FMidiHandle); 613 | FMidiHandle := 0; 614 | end; 615 | { Send exception to caller } 616 | raise; 617 | end; 618 | 619 | end; 620 | 621 | procedure TMidiInput.OpenAndStart; 622 | begin 623 | Open; 624 | Start; 625 | end; 626 | 627 | {-------------------------------------------------------------------} 628 | function TMidiInput.GetMidiEvent: TMyMidiEvent; 629 | var 630 | thisItem: TMidiBufferItem; 631 | begin 632 | if (FState = misOpen) and 633 | CircBufReadEvent(PBuffer, @thisItem) then 634 | begin 635 | Result := TMyMidiEvent.Create; 636 | with thisItem Do 637 | begin 638 | Result.Time := Timestamp; 639 | if (Sysex = Nil) then 640 | begin 641 | { Short message } 642 | Result.MidiMessage := LoByte(LoWord(Data)); 643 | Result.Data1 := HiByte(LoWord(Data)); 644 | Result.Data2 := LoByte(HiWord(Data)); 645 | Result.Sysex := Nil; 646 | Result.SysexLength := 0; 647 | end 648 | else 649 | { Long Sysex message } 650 | begin 651 | Result.MidiMessage := MIDI_BEGINSYSEX; 652 | Result.Data1 := 0; 653 | Result.Data2 := 0; 654 | Result.SysexLength := Sysex^.dwBytesRecorded; 655 | if Sysex^.dwBytesRecorded <> 0 then 656 | begin 657 | { Put a copy of the sysex buffer in the object } 658 | GetMem(Result.Sysex, Sysex^.dwBytesRecorded); 659 | StrMove(Result.Sysex, Sysex^.lpData, Sysex^.dwBytesRecorded); 660 | { If you don't zero this out some MIDI drivers append new data to the old data } 661 | Sysex^.dwBytesRecorded := 0; 662 | end; 663 | 664 | { Put the header back on the input buffer } 665 | FError := midiInPrepareHeader(FMidiHandle,Sysex, 666 | sizeof(TMIDIHDR)); 667 | If Ferror = 0 then 668 | FError := midiInAddBuffer(FMidiHandle, Sysex, sizeof(TMIDIHDR)); 669 | 670 | if Ferror <> MMSYSERR_NOERROR then 671 | raise EMidiInputError.Create(MidiInErrorString(FError)); 672 | 673 | end; 674 | end; 675 | CircbufRemoveEvent(PBuffer); 676 | end 677 | else 678 | { Device isn't open, return a nil event } 679 | Result := Nil; 680 | end; 681 | 682 | {-------------------------------------------------------------------} 683 | 684 | function TMidiInput.GetEventCount: Word; 685 | begin 686 | if FState = misOpen then 687 | Result := PBuffer^.EventCount 688 | else 689 | Result := 0; 690 | end; 691 | 692 | {-------------------------------------------------------------------} 693 | procedure TMidiInput.ChangeDevice(const NewDeviceID: Cardinal; 694 | const OpenAndStartAfterChange: Boolean); 695 | begin 696 | if NewDeviceID <> FDeviceID then 697 | begin 698 | Stop; 699 | Close; 700 | DeviceID := NewDeviceID; 701 | if OpenAndStartAfterChange then 702 | begin 703 | Open; 704 | Start; 705 | end; 706 | end; 707 | end; 708 | 709 | procedure TMidiInput.Close; 710 | begin 711 | if FState = misOpen then 712 | begin 713 | FState := misClosed; 714 | 715 | { MidiInReset cancels any pending output. 716 | Note that midiInReset causes an MIM_LONGDATA callback for each sysex 717 | buffer on the input, so the callback function and Midi input buffer 718 | should still be viable at this stage. 719 | All the resulting MIM_LONGDATA callbacks will be completed by the time 720 | MidiInReset returns, though. } 721 | FError := MidiInReset(FMidiHandle); 722 | if Ferror <> MMSYSERR_NOERROR then 723 | raise EMidiInputError.Create(MidiInErrorString(FError)); 724 | 725 | { Remove sysex buffers from input device and free them } 726 | UnPrepareHeaders; 727 | 728 | { Close the device (finally!) } 729 | FError := MidiInClose(FMidiHandle); 730 | if Ferror <> MMSYSERR_NOERROR then 731 | raise EMidiInputError.Create(MidiInErrorString(FError)); 732 | 733 | FMidiHandle := 0; 734 | 735 | if (PBuffer <> Nil) then 736 | begin 737 | CircBufFree( PBuffer ); 738 | PBuffer := Nil; 739 | end; 740 | end; 741 | end; 742 | 743 | {-------------------------------------------------------------------} 744 | procedure TMidiInput.Start; 745 | begin 746 | if FState = misOpen then 747 | begin 748 | FError := MidiInStart(FMidiHandle); 749 | if Ferror <> MMSYSERR_NOERROR then 750 | raise EMidiInputError.Create(MidiInErrorString(FError)); 751 | end; 752 | end; 753 | 754 | {-------------------------------------------------------------------} 755 | procedure TMidiInput.Stop; 756 | begin 757 | if FState = misOpen then 758 | begin 759 | FError := MidiInStop(FMidiHandle); 760 | if Ferror <> MMSYSERR_NOERROR then 761 | raise EMidiInputError.Create(MidiInErrorString(FError)); 762 | end; 763 | end; 764 | 765 | procedure TMidiInput.StopAndClose; 766 | begin 767 | Stop; 768 | Close; 769 | end; 770 | 771 | {-------------------------------------------------------------------} 772 | procedure TMidiInput.MidiInput( var AMessage: TMessage ); 773 | { Triggered by incoming message from DLL. 774 | Note DLL has already put the message in the queue } 775 | begin 776 | case AMessage.Msg of 777 | mim_data: 778 | { Trigger the user's MIDI input event, if they've specified one and 779 | we're not in the process of closing the device. The check for 780 | GetEventCount > 0 prevents unnecessary event calls where the user has 781 | already cleared all the events from the input buffer using a GetMidiEvent 782 | loop in the OnMidiInput event handler } 783 | if Assigned(FOnMIDIInput) and 784 | (FState = misOpen) and 785 | (GetEventCount > 0) 786 | then 787 | FOnMIDIInput(Self); 788 | 789 | mim_Overflow: { input circular buffer overflow } 790 | if Assigned(FOnOverflow) and (FState = misOpen) then 791 | FOnOverflow(Self); 792 | 793 | WM_QUERYENDSESSION: 794 | // Have to handle this explicitly otherwise DefWindowProc doesn't set the 795 | // result and app doesn't shut down when Windows shuts down or user logs off 796 | AMessage.Result := 1; 797 | end; 798 | end; 799 | 800 | {-------------------------------------------------------------------} 801 | procedure Register; 802 | begin 803 | RegisterComponents('MIDI I/O', [TMidiInput]); 804 | end; 805 | 806 | end. 807 | -------------------------------------------------------------------------------- /MidiKeyPatchArray.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/MidiKeyPatchArray.pas -------------------------------------------------------------------------------- /MidiOut.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/MidiOut.pas 3 28/02/01 11:24 Davec $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | { Thanks very much to Fred Kohler for the Technology code. } 7 | 8 | (** 9 | * MidiOut.pas v2010-05r1 10 | **) 11 | 12 | (* ***** BEGIN LICENSE BLOCK ***** 13 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 14 | * 15 | * The contents of this file are subject to the Mozilla Public License Version 16 | * 1.1 (the "License"); you may not use this file except in compliance with 17 | * the License. You may obtain a copy of the License at 18 | * http://www.mozilla.org/MPL/ 19 | * 20 | * Software distributed under the License is distributed on an "AS IS" basis, 21 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 22 | * for the specific language governing rights and limitations under the 23 | * License. 24 | * 25 | * The Original Code is TMidiOutput class. 26 | * 27 | * The Initial Developer of the Original Code is 28 | * David Churcher . 29 | * Portions created by the Initial Developer are Copyright (C) 1997 30 | * the Initial Developer. All Rights Reserved. 31 | * 32 | * Contributor(s): 33 | * turboPASCAL < http://www.delphipraxis.net/user13047.html > 34 | * FAlter < http://www.delphipraxis.net/user7745.html > 35 | * Manuel Kroeber 36 | * 37 | * Alternatively, the contents of this file may be used under the terms of 38 | * either the GNU General Public License Version 3 or later (the "GPL"), or 39 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 40 | * in which case the provisions of the GPL or the LGPL are applicable instead 41 | * of those above. If you wish to allow use of your version of this file only 42 | * under the terms of either the GPL or the LGPL, and not to allow others to 43 | * use your version of this file under the terms of the MPL, indicate your 44 | * decision by deleting the provisions above and replace them with the notice 45 | * and other provisions required by the GPL or the LGPL. If you do not delete 46 | * the provisions above, a recipient may use your version of this file under 47 | * the terms of any one of the MPL, the GPL or the LGPL. 48 | * 49 | * ***** END LICENSE BLOCK ***** *) 50 | 51 | unit MidiOut; 52 | 53 | { 54 | MIDI Output component. 55 | 56 | Properties: 57 | DeviceID: Windows numeric device ID for the MIDI output device. 58 | Between 0 and (midioutGetNumDevs-1), or MIDI_MAPPER (-1). 59 | Special value MIDI_MAPPER specifies output to the Windows MIDI mapper 60 | Read-only while device is open, exception if changed while open 61 | 62 | MIDIHandle: The output handle to the MIDI device. 63 | 0 when device is not open 64 | Read-only, runtime-only 65 | 66 | ProductName: Name of the output device product that corresponds to the 67 | DeviceID property (e.g. 'MPU 401 out'). 68 | You can write to this while the device is closed to select a particular 69 | output device by name (the DeviceID property will change to match). 70 | Exception if this property is changed while the device is open. 71 | 72 | NumDevs: Number of MIDI output devices installed on the system. This 73 | is the value returned by midiOutGetNumDevs. It's included for 74 | completeness. 75 | 76 | Technology: Type of technology used by the MIDI device. You can set this 77 | property to one of the values listed for OutportTech (below) and the component 78 | will find an appropriate MIDI device. For example: 79 | MidiOutput.Technology := opt_FMSynth; 80 | will set MidiInput.DeviceID to the MIDI device ID of the FM synth, if one 81 | is installed. If no such device is available an exception is raised, 82 | see MidiOutput.SetTechnology. 83 | 84 | See the MIDIOUTCAPS entry in MMSYSTEM.HLP for descriptions of the 85 | following properties: 86 | DriverVersion 87 | Voices 88 | Notes 89 | ChannelMask 90 | Support 91 | 92 | Error: The error code for the last MMSYSTEM error. See the MMSYSERR_ 93 | entries in MMSYSTEM.INT for possible values. 94 | 95 | Methods: 96 | Open: Open MIDI device specified by DeviceID property for output 97 | 98 | Close: Close device 99 | 100 | PutMidiEvent(Event:TMyMidiEvent): Output a note or sysex message to the 101 | device. This method takes a TMyMidiEvent object and transmits it. 102 | Notes: 103 | 1. If the object contains a sysex event the OnMidiOutput event will 104 | be triggered when the sysex transmission is complete. 105 | 2. You can queue up multiple blocks of system exclusive data for 106 | transmission by chucking them at this method; they will be 107 | transmitted as quickly as the device can manage. 108 | 3. This method will not free the TMyMidiEvent object, the caller 109 | must do that. Any sysex data in the TMyMidiEvent is copied before 110 | transmission so you can free the TMyMidiEvent immediately after 111 | calling PutMidiEvent, even if output has not yet finished. 112 | 113 | PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte): Output a short 114 | MIDI message. Handy when you can't be bothered to build a TMyMidiEvent. 115 | If the message you're sending doesn't use Data1 or Data2, set them to 0. 116 | 117 | PutLong(TheSysex: Pointer; msgLength: Word): Output sysex data. 118 | SysexPointer: Pointer to sysex data to send 119 | msgLength: Length of sysex data. 120 | This is handy when you don't have a TMyMidiEvent. 121 | 122 | SetVolume(Left: Word, Right: Word): Set the volume of the 123 | left and right channels on the output device (only on internal devices?). 124 | 0xFFFF is maximum volume. If the device doesn't support separate 125 | left/right volume control, the value of the Left parameter will be used. 126 | Check the Support property to see whether the device supports volume 127 | control. See also other notes on volume control under midiOutSetVolume() 128 | in MMSYSTEM.HLP. 129 | 130 | Events: 131 | OnMidiOutput: Procedure called when output of a system exclusive block 132 | is completed. 133 | 134 | Notes: 135 | I haven't implemented any methods for midiOutCachePatches and 136 | midiOutCacheDrumpatches, mainly 'cause I don't have any way of testing 137 | them. Does anyone really use these? 138 | 139 | -- Manuel Kroeber/2010 140 | Added methods for midiOutCache*Patches. Untested. Hinted as experimental. 141 | } 142 | 143 | interface 144 | 145 | uses 146 | SysUtils, Classes, Messages, Windows, 147 | 148 | MMSystem, 149 | CircBuf, MidiType, MidiDefs, MidiCons, MidiCallback, MidiKeyPatchArray; 150 | 151 | type 152 | MidiOutputState = (mosOpen, mosClosed); 153 | EMidiOutputError = class(Exception); 154 | 155 | { These are the equivalent of constants prefixed with mod_ 156 | as defined in MMSystem. See SetTechnology } 157 | OutPortTech = ( 158 | opt_None, { none } 159 | opt_MidiPort, { output port } 160 | opt_Synth, { generic internal synth } 161 | opt_SQSynth, { square wave internal synth } 162 | opt_FMSynth, { FM internal synth } 163 | opt_Mapper); { MIDI mapper } 164 | TechNameMap = array[OutPortTech] of string; 165 | 166 | const 167 | TechName: TechNameMap = ( 168 | 'None', 'MIDI Port', 'Generic Synth', 'Square Wave Synth', 169 | 'FM Synth', 'MIDI Mapper'); 170 | 171 | {-------------------------------------------------------------------} 172 | type 173 | TMidiOutput = class(TMidiIO) 174 | private 175 | function GetSupportsCaching: Boolean; 176 | procedure MidiOutput(var Message: TMessage); 177 | procedure SetDeviceID(DeviceID: Cardinal); 178 | procedure SetProductName(NewProductName: string); 179 | procedure SetTechnology(NewTechnology: OutPortTech); 180 | function MidiOutErrorString(const WError: Cardinal; 181 | const ErrorContext: TMIDIErrorContext = ecGeneric): string; 182 | function GetSupportsStreaming: Boolean; 183 | function GetFeaturesAsSet: TFeatureSet; 184 | function GetSupportsLRVolCtrl: Boolean; 185 | function GetSupportsVolControl: Boolean; 186 | protected 187 | Handle: THandle; { Window handle used for callback notification } 188 | FDeviceID: Cardinal; { MIDI device ID } 189 | FMIDIHandle: Hmidiout; { Handle to output device } 190 | FState: MidiOutputState; { Current device state } 191 | PCtlInfo: PMidiCtlInfo; { Pointer to control info for DLL } 192 | 193 | PBuffer: PCircularBuffer; { Output queue for PutTimedEvent, set by Open } 194 | 195 | FError: DWord; { Last MMSYSTEM error } //FAlter: DWord statt Word 196 | FUseFullReset: Boolean; 197 | 198 | { Stuff from midioutCAPS } 199 | FMID: Word; { Manufacturer ID } 200 | FPID: Word; { Product ID } 201 | FDriverVersion: Version; { Driver version from midioutGetDevCaps } 202 | FProductName: string; { product name } 203 | FTechnology: OutPortTech; { Type of MIDI output device } 204 | FVoices: Word; { Number of voices (internal synth) } 205 | FNotes: Word; { Number of notes (internal synth) } 206 | FChannelMask: Word; { Bit set for each MIDI channels that the 207 | device responds to (internal synth) } 208 | FSupport: DWORD; { Technology supported (volume control, 209 | patch caching etc. } 210 | FNumDevs: Word; { Number of MIDI output devices on system } 211 | 212 | { Events } 213 | FOnMidiOutput: TNotifyEvent; { Sysex output finished } 214 | FOnDeviceChanged: TNotifyEvent; // after successfully changing the DeviceID 215 | 216 | public 217 | { Properties } 218 | property MIDIHandle: Hmidiout read FMIDIHandle; 219 | 220 | property MID: Word read FMID; { Manufacturer ID } 221 | property PID: Word read FPID; { Product ID } 222 | property DriverVersion: Version { Driver version from midioutGetDevCaps } 223 | read FDriverVersion; 224 | property Technology: OutPortTech { Type of MIDI output device } 225 | read FTechnology 226 | write SetTechnology 227 | default opt_Synth; 228 | property Voices: Word { Number of voices (internal synth) } 229 | read FVoices; 230 | property Notes: Word { Number of notes (internal synth) } 231 | read FNotes; 232 | property ChannelMask: Word { Bit set for each MIDI channels that the } 233 | read FChannelMask; { device responds to (internal synth) } 234 | property Support: DWORD { Technology supported (volume control, } 235 | read FSupport; { patch caching etc. } 236 | 237 | property Error: DWord read FError; //FAlter DWord statt Word 238 | 239 | property NumDevs: Word read FNumDevs; // Buffered output 240 | 241 | property SupportedFeatures: TFeatureSet read GetFeaturesAsSet; 242 | // if ftStereoVolume is supported, ftVolume is allways supported, too. 243 | property SupportsCaching: Boolean read GetSupportsCaching; 244 | property SupportsStreaming: Boolean read GetSupportsStreaming; 245 | property SupportsVolumeControl: Boolean read GetSupportsVolControl; 246 | property SupportsStereoVolumeControl: Boolean read GetSupportsLRVolCtrl; 247 | 248 | property FullResetOnClose: Boolean read FUseFullReset write FUseFullReset; 249 | property State: MidiOutputState read FState; 250 | 251 | { Methods } 252 | constructor Create(AOwner: TComponent); override; 253 | destructor Destroy; override; 254 | 255 | function Open: Boolean; virtual; 256 | function Close: Boolean; virtual; 257 | function ChangeDevice(const NewDeviceID: Cardinal; 258 | const OpenAfterChange: Boolean = True): Boolean; virtual; 259 | 260 | function DeviceCount: Cardinal; override; 261 | 262 | procedure PutMidiEvent(theEvent: TMyMidiEvent); virtual; 263 | procedure PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte); virtual; 264 | procedure PutLong(const TheSysex: Pointer; const msgLength: Word); virtual; 265 | function DriverMidiMessage(const Msg: Cardinal; const dw1, dw2: DWORD): DWORD; {$IFDEF VER170}experimental;{$ENDIF} 266 | 267 | procedure SetVolume(Left, Right: Word); overload; 268 | // right volume is ignored if stereo volume is not supported 269 | procedure SetVolume(const MonoVolume: Word); overload; 270 | // use this is you don't care about stereo volume 271 | procedure GetVolume(var Left, Right: Word); overload; 272 | // right = left if stereo volume is not supported 273 | function GetVolume: Word; overload; 274 | procedure GetVolume(var MonoVolume: Word); overload; 275 | // use these if you don't care about stereo volume 276 | 277 | 278 | { Methods encapsulating PutShort provided for your convenience } 279 | procedure NoteOn(const Channel, Note: Byte; const Dynamics: Byte = 127); 280 | procedure NoteOff(const Channel, Note: Byte; const Dynamics: Byte = 127); 281 | 282 | procedure NoteAftertouch(const Channel, Note: Byte; 283 | const NewDynamics: Byte = 127); 284 | procedure ChannelAftertouch(const Channel: Byte; 285 | const NewDynamics: Byte = 127); 286 | 287 | procedure ControllerChange(const Channel, NewController, Value: Byte); 288 | procedure ProgramChange(const Channel, NewProgram: Byte); 289 | procedure ChangeInstrument(const Channel: Byte; 290 | const NewInstrument: TGMInstrumentPatch); // for your convenience 291 | 292 | 293 | { Experimental and/or untested stuff } 294 | // Caching. Returns true if successful. Check LastError on False. 295 | // Use property "SupportsCaching" for a pre-check. 296 | function CachePatches(const Bank: Cardinal; var PatchArray: TKeyPatchArray; 297 | const OperationFlag: Byte): Boolean; {$IFDEF VER170}experimental;{$ENDIF} 298 | function CacheDrumPatches(const Patch: Cardinal; var KeyArray: TKeyPatchArray; 299 | const OperationFlag: Byte): Boolean; {$IFDEF VER170}experimental;{$ENDIF} 300 | 301 | 302 | { Some functions to decode and classify incoming messages would be nice } 303 | 304 | published 305 | { TODO: Property editor with dropdown list of product names } 306 | property ProductName: string read FProductName write SetProductName; 307 | 308 | property DeviceID: Cardinal read FDeviceID write SetDeviceID default 0; 309 | 310 | { Events } 311 | property OnMidiOutput: TNotifyEvent 312 | read FOnMidiOutput write FOnMidiOutput; 313 | property OnDeviceChanged: TNotifyEvent 314 | read FOnDeviceChanged write FOnDeviceChanged; 315 | end; 316 | 317 | procedure Register; 318 | 319 | {-------------------------------------------------------------------} 320 | implementation 321 | 322 | constructor TMidiOutput.Create(AOwner: TComponent); 323 | begin 324 | inherited Create(AOwner); 325 | 326 | FState := mosClosed; 327 | FNumDevs := midiOutGetNumDevs; 328 | FUseFullReset := False; 329 | 330 | { Create the window for callback notification } 331 | if not (csDesigning in ComponentState) then 332 | begin 333 | Handle := Classes.AllocateHWnd(MidiOutput); 334 | end; 335 | end; 336 | 337 | {-------------------------------------------------------------------} 338 | 339 | destructor TMidiOutput.Destroy; 340 | begin 341 | if FState = mosOpen then 342 | Close; 343 | if (PCtlInfo <> nil) then 344 | GlobalSharedLockedFree(PCtlinfo^.hMem, PCtlInfo); 345 | Classes.DeallocateHWnd(Handle); 346 | inherited Destroy; 347 | end; 348 | 349 | function TMidiOutput.DeviceCount: Cardinal; 350 | begin 351 | FNumDevs := midiOutGetNumDevs; 352 | Result := FNumDevs; 353 | end; 354 | 355 | function TMidiOutput.DriverMidiMessage(const Msg: Cardinal; const dw1, 356 | dw2: DWORD): DWORD; 357 | begin 358 | Result := midiOutMessage(HMIDIOUT(FDeviceID), msg, dw1, dw2); 359 | end; 360 | 361 | function TMidiOutput.GetFeaturesAsSet: TFeatureSet; 362 | begin 363 | Result := []; 364 | // Check for "Device supports caching" flag 365 | if (FSupport and MIDICAPS_CACHE) = MIDICAPS_CACHE then 366 | Result := Result + [ftCaching]; 367 | // Check for "Device supports MIDI streaming" flag 368 | if (FSupport and MIDICAPS_STREAM) = MIDICAPS_STREAM then 369 | Result := Result + [ftStreaming]; 370 | // Check for "Device supports volume control (Mono)" flag 371 | if (FSupport and MIDICAPS_VOLUME) = MIDICAPS_VOLUME then 372 | Result := Result + [ftVolume]; 373 | // Check for "Device supports stereo volume control for left and right" flag 374 | if (FSupport and MIDICAPS_LRVOLUME) = MIDICAPS_LRVOLUME then 375 | Result := Result + [ftStereoVolume]; 376 | end; 377 | 378 | function TMidiOutput.GetSupportsCaching: Boolean; 379 | begin 380 | Result := (ftCaching in SupportedFeatures); 381 | end; 382 | 383 | function TMidiOutput.GetSupportsLRVolCtrl: Boolean; 384 | begin 385 | Result := (ftStereoVolume in SupportedFeatures); 386 | end; 387 | 388 | function TMidiOutput.GetSupportsStreaming: Boolean; 389 | begin 390 | Result := (ftStreaming in SupportedFeatures); 391 | end; 392 | 393 | function TMidiOutput.GetSupportsVolControl: Boolean; 394 | begin 395 | Result := (ftVolume in SupportedFeatures); 396 | end; 397 | 398 | function TMidiOutput.GetVolume: Word; 399 | var 400 | LVol, RVol: Word; 401 | begin 402 | GetVolume(LVol, RVol); 403 | Result := LVol; 404 | end; 405 | 406 | procedure TMidiOutput.GetVolume(var MonoVolume: Word); 407 | begin 408 | MonoVolume:= GetVolume; 409 | end; 410 | 411 | procedure TMidiOutput.GetVolume(var Left, Right: Word); 412 | var 413 | dwVolume: DWORD; 414 | begin 415 | FError := midiOutGetVolume(DeviceID, @dwVolume); 416 | if FError <> MMSYSERR_NOERROR then 417 | raise EMidiOutputError.Create(MidiOutErrorString(FError)); 418 | 419 | // Volume is stored as stereo value in the higher and lower WORD of 420 | // an unsigned DWORD (Cardinal). MSB = left, LSB = right channel. 421 | 422 | // move high WORD to the right & blank high WORD area to get high WORD 423 | Left := WORD((dwVolume shr 16) and $0000FFFF); 424 | if SupportsStereoVolumeControl then 425 | Right := WORD(dwVolume and $0000FFFF) // blank high WORD to get low WORD 426 | else 427 | Right := Left; 428 | end; 429 | 430 | {-------------------------------------------------------------------} 431 | { Convert the numeric return code from an MMSYSTEM function to a string 432 | using midioutGetErrorText. TODO: These errors aren't very helpful 433 | (e.g. "an invalid parameter was passed to a system function") so 434 | some proper error strings would be nice. 435 | 436 | MKr: Problem with an enhancement: Many functions share the same error codes 437 | but give them different meanings. This function needs to know the context 438 | to output a suitable error message. 439 | } 440 | 441 | 442 | function TMidiOutput.MidiOutErrorString(const WError: Cardinal; 443 | const ErrorContext: TMIDIErrorContext): string; 444 | 445 | function GetGenericErrorMessage(ErrorCode: Cardinal): string; 446 | var 447 | errorDesc: PChar; 448 | begin 449 | errorDesc := nil; 450 | try 451 | errorDesc := StrAlloc(MAXERRORLENGTH); 452 | if midioutGetErrorText(ErrorCode, errorDesc, MAXERRORLENGTH) = 0 then 453 | Result := StrPas(errorDesc) 454 | else 455 | Result := 'Specified error number is out of range'; 456 | finally 457 | if errorDesc <> nil then 458 | StrDispose(errorDesc); 459 | end; 460 | end; 461 | 462 | var 463 | SpecificError: string; 464 | begin 465 | case ErrorContext of 466 | ecGeneric: Result := GetGenericErrorMessage(WError); 467 | ecCaching: begin 468 | case WError of 469 | MMSYSERR_INVALFLAG: SpecificError := '(Caching) The flag specified by wFlags is invalid.'; 470 | MMSYSERR_INVALHANDLE: SpecificError := '(Caching) The specified device handle is invalid.'; 471 | MMSYSERR_INVALPARAM: SpecificError := '(Caching) The array pointed to by lpPatchArray is invalid.'; 472 | MMSYSERR_NOMEM: SpecificError := '(Caching) The device does not have enough memory to cache all of the requested patches.'; 473 | MMSYSERR_NOTSUPPORTED: SpecificError := '(Caching) The specified device does not support patch caching.'; 474 | end; 475 | end; 476 | ecPutShort: begin 477 | case WError of 478 | MIDIERR_BADOPENMODE: SpecificError := '(Short Msg) The application sent a message without a status byte to a stream handle.'; 479 | MIDIERR_NOTREADY: SpecificError := '(Short Msg) The hardware is busy with other data.'; 480 | MMSYSERR_INVALHANDLE: SpecificError := '(Short Msg) The specified device handle is invalid.'; 481 | end; 482 | end; 483 | ecPutLong: begin 484 | case WError of 485 | MIDIERR_NOTREADY: SpecificError := '(Long Msg) The hardware is busy with other data.'; 486 | MIDIERR_UNPREPARED: SpecificError := '(Long Msg) The buffer pointed to by lpMidiOutHdr has not been prepared.'; 487 | MMSYSERR_INVALHANDLE: SpecificError := '(Long Msg) The specified device handle is invalid.'; 488 | MMSYSERR_INVALPARAM: SpecificError := '(Long Msg) The specified pointer or structure is invalid.'; 489 | end; 490 | end; 491 | ecOutPrepareHeader: begin 492 | case WError of 493 | MMSYSERR_INVALHANDLE: SpecificError := '(Prep Header) The specified device handle is invalid.'; 494 | MMSYSERR_INVALPARAM: SpecificError := '(Prep Header) The specified address is invalid or the given stream buffer is greater than 64K.'; 495 | MMSYSERR_NOMEM: SpecificError := '(Prep Header) The system is unable to allocate or lock memory.'; 496 | end; 497 | end; 498 | end; 499 | 500 | // Fallback 501 | if SpecificError = '' then 502 | Result := GetGenericErrorMessage(WError) 503 | else 504 | Result := SpecificError; 505 | end; 506 | 507 | {-------------------------------------------------------------------} 508 | { Set the output device ID and change the other properties to match } 509 | 510 | procedure TMidiOutput.SetDeviceID(DeviceID: Cardinal); 511 | var 512 | midioutCaps: TmidioutCaps; 513 | begin 514 | if FState = mosOpen then 515 | raise EMidiOutputError.Create('Change to DeviceID while device was open') 516 | else 517 | if (DeviceID >= midioutGetNumDevs) and 518 | (DeviceID <> MIDI_MAPPER) then 519 | raise EMidiOutputError.Create('Invalid device ID') 520 | else 521 | begin 522 | FDeviceID := DeviceID; 523 | 524 | { Set the name and other midioutCAPS properties to match the ID } 525 | FError := midioutGetDevCaps( 526 | DeviceID, //FAlter wohl in der MMSystem falscher Typ? -1=Default 527 | // MKr: Reverted to Cardinal type. 528 | // DeviceID is declared as Unsigned Integer in MSDN and MIDI MAPPER 529 | // default device as UINT(-1). Whatever this is producing, it works. 530 | // Use const MIDI_MAPPER or MIDIMAPPER found in MidiCons or MMSystem. 531 | @midioutCaps, 532 | sizeof(TmidioutCaps) 533 | ); 534 | if Ferror > 0 then 535 | raise EMidiOutputError.Create(MidiOutErrorString(FError)); 536 | 537 | with midiOutCaps do 538 | begin 539 | FMID := wMid; 540 | FPID := wPid; 541 | FProductName := StrPas(szPname); 542 | FDriverVersion := vDriverVersion; 543 | FTechnology := OutPortTech(wTechnology); 544 | FVoices := wVoices; 545 | FNotes := wNotes; 546 | FChannelMask := wChannelMask; 547 | FSupport := dwSupport; 548 | end; 549 | 550 | if Assigned(FOnDeviceChanged) then 551 | FOnDeviceChanged(Self); 552 | end; 553 | end; 554 | 555 | {-------------------------------------------------------------------} 556 | { Set the product name property and put the matching output device number 557 | in FDeviceID. 558 | This is handy if you want to save a configured output/output device 559 | by device name instead of device number, because device numbers may 560 | change if users install or remove MIDI devices. 561 | Exception if output device with matching name not found, 562 | or if output device is open } 563 | 564 | procedure TMidiOutput.SetProductName(NewProductName: string); 565 | var 566 | midioutCaps: TmidioutCaps; 567 | testDeviceID: Integer; 568 | testProductName: string; 569 | begin 570 | if FState = mosOpen then 571 | raise EMidiOutputError.Create('Change to ProductName while device was open') 572 | else 573 | { Don't set the name if the component is reading properties because 574 | the saved Productname will be from the machine the application was compiled 575 | on, which may not be the same for the corresponding DeviceID on the user's 576 | machine. The FProductname property will still be set by SetDeviceID } 577 | if not (csLoading in ComponentState) then 578 | begin 579 | { Loop uses -1 to test for MIDI_MAPPER as well } 580 | for testDeviceID := -1 to (midioutGetNumDevs - 1) do 581 | begin 582 | FError := 583 | midioutGetDevCaps(testDeviceID, @midioutCaps, sizeof(TmidioutCaps)); 584 | if Ferror > 0 then 585 | raise EMidiOutputError.Create(MidiOutErrorString(FError)); 586 | testProductName := StrPas(midioutCaps.szPname); 587 | if testProductName = NewProductName then 588 | begin 589 | FProductName := NewProductName; 590 | Break; 591 | end; 592 | end; 593 | if FProductName <> NewProductName then 594 | raise EMidiOutputError.Create('MIDI output Device ' + 595 | NewProductName + ' not installed') 596 | else 597 | SetDeviceID(testDeviceID); 598 | end; 599 | end; 600 | 601 | {-------------------------------------------------------------------} 602 | { Set the output technology property and put the matching output device 603 | number in FDeviceID. 604 | This is handy, for example, if you want to be able to switch between a 605 | sound card and a MIDI port } 606 | 607 | procedure TMidiOutput.SetTechnology(NewTechnology: OutPortTech); 608 | var 609 | midiOutCaps: TMidiOutCaps; 610 | testDeviceID: Integer; 611 | testTechnology: OutPortTech; 612 | begin 613 | if FState = mosOpen then 614 | raise EMidiOutputError.Create( 615 | 'Change to Product Technology while device was open') 616 | else 617 | begin 618 | { Loop uses -1 to test for MIDI_MAPPER as well } 619 | for testDeviceID := -1 to (midiOutGetNumDevs - 1) do 620 | begin 621 | // get device info 622 | FError := midioutGetDevCaps(testDeviceID, @midioutCaps, 623 | sizeof(TmidioutCaps)); 624 | 625 | if FError > 0 then 626 | raise EMidiOutputError.Create(MidiOutErrorString(FError)); 627 | 628 | // translate to OutPortTech 629 | testTechnology := OutPortTech(midioutCaps.wTechnology); 630 | // and test for support 631 | if testTechnology = NewTechnology then 632 | begin 633 | FTechnology := NewTechnology; 634 | Break; 635 | end; 636 | end; 637 | if FTechnology <> NewTechnology then 638 | raise EMidiOutputError.Create 639 | ('MIDI output technology ' + TechName[NewTechnology] 640 | + ' not installed') 641 | else 642 | // switch to new device if tech was found 643 | SetDeviceID(testDeviceID); 644 | end; 645 | end; 646 | 647 | procedure TMidiOutput.SetVolume(const MonoVolume: Word); 648 | begin 649 | SetVolume(MonoVolume, MonoVolume); 650 | end; 651 | 652 | {-------------------------------------------------------------------} 653 | 654 | function TMidiOutput.Open: Boolean; 655 | var 656 | hMem: THandle; 657 | begin 658 | Result := False; 659 | try 660 | { Create the control info for the DLL } 661 | if (PCtlInfo = nil) then 662 | begin 663 | PCtlInfo := GlobalSharedLockedAlloc(Sizeof(TMidiCtlInfo), hMem); 664 | PctlInfo^.hMem := hMem; 665 | end; 666 | 667 | Pctlinfo^.hWindow := Handle; { Control's window handle } 668 | 669 | FError := midioutOpen(@FMidiHandle, 670 | Cardinal(FDeviceId), 671 | DWORD(@midiHandler), 672 | DWORD(PCtlInfo), 673 | CALLBACK_FUNCTION); 674 | 675 | if (FError <> 0) then 676 | { TODO: use CreateFmtHelp to add MIDI device name/ID to message } 677 | raise EMidiOutputError.Create(MidiOutErrorString(FError)) 678 | else 679 | begin 680 | Result := True; 681 | FState := mosOpen; 682 | end; 683 | 684 | except 685 | if PCtlInfo <> nil then 686 | begin 687 | GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo); 688 | PCtlInfo := nil; 689 | end; 690 | end; 691 | 692 | end; 693 | 694 | {-------------------------------------------------------------------} 695 | 696 | procedure TMidiOutput.PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte); 697 | var 698 | thisMsg: DWORD; 699 | begin 700 | if FState = mosOpen then 701 | begin 702 | thisMsg := DWORD(MidiMessage) or 703 | (DWORD(Data1) shl 8) or 704 | (DWORD(Data2) shl 16); 705 | 706 | FError := midiOutShortMsg(FMidiHandle, thisMsg); 707 | if Ferror > 0 then 708 | raise EMidiOutputError.Create(MidiOutErrorString(FError, ecPutShort)); 709 | end 710 | else 711 | raise EMidiOutputError.Create('(Short Msg) Device not opened.'); 712 | end; 713 | 714 | {-------------------------------------------------------------------} 715 | 716 | procedure TMidiOutput.PutLong(const TheSysex: Pointer; const msgLength: Word); 717 | { Notes: This works asynchronously; you send your sysex output by 718 | calling this function, which returns immediately. When the MIDI device 719 | driver has finished sending the data the MidiOutPut function in this 720 | component is called, which will in turn call the OnMidiOutput method 721 | if the component user has defined one. } 722 | { TODO: Combine common functions with PutTimedLong into subroutine } 723 | 724 | // MKr: Does anyone know what's meant with PutTimedLong? 725 | // Can't find any timed WinAPI MIDI stuff on the internet... 726 | 727 | var 728 | MyMidiHdr: TMyMidiHdr; 729 | begin 730 | if FState = mosOpen then 731 | begin 732 | { Initialize the header and allocate buffer memory } 733 | MyMidiHdr := TMyMidiHdr.Create(msgLength); 734 | 735 | { Copy the data over to the MidiHdr buffer 736 | We can't just use the caller's PChar because the buffer memory 737 | has to be global, shareable, and locked. } 738 | CopyMemory(MyMidiHdr.SysexPointer, TheSysex, msgLength); 739 | 740 | { Store the MyMidiHdr address in the header so we can find it again quickly 741 | (see the MidiOutput proc) } 742 | MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr); 743 | 744 | { Get MMSYSTEM's blessing for this header } 745 | FError := midiOutPrepareHeader(FMidiHandle, MyMidiHdr.hdrPointer, 746 | sizeof(TMIDIHDR)); 747 | if Ferror > 0 then 748 | raise EMidiOutputError.Create(MidiOutErrorString(FError, ecOutPrepareHeader)); 749 | 750 | { Send it } 751 | FError := midiOutLongMsg(FMidiHandle, MyMidiHdr.hdrPointer, 752 | sizeof(TMIDIHDR)); 753 | if Ferror > 0 then 754 | raise EMidiOutputError.Create(MidiOutErrorString(FError, ecPutLong)); 755 | end 756 | else 757 | raise EMidiOutputError.Create('(Long Msg) Device not opened.'); 758 | end; 759 | 760 | {-------------------------------------------------------------------} 761 | 762 | procedure TMidiOutput.PutMidiEvent(theEvent: TMyMidiEvent); 763 | begin 764 | if FState <> mosOpen then 765 | raise EMidiOutputError.Create('MIDI Output device not open'); 766 | 767 | if theEvent.Sysex = nil then 768 | begin 769 | PutShort(theEvent.MidiMessage, theEvent.Data1, theEvent.Data2) 770 | end 771 | else 772 | PutLong(theEvent.Sysex, theEvent.SysexLength); 773 | end; 774 | 775 | {-------------------------------------------------------------------} 776 | 777 | procedure TMidiOutput.NoteAftertouch(const Channel, Note, NewDynamics: Byte); 778 | begin 779 | // See NoteOff for details 780 | PutShort(MIDI_KEYAFTERTOUCH or ($0F and Channel), Note, NewDynamics); 781 | end; 782 | 783 | function TMidiOutput.CacheDrumPatches(const Patch: Cardinal; 784 | var KeyArray: TKeyPatchArray; const OperationFlag: Byte): Boolean; 785 | begin 786 | FError := midiOutCacheDrumPatches(FMIDIHandle, Patch, @KeyArray, 787 | OperationFlag); 788 | 789 | if FError <> MMSYSERR_NOERROR then 790 | begin 791 | Result := False; 792 | //raise EMidiOutputError.Create(MidiOutErrorString(FError)); 793 | end 794 | else 795 | Result := True; 796 | end; 797 | 798 | function TMidiOutput.CachePatches(const Bank: Cardinal; 799 | var PatchArray: TKeyPatchArray; const OperationFlag: Byte): Boolean; 800 | begin 801 | FError := midiOutCachePatches(FMIDIHandle, Bank, @PatchArray, OperationFlag); 802 | 803 | if FError <> MMSYSERR_NOERROR then 804 | begin 805 | Result := False; 806 | //raise EMidiOutputError.Create(MidiOutErrorString(FError)); 807 | end 808 | else 809 | Result := True; 810 | end; 811 | 812 | function TMidiOutput.ChangeDevice(const NewDeviceID: Cardinal; 813 | const OpenAfterChange: Boolean): Boolean; 814 | begin 815 | Result := False; 816 | 817 | if FState <> mosClosed then 818 | Close; 819 | 820 | if FState = mosClosed then 821 | begin 822 | DeviceID := NewDeviceID; 823 | if OpenAfterChange then 824 | Result := Open; 825 | end; 826 | end; 827 | 828 | procedure TMidiOutput.ChangeInstrument(const Channel: Byte; 829 | const NewInstrument: TGMInstrumentPatch); 830 | begin 831 | ProgramChange(Channel, Byte(NewInstrument)); 832 | end; 833 | 834 | procedure TMidiOutput.ChannelAftertouch(const Channel, NewDynamics: Byte); 835 | begin 836 | // See NoteOff for details 837 | PutShort(MIDI_CHANAFTERTOUCH or ($0F and Channel), NewDynamics, $00); 838 | end; 839 | 840 | procedure TMidiOutput.ProgramChange(const Channel, NewProgram: Byte); 841 | begin 842 | // See NoteOff for details 843 | PutShort(MIDI_PROGRAMCHANGE or ($0F and Channel), NewProgram, $00); 844 | end; 845 | 846 | function TMidiOutput.Close: Boolean; 847 | begin 848 | Result := False; 849 | if FState = mosOpen then 850 | begin 851 | if FUseFullReset then 852 | begin 853 | // Note: this sends a lot of fast control change messages which some\ 854 | // synths can't handle thus it's off by default. 855 | FError := midioutReset(FMidiHandle); 856 | 857 | if FError <> 0 then 858 | raise EMidiOutputError.Create(MidiOutErrorString(FError)); 859 | end; 860 | 861 | FError := midioutClose(FMidiHandle); 862 | if Ferror <> 0 then 863 | raise EMidiOutputError.Create(MidiOutErrorString(FError)) 864 | else 865 | Result := True; 866 | end; 867 | 868 | FMidiHandle := 0; 869 | FState := mosClosed; 870 | end; 871 | 872 | procedure TMidiOutput.ControllerChange(const Channel, NewController, 873 | Value: Byte); 874 | begin 875 | // See NoteOff for details 876 | PutShort(MIDI_CONTROLCHANGE or ($0F and Channel), NewController, Value); 877 | end; 878 | 879 | {-------------------------------------------------------------------} 880 | 881 | procedure TMidiOutput.SetVolume(Left, Right: Word); 882 | var 883 | dwVolume: DWORD; 884 | begin 885 | if not SupportsStereoVolumeControl then 886 | Right := Left; 887 | 888 | dwVolume := (DWORD(Left) shl 16) or Right; 889 | FError := midiOutSetVolume(DeviceID, dwVolume); 890 | if FError <> 0 then 891 | raise EMidiOutputError.Create(MidiOutErrorString(FError)); 892 | end; 893 | 894 | {-------------------------------------------------------------------} 895 | 896 | procedure TMidiOutput.MidiOutput(var Message: TMessage); 897 | { Triggered when sysex output from PutLong is complete } 898 | var 899 | MyMidiHdr: TMyMidiHdr; 900 | thisHdr: PMidiHdr; 901 | begin 902 | if Message.Msg = MOM_DONE then 903 | begin 904 | { Find the MIDIHDR we used for the output. Message.lParam is its address } 905 | thisHdr := PMidiHdr(Message.lParam); 906 | 907 | { Remove it from the output device } 908 | midiOutUnprepareHeader(FMidiHandle, thisHdr, sizeof(TMIDIHDR)); 909 | 910 | { Get the address of the MyMidiHdr object containing this MIDIHDR structure. 911 | We stored this address in the PutLong procedure } 912 | MyMidiHdr := TMyMidiHdr(thisHdr^.dwUser); 913 | 914 | { Header and copy of sysex data no longer required since output is complete } 915 | MyMidiHdr.Free; 916 | 917 | { Call the user's event handler if any } 918 | if Assigned(FOnMidiOutput) then 919 | FOnMidiOutput(Self); 920 | end; 921 | { TODO: Case for MOM_PLAYBACK_DONE } 922 | end; 923 | 924 | procedure TMidiOutput.NoteOff(const Channel, Note: Byte; 925 | const Dynamics: Byte); 926 | begin 927 | // ($0F and Channel) kills the upper 4 bits of the byte to 0000 to ensure the 928 | // OR-operation works fine to "build" the Note command. The note event just 929 | // recognizes 16 channels ($00 to $0F). This way you can input any Byte 930 | // value. Note that using values > 15 results in an overflow behavior 931 | // (h10/d16 is channel 0, h11/d17 is channel 1, h12/d18 channel 2, a.s.o) 932 | PutShort(MIDI_NOTEOFF or ($0F and Channel), Note, Dynamics); 933 | end; 934 | 935 | procedure TMidiOutput.NoteOn(const Channel, Note: Byte; 936 | const Dynamics: Byte); 937 | begin 938 | // See NoteOff for details 939 | PutShort(MIDI_NOTEON or ($0F and Channel), Note, Dynamics); 940 | end; 941 | 942 | {-------------------------------------------------------------------} 943 | 944 | procedure Register; 945 | begin 946 | RegisterComponents('MIDI I/O', [TMidiOutput]); 947 | end; 948 | 949 | end. 950 | -------------------------------------------------------------------------------- /MidiScope.pas: -------------------------------------------------------------------------------- 1 | { 2 | Shows a large black area where midi note/controller events are shown 3 | just to monitor midi activity (for the MidiPlayer) 4 | 5 | version 1.0 first release 6 | 7 | for comments/bugs 8 | F.Bouwmans 9 | fbouwmans@spiditel.nl 10 | 11 | if you think this component is nice and you use it, sent me a short email. 12 | I've seen that other of my components have been downloaded a lot, but I've 13 | got no clue wether they are actually used. 14 | Don't worry because you are free to use these components 15 | } 16 | 17 | (** 18 | * MidiScope.pas v2010-05r1 19 | **) 20 | 21 | (* ***** BEGIN LICENSE BLOCK ***** 22 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 23 | * 24 | * The contents of this file are subject to the Mozilla Public License Version 25 | * 1.1 (the "License"); you may not use this file except in compliance with 26 | * the License. You may obtain a copy of the License at 27 | * http://www.mozilla.org/MPL/ 28 | * 29 | * Software distributed under the License is distributed on an "AS IS" basis, 30 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 31 | * for the specific language governing rights and limitations under the 32 | * License. 33 | * 34 | * The Original Code is MIDI constants. 35 | * 36 | * The Initial Developer of the Original Code is 37 | * David Churcher . 38 | * Portions created by the Initial Developer are Copyright (C) 1997 39 | * the Initial Developer. All Rights Reserved. 40 | * 41 | * Contributor(s): 42 | * turboPASCAL < http://www.delphipraxis.net/user13047.html > 43 | * Manuel Kroeber 44 | * 45 | * Alternatively, the contents of this file may be used under the terms of 46 | * either the GNU General Public License Version 3 or later (the "GPL"), or 47 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 48 | * in which case the provisions of the GPL or the LGPL are applicable instead 49 | * of those above. If you wish to allow use of your version of this file only 50 | * under the terms of either the GPL or the LGPL, and not to allow others to 51 | * use your version of this file under the terms of the MPL, indicate your 52 | * decision by deleting the provisions above and replace them with the notice 53 | * and other provisions required by the GPL or the LGPL. If you do not delete 54 | * the provisions above, a recipient may use your version of this file under 55 | * the terms of any one of the MPL, the GPL or the LGPL. 56 | * 57 | * ***** END LICENSE BLOCK ***** *) 58 | 59 | unit MidiScope; 60 | 61 | interface 62 | 63 | uses 64 | Windows, Messages, SysUtils, Classes, Graphics, Controls, 65 | 66 | MidiCons; 67 | 68 | type 69 | TMidiScope = class(TGraphicControl) 70 | private 71 | { Private declarations } 72 | protected 73 | { Protected declarations } 74 | notes : array[0..15,0..127] of integer; 75 | controllers : array[0..15,0..17] of integer; 76 | aftertouch : array[0..15,0..127] of integer; 77 | 78 | selectedChannel : integer; 79 | 80 | procedure PaintSlide(ch,pos,val: integer); 81 | 82 | procedure NoteOn(channel, note, speed : integer); 83 | procedure Controller(channel,number,value : integer); 84 | procedure AfterTch(channel, note, value : integer); 85 | 86 | public 87 | { Public declarations } 88 | constructor Create(AOwner: TComponent); override; 89 | procedure MidiEvent(event,data1,data2 : integer); 90 | procedure Paint; override; 91 | published 92 | { Published declarations } 93 | end; 94 | 95 | 96 | procedure Register; 97 | 98 | const 99 | BarHeight = 16; 100 | BarHeightInc = BarHeight+2; 101 | BarWidth = 3; 102 | BarWidthInc = BarWidth+1; 103 | HeightDiv = 128 div BarHeight; 104 | 105 | implementation 106 | 107 | procedure Register; 108 | begin 109 | RegisterComponents('MIDI I/O', [TMidiScope]); 110 | end; 111 | 112 | constructor TMidiScope.Create(AOwner: TComponent); 113 | var 114 | i,j : integer; 115 | begin 116 | inherited Create(AOwner); 117 | Height := BarHeightinc * 16 + 4; 118 | Width := 147*BarWidthInc + 4 + 20; // for channel number 119 | for i := 0 to 15 do 120 | begin 121 | for j := 0 to 127 do 122 | begin 123 | notes[i,j] := 0; 124 | aftertouch[i,j] := 0; 125 | end; 126 | end; 127 | for i := 0 to 17 do 128 | begin 129 | for j := 0 to 15 do 130 | controllers[i,j] := 0; 131 | end; 132 | end; 133 | 134 | procedure TMidiScope.PaintSlide(ch,pos,val: integer); 135 | var x,y:integer; 136 | begin 137 | Canvas.Brush.Color := clBlack; 138 | Canvas.Pen.color := clBlack; 139 | x := pos * BarWidthInc + 2; 140 | y := 2 + ch * BarHeightInc; 141 | Canvas.Rectangle(x, y, x+BarWidthInc, y+BarHeightInc); 142 | Canvas.Brush.Color := clGreen; 143 | Canvas.Pen.Color := clGreen; 144 | Canvas.Rectangle(x, y + (BarHeight - (val div HeightDiv )), x + BarWidth, y + BarHeight) 145 | end; 146 | 147 | procedure TMidiScope.Paint; 148 | var i,j : integer; 149 | x : integer; 150 | begin 151 | Canvas.Brush.color := clBlack; 152 | Canvas.Rectangle(0,0,Width,Height); 153 | Canvas.Pen.Color := clGreen; 154 | x := 128*BarWidthInc+2; 155 | Canvas.MoveTo(x,0); 156 | Canvas.LineTo(x,Height); 157 | x := 148*BarWIdthInc+2; 158 | canvas.Font.Color := clGreen; 159 | for i := 0 to 15 do 160 | begin 161 | Canvas.TextOut(x,((i+1)*BarHeightInc) - Canvas.font.size-3,IntToStr(i+1)); 162 | canvas.Pen.color := clBlack; 163 | for j := 0 to 127 do 164 | begin 165 | PaintSlide(i,j,notes[i,j]); 166 | end; 167 | for j := 0 to 17 do 168 | begin 169 | PaintSlide(i,j+129,controllers[i,j]); 170 | end; 171 | end; 172 | end; 173 | procedure TMidiScope.NoteOn(channel, note, speed : integer); 174 | begin 175 | notes[channel,note] := speed; 176 | PaintSlide(channel,note,notes[channel,note]); 177 | end; 178 | procedure TMidiScope.AfterTch(channel, note, value : integer); 179 | begin 180 | aftertouch[channel,note] := value; 181 | end; 182 | 183 | procedure TMidiScope.Controller(channel,number,value : integer); 184 | var i : integer; 185 | begin 186 | if number < 18 then 187 | begin 188 | controllers[channel,number] := value; 189 | PaintSlide(channel,number+129,value); 190 | end 191 | else if number >= $7B then 192 | begin 193 | // all notes of for channel 194 | for i := 0 to 127 do 195 | begin 196 | if notes[channel,i] > 0 then 197 | begin 198 | notes[channel,i] := 0; 199 | PaintSlide(channel,i,0); 200 | end; 201 | end; 202 | end; 203 | end; 204 | 205 | procedure TMidiScope.MidiEvent(event,data1,data2 : integer); 206 | begin 207 | case (event AND $F0) of 208 | MIDI_NOTEON : 209 | begin 210 | NoteOn((event AND $F),data1,data2); 211 | end; 212 | MIDI_NOTEOFF: 213 | begin 214 | NoteOn((event AND $F),data1,0); 215 | end; 216 | MIDI_CONTROLCHANGE : 217 | begin 218 | Controller((event AND $F),data1,data2); 219 | end; 220 | MIDI_CHANAFTERTOUCH: 221 | begin 222 | Controller((Event AND $F),16,Data1); 223 | end; 224 | MIDI_PITCHBEND: 225 | begin 226 | begin 227 | Controller((Event AND $F),17,data2); 228 | end; 229 | end; 230 | MIDI_KEYAFTERTOUCH: 231 | begin 232 | end; 233 | end; 234 | end; 235 | end. 236 | -------------------------------------------------------------------------------- /MidiType.pas: -------------------------------------------------------------------------------- 1 | { $Header: /MidiComp/MIDITYPE.PAS 2 10/06/97 7:33 Davec $ } 2 | 3 | { Written by David Churcher , 4 | released to the public domain. } 5 | 6 | (** 7 | * MidiType.pas v2010-05r1 8 | **) 9 | 10 | (* ***** BEGIN LICENSE BLOCK ***** 11 | * Version: MPL 1.1/GPL 3.0/LGPL 3.0 12 | * 13 | * The contents of this file are subject to the Mozilla Public License Version 14 | * 1.1 (the "License"); you may not use this file except in compliance with 15 | * the License. You may obtain a copy of the License at 16 | * http://www.mozilla.org/MPL/ 17 | * 18 | * Software distributed under the License is distributed on an "AS IS" basis, 19 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 20 | * for the specific language governing rights and limitations under the 21 | * License. 22 | * 23 | * The Original Code is MIDI type definitions. 24 | * 25 | * The Initial Developer of the Original Code is 26 | * David Churcher . 27 | * Portions created by the Initial Developer are Copyright (C) 1997 28 | * the Initial Developer. All Rights Reserved. 29 | * 30 | * Contributor(s): 31 | * Manuel Kroeber 32 | * 33 | * Alternatively, the contents of this file may be used under the terms of 34 | * either the GNU General Public License Version 3 or later (the "GPL"), or 35 | * the GNU Lesser General Public License Version 3 or later (the "LGPL"), 36 | * in which case the provisions of the GPL or the LGPL are applicable instead 37 | * of those above. If you wish to allow use of your version of this file only 38 | * under the terms of either the GPL or the LGPL, and not to allow others to 39 | * use your version of this file under the terms of the MPL, indicate your 40 | * decision by deleting the provisions above and replace them with the notice 41 | * and other provisions required by the GPL or the LGPL. If you do not delete 42 | * the provisions above, a recipient may use your version of this file under 43 | * the terms of any one of the MPL, the GPL or the LGPL. 44 | * 45 | * ***** END LICENSE BLOCK ***** *) 46 | 47 | unit MidiType; 48 | 49 | interface 50 | 51 | uses Classes, Windows, MMSystem, MidiDefs, Circbuf; 52 | 53 | type 54 | 55 | TMidiIO = class(TComponent) 56 | public 57 | function DeviceCount: Cardinal; virtual; abstract; 58 | end; 59 | 60 | {-------------------------------------------------------------------} 61 | { A MIDI input/output event } 62 | TMyMidiEvent = class(TPersistent) 63 | public 64 | MidiMessage: Byte; { MIDI message status byte } 65 | Data1: Byte; { MIDI message data 1 byte } 66 | Data2: Byte; { MIDI message data 2 byte } 67 | Time: DWORD; { Time in ms since midiInOpen } 68 | SysexLength: Word; { Length of sysex data (0 if none) } 69 | Sysex: PAnsiChar; { Pointer to sysex data buffer } 70 | destructor Destroy; override; { Frees sysex data buffer if nec. } 71 | end; 72 | PMyMidiEvent = ^TMyMidiEvent; 73 | 74 | {-------------------------------------------------------------------} 75 | { Encapsulates the MIDIHDR with its memory handle and sysex buffer } 76 | PMyMidiHdr = ^TMyMidiHdr; 77 | TMyMidiHdr = class(TObject) 78 | public 79 | hdrHandle: THandle; 80 | hdrPointer: PMIDIHDR; 81 | sysexHandle: THandle; 82 | sysexPointer: Pointer; 83 | constructor Create(const BufferSize: Word); 84 | destructor Destroy; override; 85 | end; 86 | 87 | TMidiChannel = 0..15; 88 | 89 | TMidiChannelNamed = ( 90 | ch00, ch01, ch02, ch03, 91 | ch04, ch05, ch06, ch07, 92 | ch08, ch09, ch10, ch11, 93 | ch12, ch13, ch14, ch15 94 | ); 95 | 96 | TMidiChannels = set of TMidiChannel; 97 | 98 | TFeature = ( 99 | ftCaching, ftStreaming, ftVolume, ftStereoVolume 100 | ); 101 | 102 | TFeatureSet = set of TFeature; 103 | 104 | TMIDIErrorContext = ( 105 | ecGeneric, 106 | ecCaching, 107 | ecPutShort, 108 | ecPutLong, 109 | ecOutPrepareHeader 110 | ); 111 | 112 | TMidiMsg = ( 113 | msgActiveSensing, 114 | msgMidiTimeCode 115 | ); 116 | 117 | TMidiMsgFilter = set of TMidiMsg; 118 | 119 | TGMInstrumentPatch = ( 120 | // Piano 121 | gmiAcousticGrandPiano, gmiBrightAcousticPiano, 122 | gmiElectricGrandPiano, gmiHonkyTonkPiano, 123 | gmiElectricPiano1, gmiElectricPiano2, 124 | gmiHarpsichord, gmiClavi, 125 | // Chromatic Percussion 126 | gmiCelesta, gmiGlockenspiel, 127 | gmiMusicBox, gmiVibraphone, 128 | gmiMarimba, gmiXylophone, 129 | gmiTubularBells, gmiDulcimer, 130 | // Organ 131 | gmiDrawbarOrgan, gmiPercussiveOrgan, 132 | gmiRockOrgan, gmiChurchOrgan, 133 | gmiReedOrgan, gmiAccordion, 134 | gmiHarmonica, gmiTangoAccordion, 135 | // Guitar 136 | gmiAcousticGuitarNylon, gmiAcousticGuitarSteel, 137 | gmiElectricGuitarJazz, gmiElectricGuitarClean, 138 | gmiElectricGuitarMuted, gmiOverdrivenGuitar, 139 | gmiDistortionGuitar, gmiGuitarHarmonics, 140 | // Bass 141 | gmiAcousticBass, gmiElectricBassFinger, 142 | gmiElectricBassPick, gmiFretlessBass, 143 | gmiSlapBass1, gmiSlapBass2, 144 | gmiSynthBass1, gmiSynthBass2, 145 | // Strings 146 | gmiViolin, gmiViola, 147 | gmiCello, gmiContrabass, 148 | gmiTremoloStrings, gmiPizzicatoStrings, 149 | gmiOrchestralHarp, gmiTimpani, 150 | // Ensemble 151 | gmiStringEnsemble1, gmiStringEnsemble2, 152 | gmiSynthStrings1, gmiSynthString2, 153 | gmiChoirAahs, gmiVoiceOohs, 154 | gmiSynthVoice, gmiOrchestraHit, 155 | // Brass 156 | gmiTrumpet, gmiTrobone, 157 | gmiTuba, gmiMutedTrumpet, 158 | gmiFrenchHorn, gmiBrassSection, 159 | gmiSynthBrass1, gmiSynthBrass2, 160 | // Reed 161 | gmiSopranoSax, gmiAltoSax, 162 | gmiTenorSax, gmiBaritoneSax, 163 | gmiOboe, gmiEnglishHorn, 164 | gmiBassoon, gmiClarinet, 165 | // Pipe 166 | gmiPiccolo, gmiFlute, 167 | gmiRecorder, gmiPanFlute, 168 | gmiBlownBottle, gmiShakuhachi, 169 | gmiWhistle, gmiOcarina, 170 | // Synth Lead 171 | gmiLead1Square, gmiLead2Sawtooth, 172 | gmiLead3Calliope, gmiLead4Chiff, 173 | gmiLead5Charang, gmiLead6Voice, 174 | gmiLead7Fifths, gmiLead8BassAndLead, 175 | // Synth Pad 176 | gmiPad1NewAge, gmiPad2Warm, 177 | gmiPad3Polysynth, gmiPad4Choir, 178 | gmiPad5Bowed, gmiPad6Metallic, 179 | gmiPad7Halo, gmiPad8Sweep, 180 | // Synth Effects 181 | gmiFX1Rain, gmiFX2Soundtrack, 182 | gmiFX3Crystal, gmiFX4Atmosphere, 183 | gmiFX5Brightness, gmiFX6Goblins, 184 | gmiFX7Echoes, gmiFX8SciFi, 185 | // Ethnic 186 | gmiSitar, gmiBanjo, 187 | gmiShamisen, gmiKoto, 188 | gmiKalimba, gmiBagPipe, 189 | gmiFiddle, gmiShania, 190 | // Percussive 191 | gmiTinkleBell, gmiAgogo, 192 | gmiSteelDrums, gmiWoodblock, 193 | gmiTaikoDrum, gmiMelodicTom, 194 | gmiSynthDrum, gmiReverseCymbal, 195 | // Sound Effects 196 | gmiGuitarFretNoise, gmiBreathNoise, 197 | gmiSeashore, gmiBirdTweet, 198 | gmiTelephoneRing, gmiHelicopter, 199 | gmiApplause, gmiGunshot 200 | ); 201 | 202 | TGMInstrumentStringMap = array[TGMInstrumentPatch] of string; 203 | 204 | function MIDIInstrumentToStr(const Instrument: TGMInstrumentPatch): string; 205 | 206 | implementation 207 | 208 | const 209 | GeneralMidiIstrumentStrings: TGMInstrumentStringMap = ( 210 | // Piano 211 | 'Acoustic Grand Piano', 'Bright Acoustic Piano', 212 | 'Electric Grand Piano', 'Honky-Tonk Piano', 213 | 'Electric Piano 1', 'Electric Piano 2', 214 | 'Harpsichord', 'Clavi', 215 | // Chromatic Percussion 216 | 'Celesta', 'Glockenspiel', 217 | 'Music Box', 'Vibraphone', 218 | 'Marimba', 'Xylophone', 219 | 'TubularBells', 'Dulcimer', 220 | // Organ 221 | 'Drawbar Organ', 'Percussive Organ', 222 | 'Rock Organ', 'Church Organ', 223 | 'Reed Organ', 'Accordion', 224 | 'Harmonica', 'Tango Accordion', 225 | // Guitar 226 | 'Acoustic Guitar (Nylon)', 'Acoustic Guitar (Steel)', 227 | 'Electric Guitar (Jazz)', 'Electric Guitar (Clean)', 228 | 'Electric Guitar (Muted)', 'Overdriven Guitar', 229 | 'Distortion Guitar', 'Guitar Harmonics', 230 | // Bass 231 | 'Acoustic Bass', 'Electric Bass (Finger)', 232 | 'Electric Bass (Pick)', 'Fretless Bass', 233 | 'Slap Bass 1', 'Slap Bass 2', 234 | 'Synth Bass 1', 'Synth Bass 2', 235 | // Strings 236 | 'Violin', 'Viola', 237 | 'Cello', 'Contrabass', 238 | 'Tremolo Strings', 'Pizzicato Strings', 239 | 'Orchestral Harp', 'Timpani', 240 | // Ensemble 241 | 'String Ensemble 1', 'String Ensemble 2', 242 | 'Synth Strings 1', 'Synth String 2', 243 | 'Choir Aahs', 'Voice Oohs', 244 | 'Synth Voice', 'Orchestra Hit', 245 | // Brass 246 | 'Trumpet', 'Trobone', 247 | 'Tuba', 'Muted Trumpet', 248 | 'French Horn', 'Brass Section', 249 | 'Synth Brass 1', 'Synth Brass2', 250 | // Reed 251 | 'Soprano Sax', 'Alto Sax', 252 | 'Tenor Sax', 'Baritone Sax', 253 | 'Oboe', 'English Horn', 254 | 'Bassoon', 'Clarinet', 255 | // Pipe 256 | 'Piccolo', 'Flute', 257 | 'Recorder', 'Pan Flute', 258 | 'Blown Bottle', 'Shakuhachi', 259 | 'Whistle', 'Ocarina', 260 | // Synth Lead 261 | 'Lead 1 (Square)', 'Lead 2 (Sawtooth)', 262 | 'Lead 3 (Calliope)', 'Lead 4 (Chiff)', 263 | 'Lead 5 (Charang)', 'Lead 6 (Voice)', 264 | 'Lead 7 (Fifths)', 'Lead 8 (Bass + Lead)', 265 | // Synth Pad 266 | 'Pad 1 (NewAge)', 'Pad 2 (Warm)', 267 | 'Pad 3 (Polysynth)', 'Pad 4 (Choir)', 268 | 'Pad 5 (Bowed)', 'Pad 6 (Metallic)', 269 | 'Pad 7 (Halo)', 'Pad 8 (Sweep)', 270 | // Synth Effects 271 | 'FX 1 (Rain)', 'FX 2 (Soundtrack)', 272 | 'FX 3 (Crystal)', 'FX 4 (Atmosphere)', 273 | 'FX 5 (Brightness)', 'FX 6 (Goblins)', 274 | 'FX 7 (Echoes)', 'FX 8 (SciFi)', 275 | // Ethnic 276 | 'Sitar', 'Banjo', 277 | 'Shamisen', 'Koto', 278 | 'Kalimba', 'Bag Pipe', 279 | 'Fiddle', 'Shania', 280 | // Percussive 281 | 'Tinkle Bell', 'Agogo', 282 | 'Steel Drums', 'Woodblock', 283 | 'Taiko Drum', 'Melodic Tom', 284 | 'Synth Drum', 'Reverse Cymbal', 285 | // Sound Effects 286 | 'Guitar Fret Noise', 'Breath Noise', 287 | 'Seashore', 'Bird Tweet', 288 | 'Telephone Ring', 'Helicopter', 289 | 'Applause', 'Gunshot' 290 | ); 291 | 292 | 293 | function MIDIInstrumentToStr(const Instrument: TGMInstrumentPatch): string; 294 | begin 295 | Result := GeneralMidiIstrumentStrings[Instrument]; 296 | end; 297 | 298 | 299 | {-------------------------------------------------------------------} 300 | { Free any sysex buffer associated with the event } 301 | destructor TMyMidiEvent.Destroy; 302 | begin 303 | if (Sysex <> Nil) then 304 | Freemem(Sysex, SysexLength); 305 | 306 | inherited Destroy; 307 | end; 308 | 309 | {-------------------------------------------------------------------} 310 | { Allocate memory for the sysex header and buffer } 311 | constructor TMyMidiHdr.Create(const BufferSize:Word); 312 | begin 313 | inherited Create; 314 | 315 | if BufferSize > 0 then 316 | begin 317 | hdrPointer := GlobalSharedLockedAlloc(sizeof(TMIDIHDR), hdrHandle); 318 | sysexPointer := GlobalSharedLockedAlloc(BufferSize, sysexHandle); 319 | 320 | hdrPointer^.lpData := sysexPointer; 321 | hdrPointer^.dwBufferLength := BufferSize; 322 | end; 323 | end; 324 | 325 | {-------------------------------------------------------------------} 326 | destructor TMyMidiHdr.Destroy; 327 | begin 328 | GlobalSharedLockedFree( hdrHandle, hdrPointer ); 329 | GlobalSharedLockedFree( sysexHandle, sysexPointer ); 330 | inherited Destroy; 331 | end; 332 | 333 | 334 | 335 | end. 336 | -------------------------------------------------------------------------------- /Package/MidiComponents2010.dpk: -------------------------------------------------------------------------------- 1 | package MidiComponents2010; 2 | 3 | {$R *.res} 4 | {$R 'MidiFile.dcr'} 5 | {$R 'MidiIn.dcr'} 6 | {$R 'MidiOut.dcr'} 7 | {$R 'MidiScope.dcr'} 8 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 9 | {$ALIGN 8} 10 | {$ASSERTIONS ON} 11 | {$BOOLEVAL OFF} 12 | {$DEBUGINFO OFF} 13 | {$EXTENDEDSYNTAX ON} 14 | {$IMPORTEDDATA ON} 15 | {$IOCHECKS ON} 16 | {$LOCALSYMBOLS ON} 17 | {$LONGSTRINGS ON} 18 | {$OPENSTRINGS ON} 19 | {$OPTIMIZATION ON} 20 | {$OVERFLOWCHECKS OFF} 21 | {$RANGECHECKS OFF} 22 | {$REFERENCEINFO ON} 23 | {$SAFEDIVIDE OFF} 24 | {$STACKFRAMES OFF} 25 | {$TYPEDADDRESS OFF} 26 | {$VARSTRINGCHECKS ON} 27 | {$WRITEABLECONST OFF} 28 | {$MINENUMSIZE 1} 29 | {$IMAGEBASE $400000} 30 | {$DEFINE DEBUG} 31 | {$ENDIF IMPLICITBUILDING} 32 | {$DESCRIPTION 'MIDI I/O components'} 33 | {$IMPLICITBUILD ON} 34 | 35 | requires 36 | vcl; 37 | 38 | contains 39 | CircBuf in '..\CircBuf.pas', 40 | MidiCallback in '..\MidiCallback.pas', 41 | MidiCons in '..\MidiCons.pas', 42 | MidiDefs in '..\MidiDefs.pas', 43 | MidiFile in '..\MidiFile.pas', 44 | MidiIn in '..\MidiIn.pas', 45 | MidiOut in '..\MidiOut.pas', 46 | MidiType in '..\MidiType.pas', 47 | MidiKeyPatchArray in '..\MidiKeyPatchArray.pas', 48 | MidiScope in '..\MidiScope.pas', 49 | MidiDeviceComboBox in '..\MidiDeviceComboBox.pas', 50 | MidiEventStreamer in '..\MidiEventStreamer.pas'; 51 | 52 | end. 53 | -------------------------------------------------------------------------------- /Package/MidiComponents2010.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {35271963-7A55-40F0-B8C8-5C6B7F67DE0D} 4 | MidiComponents2010.dpk 5 | 12.0 6 | Debug 7 | DCC32 8 | 9 | 10 | true 11 | 12 | 13 | true 14 | Base 15 | true 16 | 17 | 18 | true 19 | Base 20 | true 21 | 22 | 23 | false 24 | MIDI I/O components 25 | 00400000 26 | true 27 | ..\..\..\..\..\..\All Users\Documents\RAD Studio\7.0\Bpl\MidiComponents2010.bpl 28 | WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) 29 | x86 30 | false 31 | false 32 | true 33 | false 34 | false 35 | false 36 | 37 | 38 | false 39 | RELEASE;$(DCC_Define) 40 | 0 41 | false 42 | 43 | 44 | DEBUG;$(DCC_Define) 45 | 46 | 47 | 48 | MainSource 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | Base 69 | 70 | 71 | Cfg_2 72 | Base 73 | 74 | 75 | Cfg_1 76 | Base 77 | 78 | 79 | 80 | 81 | Delphi.Personality.12 82 | Package 83 | 84 | 85 | 86 | MidiComponents2010.dpk 87 | 88 | 89 | False 90 | True 91 | False 92 | 93 | 94 | True 95 | False 96 | 1 97 | 0 98 | 0 99 | 0 100 | False 101 | False 102 | False 103 | False 104 | False 105 | 1033 106 | 1252 107 | 108 | 109 | 110 | 111 | 1.0.0.0 112 | 113 | 114 | 115 | 116 | 117 | 1.0.0.0 118 | 119 | 120 | 121 | Microsoft Office 2000 Sample Automation Server Wrapper Components 122 | Microsoft Office XP Sample Automation Server Wrapper Components 123 | 124 | 125 | 126 | 12 127 | 128 | 129 | -------------------------------------------------------------------------------- /Package/MidiComponents2010.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Package/MidiComponents2010.res -------------------------------------------------------------------------------- /Package/MidiFile.dcr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Package/MidiFile.dcr -------------------------------------------------------------------------------- /Package/MidiIn.dcr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Package/MidiIn.dcr -------------------------------------------------------------------------------- /Package/MidiOut.dcr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Package/MidiOut.dcr -------------------------------------------------------------------------------- /Package/MidiScope.dcr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/Package/MidiScope.dcr -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/beNative/midiio/541e60f92322726b1ac139f24f47fc72539cb557/README.txt --------------------------------------------------------------------------------