🚀 go-pugleaf

Ik heb de belangrijkste stukken er zo wat uitgehaald, het gaat hier dus over
een midi sysex decoder.
gSysex is een byte-array waarin de callback functie de sysex (midi) code
schrijft.
Dit is de code in de module, deze werkt tot ik ze in de active x control
gebruik, als ik die active x in een test-project gebruik krijg ik die
beschermingsfout.
In de active x code doe ik echter niet meer dan de functies in de module
oproepen zoals ik dat eerst vanuit ne form deed.vb call openIR.
Zou toch moeten werken dacht ik : (
De declaratie is wel nen hoop, ik laat ze erin staan ter info.
Tia Pieter
Greetz
Cofke
****************variable
declaratie******************************************************************
********************
Public Type MIDIHDR
        lpData As Long
        dwBufferLength As Long
        dwBytesRecorded As Long
        dwUser As Long
        dwFlags As Long
        dwOffset As Long
        lpNext As Long
        Reserved As Long
End Type
Const MAXPNAMELEN = 32
Public Type MIDIINCAPS
        wMid As Integer
        wPid As Integer
        vDriverVersion As Long
        szPname As String * MAXPNAMELEN
End Type

'flags for dw flags
Public Const MHDR_DONE = &H1         '  done bit
Public Const MHDR_INQUEUE = &H4      '  reserved for driver
Public Const MHDR_PREPARED = &H2     '  set if header prepared
Public Const MHDR_VALID = &H7        '  valid flags / ;Internal /
'call back messages
Public Const MM_MIM_CLOSE = &H3C2
Public Const MM_MIM_DATA = &H3C3
Public Const MM_MIM_ERROR = &H3C5
Public Const MM_MIM_LONGDATA = &H3C4
Public Const MM_MIM_LONGERROR = &H3C6
Public Const MM_MIM_MOREDATA = &H3CC '  MIM_DONE w/ pending events
Public Const MM_MIM_OPEN = &H3C1     '  MIDI input
'callback flags
Public Const CALLBACK_FUNCTION = &H30000      '  dwCallback is a FARPROC
Public Const CALLBACK_NULL = &H0              '  no callback
Public Const CALLBACK_TASK = &H20000          '  dwCallback is a HTASK
Public Const CALLBACK_TYPEMASK = &H70000      '  callback type mask
Public Const CALLBACK_WINDOW = &H10000        '  dwCallback is a HWND

Public gintErrorId As Integer
Public glHandle As Long
Public gllengte As Long
Public glDeviceID As Long
Public glInstance As Long
Public glFlags As Long
Public gintError As Integer
Public gSysex(50) As Byte   'groot genoeg nemen kans bestaat op een vreemd
groter sysex bericht
Public Header As MIDIHDR
Public gMsg As Long
Public gPar1 As Long
Public gPar2 As Long
Public gCode As String
Public gKey As Integer
Public gSysexCode As String
Public gCaps As MIDIINCAPS
Public gbDecode As Boolean
Public Declare Function midiInGetDevCaps Lib "winmm.dll" Alias
"midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal
uSize As Long) As Long
Public Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Long)
As Long
Public Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Long)
As Long
Public Declare Function midiInPrepareHeader Lib "winmm.dll" (ByVal hMidiIn
As Long, ByRef lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiInClose Lib "winmm.dll" (ByVal hMidiIn As Long)
As Long
Public 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
Public Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long)
As Long
Public Declare Function midiInGetErrorText Lib "winmm.dll" Alias
"midiInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal
uSize As Long) As Long
Public Declare Function midiInAddBuffer Lib "winmm.dll" (ByVal hMidiIn As
Long, ByRef lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long



*******************************************ini******************************
**************************************
Public Sub ini()
glHandle = 0
glDeviceID = 0
glInstance = 0  'userdata die wordt meegegeven aan de callbackfunctie
glFlags = CALLBACK_FUNCTION
Header.dwBufferLength = 50
Header.dwBytesRecorded = 0
Header.dwFlags = 0
Header.dwOffset = 0
Header.dwUser = 0
Header.lpData = VarPtr(gSysex(0))                 !!!!!!!hier wordt het
adres van gsysex meegegeven aan de header
Header.lpNext = 0
End Sub
******************************************midiinopen************************
********************************************
Public Sub openIR()
gintErrorId = 2
gintError = midiInOpen(glHandle, glDeviceID, AddressOf clbMidiIn,
glInstance, glFlags)           !!!!!!hier wordt de header, en adress van de
callback meegeven
If gintError <> 0 Then GoTo error
GoTo einde
error:
Call ErrorSub(gintError, gintErrorId)
einde:
End Sub
*******************************************call back
functie****************************************************************
Public Sub clbMidiIn(ByVal glHandle As Long, ByVal gMsg As Long, ByVal
glInstance As Long, ByVal gPar1 As Long, ByVal gPar2 As Long)
Call decode
End Sub
********************************************decode wordt opgeroepen in de
callback functie **************************************
Public Sub decode()
'hier sysex controleren manu id , dev id
Dim i As Integer
Dim s As String

gCode = ""
gSysexCode = ""
For i = 0 To 6
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
s = Hex(gSysex(i))
!!!!!!!!!!!!!!hier zit het probleem!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
If Len(s) = 1 Then
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
s = "0" & s
End If
gCode = gCode & s
gSysexCode = gSysexCode & s
Next i
If gCode <> "F0002021600001" Then GoTo einde 'sysexmessage is niet voor ons
bestemd 1e controle
gCode = ""

For i = 7 To 11
If i = 8 Or i = 10 Then 'correctie voor creative code
s = Hex(gSysex(i) + &H80)
Else
s = Hex(gSysex(i))
End If
If Len(s) = 1 Then
s = "0" & s
End If
gCode = gCode & s
gSysexCode = gSysexCode & s
Next i
einde:
End Sub