XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Sound: Klavier-Tastatur erstellen
 $I Klaviatur.inc
Autor:     Rainer Berg
Albert-Schweitzer-Str. 40
01968 Senftenberg
eMail:  r.berg@rainer-berg.com
----- Klaviatur.inc ----------------------------------------------------------------
declare Ton&[61],lb%
Play 0,8,0
Def LoadImage(6) !USER32,LoadImageA

Proc Klaviatur

    Declare l1%,l2%,b1%,b2%,Tnr%,i%,lv%,lh%,z%,w&,s&,w$,groesse%,okt%
    Parameters groesse%,lh%,lv%,okt%,i%
    --- Tastenmaße -----
    l1%=.7*groesse%  Länge Taste ganzer Ton
    l2%=.45*groesse%           halber Ton
    b1%=.22*groesse% Breite     ganzer Ton
    b2%=.14*groesse%           halber Ton
    MCLS ADD(b1%,b2%),l1% erzeugen temporäre BMP-Datei für schwarz und weiß
    StartPaint -1
    Usepen 5,0,0
    Usebrush 1,RGB(255,255,255)
    Rectangle 0,0-b1%,l1%
    w$=f.bmp
    SaveBmp w$,0,0-b1%,l1%
    w&=LoadImage(%HInstance,ADDR(w$),0,b1%,l1%,$50)
    Usebrush 1,0
    Rectangle b1%,0-ADD(b1%,b2%),l2%
    w$=f.bmp
    SaveBmp w$,b1%,0-b2%,l2%
    s&=LoadImage(%HInstance,ADDR(w$),0,b2%,l2%,$50)
    Assign #1,w$
    Erase #1
    EndPaint

    If i%

        RoundRect SUB(lh%,10),SUB(lv%,10)-ADD(ADD(ADD(lh%,MUL(MUL(okt%,7),b1%)),b1%),120),ADD(ADD(lv%,l1%),10);10,10

    Else

        RoundRect SUB(lh%,10),SUB(lv%,10)-ADD(ADD(ADD(lh%,MUL(MUL(okt%,7),b1%)),b1%),20),ADD(ADD(lv%,l1%),10);10,10

    EndIf

    Usebrush 1,RGB(156,102,62)
    FILL lh%,lv%,0

    If i%

        UseFont Arial,12,0,0,0,0
        SetDialogFont 1
        lb%=CreateListbox(%HWnd,,ADD(ADD(ADD(lh%,MUL(MUL(okt%,7),b1%)),b1%),10),lv%,100,l1%)
        dbOpen(#1,GM_MIDI.DBF)

        WhileLoop dbUse(#1)

            AddString dbGet$(INSTRUMENT)
            dbGo(Next)

        Wend

        dbClose(#1)
        MoveListToList(lb%)
        SetDialogFont 0

    EndIf

    WhileLoop okt% Anzahl Oktaven, schwarze Tasten

        z%=SUB(&loop,1)
        Tnr%=MUL(z%,12)

        WhileLoop 7

            Tnr%=ADD(Tnr%,2)
            Case EQU(&loop,4):DEC Tnr%

            IfNot OR(EQU(&loop,3),EQU(&loop,7))

                Ton&[Tnr%]=Control(BUTTON,,$54010880,SUB(ADD(SUB(ADD(MUL(&loop,b1%),ADD(MUL(z%,MUL(7,b1%)),b1%)),b1%),lh%),1),lv%,b2%,l2%,%hwnd,0,%hinstance,$0)
                SendMessage(Ton&[Tnr%],247,0,s&)

            EndIf

        Wend

    Wend

    Tnr%=0

    WhileLoop okt% Anzahl Oktaven, weiße Tasten

        z%=SUB(&loop,1)

        WhileLoop 7

            Tnr%=ADD(Tnr%,2)
            Case OR(EQU(&loop,4),EQU(&loop,1)):DEC Tnr%
            Ton&[Tnr%]=Control(BUTTON,,$54010880,ADD(SUB(ADD(MUL(&loop,b1%),ADD(MUL(z%,MUL(7,b1%)),DIV(b2%,2))),b1%),lh%),lv%,b1%,l1%,%hwnd,0,%hinstance,$0)
            SendMessage(Ton&[Tnr%],247,0,w&)

        Wend

    Wend

    INC z% abschließende Taste C
    INC Tnr%
    Ton&[Tnr%]=Control(BUTTON,,$54010880,ADD(SUB(ADD(b1%,ADD(MUL(z%,MUL(b1%,7)),DIV(b2%,2))),b1%),lh%),lv%,b1%,l1%,%hwnd,0,%hinstance,$0)
    SendMessage(Ton&[Tnr%],247,0,w&)

EndProc

Proc TonSpielen

    Declare nr%
    Parameters okt%

    WhileLoop ADD(MUL(okt%,12),1)

        If GetFocus(Ton&[&loop])

            nr%=&loop

        EndIf

    wend

    Case nr%:Play ADD(nr%,36),8,0 spielen
    Return nr%

EndProc

Proc TonNummer

    Declare nr%
    Parameters okt%

    WhileLoop ADD(MUL(okt%,12),1)

        Case GetFocus(Ton&[&loop]):nr%=&loop

    wend

    Return nr%

EndProc

Proc Instrument

    Declare w$
    w$=ADD$(I0 ,STR$(GetCurSel(lb%)))
    MUSIC w$ Instrument einstellen

EndProc

---------------------------------------------------------------------
##### DEMO ######################################################################
Declare w$
Play 0,8,0
WindowStyle 27
Window 0,0-800,575
SetTruecolor 1
CLS RGB(224,240,255)
Klaviatur 80,20,320,2,1

WhileNot EQU(%Key,2)

    SetFocus(0)
    WaitInput

    If GetFocus(lb%)

        Instrument

    Else

        TonSpielen 2

    EndIf

Wend

End