Reproducir archivo MIDI en piano virtual

Con esta aplicación puedes abrir un archivo MIDI y reproducirlo en un piano virtual. Para que funcione hay que instalar previamente el package zzPianoEx.dpk con lo que tendremos los componentes: TPianoKeyBoard, TMidiOutput, TMidiFile, TMidiInput, TMidiPlayer, TPianoChannels, TPianoTracks.

XI'AN Science and Technology University, Shanghai, China


http://www.PianoEx.com


Author: ZHONG WAN


Email: webmaster@PianoEx.com


MSN: ziziiwan@hotmail.com




Descargar programa

Codigo fuente

Ejemplos archivos MIDI

Archivo1.mid

Archivo2.mid
Archivo3.mid







 

Enviar caracteres al buffer de teclado

Esta unit envía directamente caracteres al buffer de teclado, buscando en la red me encontré con que hay códigos que funcionan sólamente en versiones antiguas de Delphi, el que a continuación os copio está probado en Delphi 2009 y Rad Studio 10 y funciona perfectamente.

unit sendkey;

interface

uses
  SysUtils, Windows, Messages;

function SendKeys(SendKeysString: {$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}; Wait: Boolean): Boolean;

function AppActivate(WindowName: {$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}): Boolean;

{Buffer for working with PChar's}

const
  WorkBufLen = 40;
var
  WorkBuf : array[0..WorkBufLen] of Char;

implementation

type
  THKeys = array[0..pred(MaxLongInt)] of Byte;
var
  AllocationSize : integer;

(*
Converts a string of characters and key names to keyboard events and
passes them to Windows.

Example syntax:

SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);

*)

Function SendKeys(SendKeysString: {$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}; Wait: Boolean): Boolean;
type
  WBytes = array[0..pred(SizeOf(Word))] of Byte;

  TSendKey = record
  Name : ShortString;
  VKey : Byte;
end;

const
  {Array of keys that SendKeys recognizes.

  If you add to this list, you must be sure to keep it sorted alphabetically
  by Name because a binary search routine is used to scan it.}

  MaxSendKeyRecs = 41;
  SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
  (
  (Name:'BKSP'; VKey:VK_BACK),
  (Name:'BS'; VKey:VK_BACK),
  (Name:'BACKSPACE'; VKey:VK_BACK),
  (Name:'BREAK'; VKey:VK_CANCEL),
  (Name:'CAPSLOCK'; VKey:VK_CAPITAL),
  (Name:'CLEAR'; VKey:VK_CLEAR),
  (Name:'DEL'; VKey:VK_DELETE),
  (Name:'DELETE'; VKey:VK_DELETE),
  (Name:'DOWN'; VKey:VK_DOWN),
  (Name:'END'; VKey:VK_END),
  (Name:'ENTER'; VKey:VK_RETURN),
  (Name:'ESC'; VKey:VK_ESCAPE),
  (Name:'ESCAPE'; VKey:VK_ESCAPE),
  (Name:'F1'; VKey:VK_F1),
  (Name:'F10'; VKey:VK_F10),
  (Name:'F11'; VKey:VK_F11),
  (Name:'F12'; VKey:VK_F12),
  (Name:'F13'; VKey:VK_F13),
  (Name:'F14'; VKey:VK_F14),
  (Name:'F15'; VKey:VK_F15),
  (Name:'F16'; VKey:VK_F16),
  (Name:'F2'; VKey:VK_F2),
  (Name:'F3'; VKey:VK_F3),
  (Name:'F4'; VKey:VK_F4),
  (Name:'F5'; VKey:VK_F5),
  (Name:'F6'; VKey:VK_F6),
  (Name:'F7'; VKey:VK_F7),
  (Name:'F8'; VKey:VK_F8),
  (Name:'F9'; VKey:VK_F9),
  (Name:'HELP'; VKey:VK_HELP),
  (Name:'HOME'; VKey:VK_HOME),
  (Name:'INS'; VKey:VK_INSERT),
  (Name:'LEFT'; VKey:VK_LEFT),
  (Name:'NUMLOCK'; VKey:VK_NUMLOCK),
  (Name:'PGDN'; VKey:VK_NEXT),
  (Name:'PGUP'; VKey:VK_PRIOR),
  (Name:'PRTSC'; VKey:VK_PRINT),
  (Name:'RIGHT'; VKey:VK_RIGHT),
  (Name:'SCROLLLOCK'; VKey:VK_SCROLL),
  (Name:'TAB'; VKey:VK_TAB),
  (Name:'UP'; VKey:VK_UP)
  );

  {Extra VK constants missing from Delphi's Windows API interface}
  VK_NULL=0;
  VK_SemiColon=186;
  VK_Equal=187;
  VK_Comma=188;
  VK_Minus=189;
  VK_Period=190;
  VK_Slash=191;
  VK_BackQuote=192;
  VK_LeftBracket=219;
  VK_BackSlash=220;
  VK_RightBracket=221;
  VK_Quote=222;
  VK_Last=VK_Quote;

  ExtendedVKeys : set of byte =
  [VK_Up,
  VK_Down,
  VK_Left,
  VK_Right,
  VK_Home,
  VK_End,
  VK_Prior, {PgUp}
  VK_Next, {PgDn}
  VK_Insert,
  VK_Delete];

const
  INVALIDKEY = $FFFF {Unsigned -1};
  VKKEYSCANSHIFTON = $01;
  VKKEYSCANCTRLON = $02;
  VKKEYSCANALTON = $04;
  UNITNAME = 'SendKeys';
var
  UsingParens,
  ShiftDown  ,
  ControlDown,
  AltDown    ,
  FoundClose : Boolean;
  PosSpace   : Byte;
  I, L       : Integer;
  NumTimes   ,
  MKey       : Word;
  KeyString  : String[20];

  procedure DisplayMessage(Message : PChar);
  begin
    MessageBox(0,Message,UNITNAME,0);
  end;

  function BitSet(BitTable, BitMask : Byte) : Boolean;
  begin
    Result := ByteBool(BitTable and BitMask);
  end;

  procedure SetBit(var BitTable : Byte; BitMask : Byte);
  begin
    BitTable := BitTable or Bitmask;
  end;

  procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
  var
    KeyboardMsg: TMsg;
  begin
    keybd_event(VKey, ScanCode, Flags,0);
    if (Wait) then
      while (PeekMessage(KeyboardMsg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do
      begin
        TranslateMessage(KeyboardMsg);
        DispatchMessage(KeyboardMsg);
      end;
  end;

  procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
  var
    Cnt          : Word;
    ScanCode     : Byte;
    NumState     : Boolean;
    KeyBoardState: TKeyboardState;
  begin
    if (VKey=VK_NUMLOCK) then
    begin
      NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
      GetKeyBoardState(KeyBoardState);
      if NumState then
        KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] and not 1)
      else
        KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] or 1);
      SetKeyBoardState(KeyBoardState);
      Exit;
    end;

    ScanCode:=Lo(MapVirtualKey(VKey,0));
    for Cnt := 1 to NumTimes do
      if (VKey in ExtendedVKeys)then
      begin
        KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
        if (GenUpMsg) then
          KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
      end
      else
      begin
        KeyboardEvent(VKey, ScanCode, 0);
        If (GenUpMsg) then
          KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
      end;
  end;

  procedure SendKeyUp(VKey: Byte);
    var
    ScanCode: Byte;
  begin
    ScanCode := Lo(MapVirtualKey(VKey,0));
    if (VKey in ExtendedVKeys)then
      KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
    else
      KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
  end;

  procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
  begin
    if (BitSet(Hi(MKey), VKKEYSCANSHIFTON)) then
      SendKeyDown(VK_SHIFT,1,False);
    if (BitSet(Hi(MKey), VKKEYSCANCTRLON)) then
      SendKeyDown(VK_CONTROL,1,False);
    if (BitSet(Hi(MKey), VKKEYSCANALTON)) then
      SendKeyDown(VK_MENU,1,False);
    SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
    if (BitSet(Hi(MKey), VKKEYSCANSHIFTON)) then
      SendKeyUp(VK_SHIFT);
    if (BitSet(Hi(MKey), VKKEYSCANCTRLON)) then
      SendKeyUp(VK_CONTROL);
    if (BitSet(Hi(MKey), VKKEYSCANALTON)) then
      SendKeyUp(VK_MENU);
  end;

{Implements a simple binary search to locate special key name strings}

  function StringToVKey(KeyString : ShortString) : Word;
  var
    Found   ,
    Collided: Boolean;
    Bottom  ,
    Top     ,
    Middle  : Byte;
  begin
    Result := INVALIDKEY;
    Bottom := 1;
    Top    := MaxSendKeyRecs;
    Found  := False;
    Middle := (Bottom+Top) div 2;
    repeat
      Collided := ((Bottom = Middle) or (Top = Middle));
      if (KeyString = SendKeyRecs[Middle].Name) then
      begin
        Found  := True;
        Result := SendKeyRecs[Middle].VKey;
      end
      else
      begin
        if (KeyString > SendKeyRecs[Middle].Name) then
          Bottom := Middle
        else
          Top  := Middle;
        Middle := (Succ(Bottom+Top)) div 2;
      end;
    until (Found or Collided);
    if (Result = INVALIDKEY) then
      DisplayMessage('Invalid Key Name');
  end;

  procedure PopUpShiftKeys;
  begin
    if (not UsingParens) then
    begin
      if ShiftDown then
        SendKeyUp(VK_SHIFT);
      if ControlDown then
        SendKeyUp(VK_CONTROL);
      if AltDown then
        SendKeyUp(VK_MENU);
      ShiftDown   := False;
      ControlDown := False;
      AltDown     := False;
    end;
  end;

begin
  AllocationSize := MaxInt;
  Result         := False;
  UsingParens    := False;
  ShiftDown      := False;
  ControlDown    := False;
  AltDown        := False;
  I              := 0;
  L              := StrLen(SendKeysString);

  if (L > AllocationSize) then
    L := AllocationSize;

  if (L = 0) then
    Exit;

  while (I < L) do
  begin
    case SendKeysString[I] of
      '(' :
      begin
        UsingParens:=True;
        Inc(I);
      end;
      ')' :
      begin
        UsingParens:=False;
        PopUpShiftKeys;
        Inc(I);
      end;
      '%' :
      begin
        AltDown:=True;
        SendKeyDown(VK_MENU, 1, False);
        Inc(I);
      end;
      '+' :
      begin
        ShiftDown:=True;
        SendKeyDown(VK_SHIFT, 1, False);
        Inc(I);
      end;
      '^' :
      begin
        ControlDown:=True;
        SendKeyDown(VK_CONTROL, 1, False);
        Inc(I);
      end;
      '{' :
      begin
        NumTimes:=1;
        if (SendKeysString[Succ(I)] = '{') then
        begin
          MKey:=VK_LEFTBRACKET;
          SetBit(Wbytes(MKey)[1], VKKEYSCANSHIFTON);
          SendKey(MKey, 1, True);
          PopUpShiftKeys;
          Inc(I, 3);
          Continue;
        end;

        KeyString := '';
        FoundClose:=False;

        while (I<=L) do
        begin
          Inc(I);
          If (SendKeysString[I]='}') then
          begin
            FoundClose:=True;
            Inc(I);
            Break;
          end;
          KeyString := KeyString + UpCase(SendKeysString[I]);
        end;

        if (Not FoundClose) then
        begin
          DisplayMessage('No Close');
          Exit;
        end;

        if (SendKeysString[I]='}') then
        begin
          MKey := VK_RIGHTBRACKET;
          SetBit(Wbytes(MKey)[1], VKKEYSCANSHIFTON);
          SendKey(MKey, 1, True);
          PopUpShiftKeys;
          Inc(I);
          Continue;
        end;

        PosSpace := Pos(' ', KeyString);

        if (PosSpace <> 0) then
        begin
          NumTimes  := StrToInt(Copy(KeyString, Succ(PosSpace), Length(KeyString)-PosSpace));
          KeyString := Copy(KeyString, 1, Pred(PosSpace));
        end;

        if (Length(KeyString) = 1) then
          MKey := VkKeyScanA(KeyString[1])
        else
          MKey := StringToVKey(KeyString);

        if (MKey <> INVALIDKEY) then
        begin
          SendKey(MKey, NumTimes, True);
          PopUpShiftKeys;
          Continue;
        end;
      end;
      '~' :
      begin
        SendKeyDown(VK_RETURN, 1, True);
        PopUpShiftKeys;
        Inc(I);
      end;
      else
      begin
        MKey:={$IFDEF UNICODE}VkKeyScanW{$ELSE}VkKeyScanA{$ENDIF}(SendKeysString[I]);
        If (MKey <> INVALIDKEY) then
        begin
          SendKey(MKey, 1, True);
          PopUpShiftKeys;
        end
        else
          DisplayMessage('Invalid KeyName');
        Inc(I);
      end;
    end;
  end;

  Result := True;
  PopUpShiftKeys;
end;

{AppActivate

This is used to set the current input focus to a given window using its
name. This is especially useful for ensuring a window is active before
sending it input messages using the SendKeys function. You can specify
a window's name in its entirety, or only portion of it, beginning from
the left.

}

var
  WindowHandle : HWND;

function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
const
  MAX_WINDOW_NAME_LEN = 80;
var
  WindowName: array[0..MAX_WINDOW_NAME_LEN] of Char;
begin
  {Can't test GetWindowText's return value since some windows don't have a title}
  GetWindowText(WHandle, WindowName, MAX_WINDOW_NAME_LEN);
  Result := (StrLIComp(WindowName, PChar(lParam), StrLen(PChar(lParam))) <> 0);
  if (not Result) then
    WindowHandle := WHandle;
end;

function AppActivate(WindowName: {$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}): Boolean;
begin
  try
    Result := True;
    WindowHandle:= {$IFDEF UNICODE}FindWindowW{$ELSE}FindWindowA{$ENDIF}(nil, WindowName);
    if (WindowHandle=0) then
      EnumWindows(@EnumWindowsProc,Integer(PChar(WindowName)));
    if (WindowHandle<>0) then
    begin
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
    end
    else
      Result := False;
  except
    on Exception do
      Result := False;
  end;
end;

end.


//la llamada a la funcion podria ser:
//sendkeys('esto es una prueba',false);