Hello I´m searching for a Midi-In listing, who can help?

[esr]

I would like to send GFA Basic button commands via a MIDI keyboard, but have not found no program- listing so far (sample scripts). VB scrips can not be translated into GFA Basic, at least I can not do it ?! - Can anyone help me? - I was able to create Midi Out via the API commands. There were also sample programs for this purpose.

Here is a VB script I found. Who can rewrite this for GFA Basic? - With the API commands I have no idea, how to use them, - I'm a beginner!


Found VB Script:

Imports System.Threading
Imports System.Runtime.InteropServices

Public Class Form1

Public Declare Function midiInGetNumDevs Lib "winmm.dll" () As Integer
Public Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Integer, ByRef lpCaps As MIDIINCAPS, ByVal uSize As Integer) As Integer
Public Declare Function midiInOpen Lib "winmm.dll" (ByRef hMidiIn As Integer, ByVal uDeviceID As Integer, ByVal dwCallback As MidiInCallback, ByVal dwInstance As Integer, ByVal dwFlags As Integer) As Integer
Public Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Integer) As Integer
Public Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Integer) As Integer
Public Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Integer) As Integer
Public Declare Function midiInClose Lib "winmm.dll" (ByVal hMidiIn As Integer) As Integer

Public Delegate Function MidiInCallback(ByVal hMidiIn As Integer, ByVal wMsg As UInteger, ByVal dwInstance As Integer, ByVal dwParam1 As Integer, ByVal dwParam2 As Integer) As Integer
Public ptrCallback As New MidiInCallback(AddressOf MidiInProc)
Public Const CALLBACK_FUNCTION As Integer = &H30000
Public Const MIDI_IO_STATUS = &H20

Public Delegate Sub DisplayDataDelegate(dwParam1)

Public Structure MIDIINCAPS
Dim wMid As Int16 ' Manufacturer ID
Dim wPid As Int16 ' Product ID
Dim vDriverVersion As Integer ' Driver version
<MarshalAs(UnmanagedType.ByValTStr, SizeConst:=32)> Dim szPname As String ' Product Name
Dim dwSupport As Integer ' Reserved
End Structure

Dim hMidiIn As Integer
Dim StatusByte As Byte
Dim DataByte1 As Byte
Dim DataByte2 As Byte
Dim MonitorActive As Boolean = False
Dim HideMidiSysMessages As Boolean = False

Function MidiInProc(ByVal hMidiIn As Integer, ByVal wMsg As UInteger, ByVal dwInstance As Integer, ByVal dwParam1 As Integer, ByVal dwParam2 As Integer) As Integer
If MonitorActive = True Then
TextBox1.Invoke(New DisplayDataDelegate(AddressOf DisplayData), New Object() {dwParam1})
End If
End Function

Private Sub DisplayData(dwParam1)
If ((HideMidiSysMessages = True) And ((dwParam1 And &HF0) = &HF0)) Then
Exit Sub
Else
StatusByte = (dwParam1 And &HFF)
DataByte1 = (dwParam1 And &HFF00) >> 8
DataByte2 = (dwParam1 And &HFF0000) >> 16
TextBox1.AppendText(String.Format("{0:X2} {1:X2} {2:X2}{3}", StatusByte, DataByte1, DataByte2, vbCrLf))
End If
End Sub

Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
Me.Show()
If midiInGetNumDevs() = 0 Then
MsgBox("No MIDI devices connected")
Application.Exit()
End If

Dim InCaps As New MIDIINCAPS
Dim DevCnt As Integer

For DevCnt = 0 To (midiInGetNumDevs - 1)
midiInGetDevCaps(DevCnt, InCaps, Len(InCaps))
ComboBox1.Items.Add(InCaps.szPname)
Next DevCnt
End Sub

Private Sub ComboBox1_SelectedIndexChanged(sender As System.Object, e As System.EventArgs) Handles ComboBox1.SelectedIndexChanged
ComboBox1.Enabled = False
Dim DeviceID As Integer = ComboBox1.SelectedIndex
midiInOpen(hMidiIn, DeviceID, ptrCallback, 0, CALLBACK_FUNCTION Or MIDI_IO_STATUS)
midiInStart(hMidiIn)
MonitorActive = True
Button2.Text = "Stop monitor"
End Sub

Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
TextBox1.Clear()
End Sub

Private Sub Button2_Click(sender As System.Object, e As System.EventArgs) Handles Button2.Click
If MonitorActive = False Then
midiInStart(hMidiIn)
MonitorActive = True
Button2.Text = "Stop monitor"
Else
midiInStop(hMidiIn)
MonitorActive = False
Button2.Text = "Start monitor"
End If
End Sub

Private Sub Button3_Click(sender As System.Object, e As System.EventArgs) Handles Button3.Click
If HideMidiSysMessages = False Then
HideMidiSysMessages = True
Button3.Text = "Show System messages"
Else
HideMidiSysMessages = False
Button3.Text = "Hide System messages"
End If
End Sub

Private Sub Form1_FormClosed(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosedEventArgs) Handles Me.FormClosed
MonitorActive = False
midiInStop(hMidiIn)
midiInReset(hMidiIn)
'midiInClose(hMidiIn)
Application.Exit()
End Sub

End Class
-------------------------------------------------------------------------------------------------------------------------

Here is an other script for Midi IN / Out / Truh: (More professional).
Posted by Stefaan Casier on January 30th, 2004

Attribute VB_Name = "midi"
Option Explicit

' *** my variables ***
' midi out
Public hMidiOUT As Long ' handle midi out port
Public mMPU401OUT As Long ' roland mpu401 out device
Public midiMessageOut As Long ' short message status byte
Public midiData1 As Long ' short message data byte
Public midiData2 As Long ' short message data byte
Public CurChannel As Integer ' short msg channel/part sequence 0-15

' midi in
Public hMidiIN As Long ' only used for midi thru
Public mMPU401IN As Long ' roland mpu401 in device

' *** API ***
' general
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOPMOST = -1

Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

' midi
Public Const MAXPNAMELEN = 32 ' max product name length (including NULL)

Type MIDIINCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
Type MIDIOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
wTechnology As Integer
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type

' MIDI API Functions for Windows 95
Declare Function midiConnect Lib "winmm.dll" (ByVal hmi As Long, ByVal hmo As Long, pReserved As Any) As Long
Declare Function midiDisconnect Lib "winmm.dll" (ByVal hmi As Long, ByVal hmo As Long, pReserved As Any) As Long
Declare Function midiInClose Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal uSize As Long) As Long
Declare Function midiInGetErrorText Lib "winmm.dll" Alias "midiInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
Declare Function midiOutMessage Lib "winmm.dll" (ByVal hMidiOUT As Long, ByVal msg As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiOutReset Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOUT As Long, ByVal dwMsg As Long) As Long

Public Const MMSYSERR_NOERROR = 0 ' no error

Public Const CALLBACK_NULL = &H0 ' no callback
Public Const CALLBACK_FUNCTION = &H30000 ' dwCallback is a FARPROC

Public Const MM_MIM_OPEN = &H3C1 ' MIDI input
Public Const MM_MIM_CLOSE = &H3C2
Public Const MM_MIM_DATA = &H3C3
Public Const MM_MIM_LONGDATA = &H3C4
Public Const MM_MIM_ERROR = &H3C5
Public Const MM_MIM_LONGERROR = &H3C6

' MIDI status messages
Public Const NOTE_OFF = &H80
Public Const NOTE_ON = &H90
Public Const POLY_KEY_PRESS = &HA0
Public Const CONTROLLER_CHANGE = &HB0
Public Const PROGRAM_CHANGE = &HC0
Public Const CHANNEL_PRESSURE = &HD0
Public Const PITCH_BEND = &HE0

'MIDI Mapper
Public Const MIDI_MAPPER = -1

' flags for wTechnology field of MIDIOUTCAPS structure
Public Const MOD_MIDIPORT = 1 ' output port
Public Const MOD_SYNTH = 2 ' generic internal synth
Public Const MOD_SQSYNTH = 3 ' square wave internal synth
Public Const MOD_FMSYNTH = 4 ' FM internal synth
Public Const MOD_MAPPER = 5 ' MIDI mapper

' flags for dwSupport field of MIDIOUTCAPS
Public Const MIDICAPS_VOLUME = &H1 ' supports volume control
Public Const MIDICAPS_LRVOLUME = &H2 ' separate left-right volume control
Public Const MIDICAPS_CACHE = &H4

Public Function isNote(ByVal Nr As Long) As String
Dim octave As Long
Dim note As String
octave = (Nr \ 12)
note = Nr Mod 12
isNote = Choose(note + 1, "C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B") & Format(octave - 1)
End Function

Public Sub MidiIN_Port(ByVal OpenClose As String)
Dim midiError As Long

If OpenClose = "open" Then
midiError = midiInOpen(hMidiIN, mMPU401IN, AddressOf MidiIN_Proc, 0, CALLBACK_FUNCTION)
If midiError <> MMSYSERR_NOERROR Then
ShowMMErr "midiIN_Open", midiError
Else
midiError = midiInStart(hMidiIN)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiIN_Open-Start", midiError
End If
Else
If hMidiIN <> 0 Then
midiError = midiInStop(hMidiIN)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiIN_Open-Stop", midiError
midiError = midiInClose(hMidiIN)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiIN_Close", midiError
hMidiIN = 0
End If
End If
End Sub

Public Sub MidiIN_Proc(ByVal hmIN As Long, ByVal wMsg As Long, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
Dim txt As String
Dim Status As Long, OnOff As Long
Dim NoteNr As Long
Dim Velocity As Long

On Error Resume Next
Select Case wMsg
Case MM_MIM_OPEN: txt = "open"
Case MM_MIM_CLOSE: txt = "close"
Case MM_MIM_DATA:
Status = (dwParam1 Mod 256)
If Status < &HF0 Then
Select Case (Status \ 16) ' filter 4-bit channel "n"
Case &H8, &H9
NoteNr = ((dwParam1 \ 256) Mod 256)
Velocity = ((dwParam1 \ (256 ^ 2)) Mod 256)
OnOff = IIf(Velocity = 0 Or Status = &H80, 0, 1)
txt = txt & "Status : Note " & IIf(OnOff = 0, "Off", "On") & vbCrLf
txt = txt & "NoteNr : " & isNote(NoteNr) & vbCrLf
txt = txt & "Velo :" & Str(Velocity)
frmMidi.ShowNote NoteNr, OnOff
Case &HB
txt = "Status : Controller Change"
Case &HC
txt = "Status : Program Change"
Case &HE
txt = "Status : Bender Change"
End Select
midiOutShortMsg hMidiOUT, dwParam1 ' send data = Thru-function
End If
Case MM_MIM_LONGDATA: txt = "longdata" & " " & Hex(dwParam1) & " " & Hex(dwParam2)
Case MM_MIM_ERROR: txt = "error" & " " & Hex(dwParam1) & " " & Hex(dwParam2)
Case MM_MIM_LONGERROR: txt = "longerror"
Case Else: txt = ""
End Select
If txt <> "" Then frmMidi.lblMidiInfo.Caption = "Midi IN " & vbCrLf & txt

End Sub

Public Sub MidiOUT_Port(ByVal OpenClose As String)
Dim midiError As Long

If OpenClose = "open" Then
If mMPU401OUT = 256 Then frmDevCap.Show 1
midiError = midiOutOpen(hMidiOUT, mMPU401OUT, vbNull, 0, CALLBACK_NULL)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiOUT_Open", midiError
Else
If hMidiOUT <> 0 Then
midiError = midiOutClose(hMidiOUT)
hMidiOUT = 0
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiOUT_Close", midiError
End If
End If
End Sub

' this function only works when no midiIn port opened yet
Public Sub MidiTHRU_Port(ByVal OpenClose As String)
Dim midiError As Long

If OpenClose = "open" Then
If hMidiOUT = 0 Then MidiOUT_Port "open"
If hMidiOUT = 0 Then Exit Sub
midiError = midiInOpen(hMidiIN, mMPU401IN, 0, 0, CALLBACK_NULL)
If midiError <> MMSYSERR_NOERROR Then
ShowMMErr "midiTHRU_Open", midiError
Else
midiError = midiConnect(hMidiIN, hMidiOUT, 0)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiConnect", midiError
midiError = midiInStart(hMidiIN)
End If

Else
If hMidiIN <> 0 Then
midiError = midiInStop(hMidiIN)
If hMidiOUT <> 0 Then
midiError = midiDisconnect(hMidiIN, hMidiOUT, 0)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiDisconnect", midiError
End If
midiError = midiInClose(hMidiIN)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiTHRU_Close", midiError
End If
End If
End Sub

Public Sub SendMidiShortOut()
Dim midiMessage As Long
Dim lowint As Long, highint As Long

'Pack MIDI message data into 4 byte long integer
lowint = (midiData1 * 256) + midiMessageOut
highint = (midiData2 * 256) * 256
midiMessage = lowint + highint
'Windows MIDI API function
midiOutShortMsg hMidiOUT, midiMessage
End Sub

Public Sub ShowMMErr(InFunct As String, MMErr)
Dim msg As String

msg = String(255, " ")
If InStr(1, InFunct, "out", vbTextCompare) = 0 Then
midiInGetErrorText MMErr, msg, 255
Else
midiOutGetErrorText MMErr, msg, 255
End If
msg = InFunct & vbCrLf & msg & vbCrLf
MsgBox msg
End Sub

[scalion]

Hi,

Sorry but i haven't Midi device to test on my pc. i can't help you but i will take a look on your problem.

See You soon.

Edit 22/08/2019 : i think the link given By JMM is a good way. Try something with it and post a code who dont work with error message if you have, explain your need more accuracy if needed. Hope you found what you need.

[esr]

My problem is with the API declaration and the syntax of delegate.

The term delegate does not exist in GFA Basic. Or I don´t know how?
In addition, a function is inserted in the declaration "MidiInCallback".
That's where the VB5 listings fail in GFA Basic.

I do not know how to define the API commands here.

A hexadecimal string is transmitted via the MidiIn port, which must then be retrieved and disassembled.
And all listings work with this "delegate" function ?!


Here are the questionable lines:(out of Sample 1)

Public Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Integer, ByRef lpCaps As MIDIINCAPS, ByVal uSize As Integer) As Integer
Public Delegate Function MidiInCallback(ByVal hMidiIn As Integer, ByVal wMsg As UInteger, ByVal dwInstance As Integer, ByVal dwParam1 As Integer, ByVal dwParam2 As Integer) As Integer

Public ptrCallback As New MidiInCallback(AddressOf MidiInProc)

Public Delegate Sub DisplayDataDelegate(dwParam1)


How do they have to be translated for GFA (syntax)
docs.microsoft.com/en-us/windows/win32/api/mmeapi/nf-mmeapi-midiingetdevcapsa
docs.microsoft.com/de-de/previous-versions/dd798451(v=vs.85)

[scalion]

Omg, this not simple. Effectivly Delegate is not implemented. But in fact the delegate functions ares secondary function that ca be reprogrammed.
DisplayDataDelegate is used to put some informations in a form. You must use the midiInMessage() function to do the same thing.

[esr]

' API Definition für Midi IN (works sucessfully)

Declare Function MidiInClose Lib "winmm.dll" Alias "midiInClose" (ByVal hMidiIn As Long) As Long
Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal uSize As Long) As Long
Declare Function midiInAddBuffer Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiInGetErrorText Lib "winmm.dll" Alias "midiInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Declare Function midiInMessage Lib "winmm.dll" (ByVal hMidiIn As Long, ByVal msg As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiInPrepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiInUnprepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long

Global OsInfo As OSVERSIONINFO
Global SendHdrCount As Long, SendHdrLength As Long
Declare Function GetVersion Lib "kernel32" () As Long
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByVal lpVersionInformation As Long) As Long

Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion(0 To 127) As Byte ' Maintenance string for PSS usage
End Type

Public Const MAXPNAMELEN = 32

Type MIDIINCAPS
wMid As Int16
wPid As Int16
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type


Type MIDIHDR
lpData As Long
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
lpNext As Long
Reserved As Long
End Type


Public Const MAXMSG = 30000 ' Maximum number of input messages
Public Const MAXSYX = 61000 ' Maximum SYSEX to be received
Public Const SYXSIZE95 = 138
Global SYXSIZE As Integer
Public Const NUMHDRS95 = 199
Global NUMHDRS As Integer

Public Const MM_MIM_OPEN = &H3C1
Public Const MM_MIM_CLOSE = &H3C2
Public Const MM_MIM_DATA = &H3C3
Public Const MM_MIM_LONGDATA = &H3C4
Public Const MM_MIM_ERROR = &H3C5
Public Const MM_MIM_LONGERROR = &H3C6
Public Const MM_MIM_MOREDATA = &H3CC


Type SYXIN
SyxData(0 To SYXSIZE95 - 1) As Byte ' Make sure this is big enough?
MyHdr As Long ' address of this MIDIHDR
End Type

Type SYXCOUNTERS
SyxStart As Long ' Start of SYSEX in SyxString
SyxLength As Integer ' Length of this message
HdrCount As Integer ' Which MIDIHDR was used
End Type

Global vntRet As Variant
Global hMidi As Long, hMidiOut As Long
Global mDev As Long, mDevOut As Long
Global InCount As Integer, LastCount As Integer
Global InMsg(1 To MAXMSG) As Long ' MSG Type
Global InParam1(1 To MAXMSG) As Long ' Param1
Global InVector(1 To MAXMSG) As SYXCOUNTERS
Global InSyx As Integer, SyxCount As Long, ErrFlag As Integer
Global HdrCount As Integer, SaveCount As Integer, MoreData As Long
' Global mHdrs(0 To NUMHDRS95) As MIDIHDR
Global mHdrs() As MIDIHDR
' Global mHdrData(0 To NUMHDRS95) As SYXIN
Global mHdrData() As SYXIN
' Global SyxString(0 To MAXSYX + SYXSIZE95) As Byte
Global SyxString() As Byte
' end of API
---------------------------------------------------------------------------------------

But the sub Routines show faults: (AddressOf MidiInCallBack)

Sub OpenMidiPort()
Dim rc As Long, xx As Integer
Public Const CALLBACK_FUNCTION = &H30000 + &H20&

InCount = 0 : LastCount = 0 : MoreData = 0 : ErrFlag = 0
InSyx = 0 : SyxCount = 0 : HdrCount = 0 : SaveCount = 0

====> rc = midiInOpen(hMidi, mDev, AddressOf MidiInCallBack, 0&, CALLBACK_FUNCTION) <= the syntax of AddressOf / does not work in GFA
' Notice the extra parameter, AddressOf [FunctionName]

' Empfangsroutine
====> Sub MidiInCallBack(ByVal hMidiIn As Long, ByVal wMsg As Integer, ByVal dwInstance As Long, ByVal dwParam1 As Long
' This is the CALLBACK routine for MIDI IN

[scalion]

i Try to replace AddressOf(MidiInCallBAck) by ProcAddr(MidiInCallBAck) but that dont work too.

i search...

Well, try to replace with this :

GetProcAddress(GetModuleHandle("winmm.dll"), "MidiInCallBack")

Be carrefull if your call is in a loop to assign the value of GetProcAddress(GetModuleHandle("winmm.dll"), "MidiInCallBack") in a variable before the loop. And put you variable replacing the parameter.

[esr]

Here is a small listing according your description, but it does not work. But there is no error! But i receive no midi in signal.
ri=Midi Device Port

LoadForm frm1

Global Const CALLBACK_FUNCTION = &H30000
Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Any, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiInClose Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Global ri As Long
ri = 4
StartMidiFunction()

Do
Sleep

Until Me Is Nothing




Sub StartMidiFunction()
Dim lngInputIndex As Long
lngInputIndex = 0
' Call midiInOpen(ri, lngInputIndex, AddressOf MidiIn_Event, 0, CALLBACK_FUNCTION) => Original line
Dim mi

mi = GetProcAddress(GetModuleHandle("winmm.dll"), "MidiIn_Event")

Call midiInOpen(ri, lngInputIndex, mi, 0, CALLBACK_FUNCTION)
Call midiInStart(ri)

End Sub

Sub frm1_Close(Cancel?)
EndMidiRecieve()

Sub EndMidiRecieve()
Call midiInReset(ri)
Call midiInStop(ri)
Call midiInClose(ri)
End Sub

Function MidiIn_Event(ByVal MidiInHandle As Long, ByVal Mess As Long, ByVal Instance As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long

'dw1 contains the midi code
If dw1 > 255 Then 'Ignore time codes
Debug.Print dw1 'This part is unstable
End If
End Function

[scalion]

Dim mi set a variant, internal variant structure store 16 bytes and values ares at the 8th bytes.

Try to replace "Dim mi" by "Global Long mi"
and Insert this after the line GetProcAddress(GetModuleHandle("winmm.dll"), "MidiIn_Event") :

If IsNull(mi) Message "That don't work again..."

Hope that will good this time.

[esr]

I have corrected the syntax according your description.

I have adjusted the routine and get no more error messages. But unfortunately I also do not receive any data during the triggering of midi signals?! - Consequently it does not work!

In the meantime, I continued to search the Internet for solutions. Here I found the following page: openmidiproject.osdn.jp/forums_en.html

It is a simplified API solution for Midi. - MIDIIOLibrary (DLL). - The file can be easily integrated into GFA Basic.

The following program lines are used to retrieve the data at the Midiport:

Local llen As Long
Local szbuf As Byte = 256

If(pmidiin)
llen = MIDIIn_GetMIDIMessage(pmidiin, szbuf, 256)
Endif

-------
pmidiin = MIDIIn_Open(szDeviceName) 'Open the Midiport (szDeviceName) is the Name of the soundcard midi-port
'pmidiin gets a device number for example 832234
-------
MIDIIn_Close(pmidiin) 'Close the open midiport and uses the pmidiin device number 832234


The only problem is that the midi query must be continuously open in the background. When changing the device, the midi channel must first be closed again and then the new one opened.

It must also be ensured that the midiport was closed when closing the program => (frm1.close).

The query must accordingly run as an interrupt. In the routine frm1_MessageProc there are errors and when the window frm1 will be closed a DLL error occur.

It should also be noted, if the program crashes during the MIDI channel is activated, the port still remains open and cannot be used again until the computer has been restarted!

Can you perhaps help here, how to package the query in a clean syntax?

If the midiport works, and is addressed by a sequencer, then the data in the variable "szbuf" will change. - It works!

[scalion]

Sorry but i dont have midi device to test, maybe you must test the presence of midi device before opening the port, and get a sort of id to see if it's the same when you close or have some error. I think you have something like GetNumDevs()and GetDevCaps() to do this.

Just one question, what's your windows version and hardware for midi ?

I will try to found midi material to make my test.

In the meantime, if you find a solution, please share it, that's very intersting.

[frank]

From an old program of mine, did some cleaning up, but didn't test it

init

Do
Sleep
Until Me Is Nothing
Procedure init
' midi out
Global hMidiOUT As Long ' handle midi out port
Global mMidi_port_OUT As Long ' roland Midi_port_ out device
Global midiMessageOut As Long ' short message status byte
Global midiData1 As Long ' short message data byte
Global midiData2 As Long ' short message data byte
Global CurChannel As Int16 ' short msg channel/part sequence 0-15

' midi in
Global hMidiIN As Long ' only used for midi thru
Global mMidi_port_IN As Long ' roland Midi_port_ in device

' *** API ***
' general
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Global Const SWP_NOMOVE = 2
Global Const SWP_NOSIZE = 1
Global Const HWND_NOTOPMOST = -2
Global Const HWND_TOPMOST = -1

Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Global Const SRCCOPY = 13369376 ' (DWORD) dest = source

' midi
Global Const MAXPNAMELEN = 32 ' max product name length (including NULL)
Type Midi_
Midi_Type As Byte
Channel As Byte
Mssage As Byte
EndType
Global Midi_in_Message As Midi_
Global Const Midi_Prgm = 1
Global Const Midi_Cntrl = 2
Global Const Midi_note = 3
Type MIDIINCAPS
wMid As Int16
wPid As Int16
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
Type MIDIOUTCAPS
wMid As Int16
wPid As Int16
vDriverVersion As Long
szPname As String * MAXPNAMELEN
wTechnology As Int16
wVoices As Int16
wNotes As Int16
wChannelMask As Int16
dwSupport As Long
End Type
' MIDI API Functions for Windows 95
Declare Function midiConnect Lib "winmm.dll" (ByVal hmi As Long, ByVal hmo As Long, pReserved As Any) As Long
Declare Function midiDisconnect Lib "winmm.dll" (ByVal hmi As Long, ByVal hmo As Long, pReserved As Any) As Long
Declare Function midiInClose Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal uSize As Long) As Long
Declare Function midiInGetErrorText Lib "winmm.dll" Alias "midiInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIN As Long) As Long
Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Declare Function midiOutGetNumDevs Lib "winmm" () As Int16
Declare Function midiOutMessage Lib "winmm.dll" (ByVal hMidiOUT As Long, ByVal msg As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function midiOutReset Lib "winmm.dll" (ByVal hMidiOUT As Long) As Long
Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOUT As Long, ByVal dwMsg As Long) As Long

Global Const MMSYSERR_NOERROR = 0 ' no error

Global Const CALLBACK_NULL = 0 ' no callback
Global Const CALLBACK_FUNCTION = 196608 ' dwCallback is a FARPROC

Global Const MM_MIM_OPEN = 961 ' MIDI input
Global Const MM_MIM_CLOSE = 962
Global Const MM_MIM_DATA = 963
Global Const MM_MIM_LONGDATA = 364
Global Const MM_MIM_ERROR = 365
Global Const MM_MIM_LONGERROR = 366

' MIDI status messages
Global Const NOTE_OFF = 128
Global Const NOTE_ON = 144
Global Const POLY_KEY_PRESS = 160
Global Const CONTROLLER_CHANGE = 176
Global Const PROGRAM_CHANGE = 192
Global Const CHANNEL_PRESSURE = 208
Global Const PITCH_BEND = 224

'MIDI Mapper
Global Const MIDI_MAPPER = -1

' flags for wTechnology field of MIDIOUTCAPS structure
Global Const MOD_MIDIPORT = 1 ' output port
Global Const MOD_SYNTH = 2 ' generic internal synth
Global Const MOD_SQSYNTH = 3 ' square wave internal synth
Global Const MOD_FMSYNTH = 4 ' FM internal synth
Global Const MOD_MAPPER = 5 ' MIDI mapper

' flags for dwSupport field of MIDIOUTCAPS
Global Const MIDICAPS_VOLUME = 1 ' supports volume control
Global Const MIDICAPS_LRVOLUME = 2 ' separate left-right volume control
Global Const MIDICAPS_CACHE = 4
build_screen
Procedure build_screen
Local Button_w = 200
Local Button_h = 30
Local marge_x = 30
Local marge_y = 10
Local Col_1 = marge_x + 0 * (marge_x + Button_w)
Local Col_2 = marge_x + 1 * (marge_x + Button_w)
Local Col_3 = marge_x + 2 * (marge_x + Button_w)
Local Row_1 = marge_y + 0 * (marge_y + Button_h)
Local Row_2 = marge_y + 1 * (marge_y + Button_h)
Local Row_3 = marge_y + 2 * (marge_y + Button_h)
Local Row_4 = marge_y + 3 * (marge_y + Button_h)
Local Row_5 = marge_y + 4 * (marge_y + Button_h)

Local Cnt As Long
Local MidiCaps As MIDIINCAPS

Form Center frm3 = "Midi Test", , , 1200, 600

Ocx Label opt_lbl1 = "Midi" , Col_1, Row_1, Button_w, Button_h
Ocx ComboBox Midi_devices = , Col_1, Row_2, Button_w, Button_h
Ocx Command Midi_Connect = "Open Port", Col_1, Row_3, Button_w, Button_h
Ocx ListBox List_midi_in = , Col_1, Row_4, Button_w, Button_h * 10
List_midi_in.Sorted = False

For Cnt = 0 To midiInGetNumDevs() - 1
'Get the device name and capabilities
Trace midiInGetDevCaps(Cnt, MidiCaps, Len(MidiCaps))
Midi_devices.AddItem MidiCaps.szPname
Next Cnt
Sub Midi_Connect_Click
If Midi_Connect.Caption = "Open Port"
mMidi_port_OUT = Midi_devices.ListIndex
Trace mMidi_port_OUT
MidiIN_Port("open")
Else
MidiIN_Port("close")
EndIf
Sub Add_to_Midi_List(txt As String)
If Not IsNothing(Me)
If List_midi_in.FontSize * 2 * List_midi_in.ListCount > List_midi_in.Height Then List_midi_in.RemoveItem 0
List_midi_in.AddItem txt
EndIf

Sub MidiIN_Port(ByVal OpenClose As String)
Dim midiError As Long
Local txt As String
If OpenClose = "open" Then
midiError = midiInOpen(hMidiIN, mMidi_port_OUT, ProcAddr(MidiIN_Proc), 0, CALLBACK_FUNCTION)
If midiError <> MMSYSERR_NOERROR Then
txt = "Open " & Midi_devices.Text
Midi_Connect.Caption = "Close Port"

Trace midiError

Else
midiError = midiInStart(hMidiIN)
Midi_Connect.Caption = "Open Port"
Trace midiError
If midiError <> MMSYSERR_NOERROR Then Trace "midiIN_Open-Start" + Str(midiError)
txt = "Open error" & Str(midiError)
End If
Else
Trace hMidiIN
If hMidiIN <> 0 Then
Midi_Connect.Caption = "Open Port"
txt = "Close Port"
midiError = midiInStop(hMidiIN)
If midiError <> MMSYSERR_NOERROR Then Trace "midiIN_Open-Stop" + Str( midiError)
midiError = midiInClose(hMidiIN)
If midiError <> MMSYSERR_NOERROR Then Trace "midiIN_Close" + Str(midiError)
hMidiIN = 0
End If
If Not IsNothing(Me)
Midi_Connect.Caption = "Open Port"
txt = "Close Port"
EndIf
End If
Add_to_Midi_List(txt)
End Sub

Sub MidiIN_Proc(ByVal hmIN As Long, ByVal wMsg As Long, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
Dim txt As String
Dim Status As Long, OnOff As Long
Dim NoteNr As Long
Dim Velocity As Long
Local nr$ = ""
On Error Resume Next
Midi_in_Message.Midi_Type = 0
Select Case wMsg
Case MM_MIM_OPEN : txt = "open"
Case MM_MIM_CLOSE : txt = "close"
Case MM_MIM_DATA :
Status = (dwParam1 Mod 256)

If Status < 240 Then
Select Case (Status \ 16) ' filter 4-bit channel "n"
Case &H8, &H9
NoteNr = ((dwParam1 \ 256) Mod 256)
Velocity = ((dwParam1 \ (256 ^ 2)) Mod 256)
OnOff = Iif(Velocity = 0 Or Status = &H80, 0, 1)
txt = txt & "Status : Note " & Iif(OnOff = 0, "Off", "On") //& vbCrLf
' txt = txt & "NoteNr : " & isNote(NoteNr)// & vbCrLf
txt = txt & Str(NoteNr)
txt = txt & "Velo :" & Str(Velocity)
If OnOff
Midi_in_Message.Midi_Type = Midi_note
Midi_in_Message.Mssage = NoteNr
EndIf

// frmMidi.ShowNote NoteNr, OnOff
Case &HB
txt = "Status : Controller Change"
nr$ = Trim(Str(((dwParam1 \ 256) Mod 256)))
txt = txt + " " + nr$
Midi_in_Message.Midi_Type = Midi_Cntrl
Midi_in_Message.Mssage = ((dwParam1 \ 256) Mod 256)

Case &HC
txt = "Status : Program Change"
nr$ = Trim( Str(((dwParam1 \ 256) Mod 256) + 1))
txt = txt + " " + nr$
Midi_in_Message.Midi_Type = Midi_Prgm
Midi_in_Message.Mssage = ((dwParam1 \ 256) Mod 256)
Case &HE
txt = "Status : Bender Change"
nr$ = Trim(Str(((dwParam1 \ 256) Mod 256)))
txt = txt + " " + nr$

End Select
// midiOutShortMsg(hMidiOUT, dwParam1) ' send data = Thru-function
End If
Case MM_MIM_LONGDATA : txt = "longdata" & " " & Hex(dwParam1) & " " & Hex(dwParam2)
Case MM_MIM_ERROR : txt = "error" & " " & Hex(dwParam1) & " " & Hex(dwParam2)
Case MM_MIM_LONGERROR : txt = "longerror"
Case Else : txt = ""
End Select
If txt <> ""
Add_to_Midi_List(txt)

EndIf

End Sub

Sub MidiOUT_Port(ByVal OpenClose As String)
Dim midiError As Long

If OpenClose = "open" Then
// If mMidi_port_OUT = 256 Then frmDevCap.Show 1
midiError = midiOutOpen(hMidiOUT, mMidi_port_OUT, 0, 0, CALLBACK_NULL)
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiOUT_Open", midiError
Else
If hMidiOUT <> 0 Then
midiError = midiOutClose(hMidiOUT)
hMidiOUT = 0
If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiOUT_Close", midiError
End If
End If
End Sub

' this function only works when no midiIn port opened yet
Sub MidiTHRU_Port(ByVal OpenClose As String)
// Dim midiError As Long

//If OpenClose = "open" Then
//If hMidiOUT = 0 Then MidiOUT_Port "open"
//If hMidiOUT = 0 Then Exit Sub
//midiError = midiInOpen(hMidiIN, mMidi_port_IN, 0, 0, CALLBACK_NULL)
//If midiError <> MMSYSERR_NOERROR Then
//ShowMMErr "midiTHRU_Open", midiError
//Else
//midiError = midiConnect(hMidiIN, hMidiOUT, 0)
//If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiConnect", midiError
//midiError = midiInStart(hMidiIN)
//End If

//Else
//If hMidiIN <> 0 Then
//midiError = midiInStop(hMidiIN)
//If hMidiOUT <> 0 Then
//midiError = midiDisconnect(hMidiIN, hMidiOUT, 0)
//If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiDisconnect", midiError
//End If
//midiError = midiInClose(hMidiIN)
//If midiError <> MMSYSERR_NOERROR Then ShowMMErr "midiTHRU_Close", midiError
//End If
//End If
//End Sub

Sub SendMidiShortOut()
Dim midiMessage As Long
Dim lowint As Long, highint As Long

'Pack MIDI message data into 4 byte long int16
lowint = (midiData1 * 256) + midiMessageOut
highint = (midiData2 * 256) * 256
midiMessage = lowint + highint
'Windows MIDI API function
midiOutShortMsg(hMidiOUT, midiMessage)
End Sub
Sub ShowMMErr(InFunct As String, MMErr)
Dim msg As String

msg = String(255, " ")
If InStr(1, InFunct, "out") = 0 Then
midiInGetErrorText(MMErr, msg, 255)
Else
midiOutGetErrorText(MMErr, msg, 255)
End If
//msg = InFunct & vbCrLf & msg & vbCrLf
MsgBox msg
End Sub

[Roger Cabo]

I was interesting in Midi stuff and high precision timers in GFA basic, in the past as well.

Wondering that there is not MIDI DLL can do this quickly.
I received MIDI Jack DLL source code to do this in Unity, but I have not idea how to compile DLLs in Visual Studio.

Further, the most Midi master-keyboards using USB for incoming Midi events. And sound is created by VST instruments in a Music-Programm (DAW) at 99.99% today.

github.com/keijiro/MidiJack

So I think.. doing anything with Midi on GFA and PC very outdated, unfortunately. And the high Precision Timer programming should be a secret as well.
I never found any Infos how to create different timing on nanoseconds, without cooking the CPU.

There is a free DAW called Reaper, containing free source code. But after 40 years of programming I became to powerless to get into all the stuff.

www.reaper.fm/download.php

After 60 days you can use Reaper as long as you like. They say only : It would nice to pay 60€ if you have. :-)

[Roger Cabo]

Does this works for Gfabasic32 as well?

--------

In the past, about 1990, I coded a complete Midi Sequencer on Atari ST1040 in GfaBasic in Assembler. GFA has produces also the product GFA Assembler for Atari ST
Developed a small multitasking system to have all functions while you edit in real-time.
( And i never know what a multitasking system was at this time.. lol )


For sure I know how to handle all the midi events and selections it self.

translate.google.com/translate?hl=&sl=de&tl=fr&u=https%3A%2F%2Fwww.stcarchiv.de%2Fstc1992%2F07%2Fx-ess

Original
www.stcarchiv.de/stc1992/07/x-ess

On PC it worked on WIn95 also very easy.

Out 1034, X sends midi :  X = IN(1034) received any midi. Also VSYNC was possible on any Port.
But later MS disabled because of security reasons.

[Roger Cabo]

Apr 4, 2021 22:09:03 GMT 1 @jmm said:

Are you a musician? 

Yes fully. Having a complete home studio. Playing Drums and Bass as professional.

Currently reworking the studio area completely my by self.
Do you also be a musician ?

[Roger Cabo]

Apr 5, 2021 10:40:54 GMT 1 @jmm said:

I am not a musician. (I worked in medical equipment repair and maintenance.)  I appreciate music and musicians, but, as the saying goes:"I couldn't carry a tune in a bucket." I do find musical theory fascinating.

So, you had all of this working in the past and now because of MS upgrade, you can't communicate with MIDI PORT, is that correct?

Did you try running in compatibility mode, under an emulator or a Virtual Machine in XP?

This might help:  www.youtube.com/watch?v=sC0gXOZZBD8

On PC I'm working with Logic and now on Cubase since some years. My own music Atari-ST project is dead since 19Win98.
Thank you .. I'm working already with Oracle VisualBox for a long time to test my stuff on Win10.