::: 델파이 Tip&Trick :::

델파이 Tip&Trick 성격에 맞지 않는 광고,비방,질문의 글은 즉시 삭제하며
내용을 복사하여 사용할 경우 반드시 이곳(http://www.howto.pe.kr)을 출처로 명시하여 주세요


Category

  김영대(2003-03-07 10:19:49, Hit : 4616, Vote : 923
 사운드파일 없이 PC 스피커로 음악연주

{Written By Luiz C. Vaz de Brito}

Unit Music;

Interface

Uses Windows, Classes, Forms;

Procedure PlaySong (TuneString:string);

Const
  BaseOctave: Integer = 0;

Implementation

Const
    SharpOffset = 60;

{ Frequency of notes }
   PitchArray: Array[1..120] of Word =
         (28,31,33,37,41,44,49,55,
          62,65,73,82,87,98,110,123,
          131,147,165,175,196,220,247,262,
          294,330,349,392,440,494,523,587,
          659,698,784,880,988,1047,1175,1319,
          1397,1568,1760,1976,2093,2349,2637,2794,
          3136,3520,3951,4186,4699,5274,5588,6272,
          32139,9738,1934,39659,29,33,35,39,
          44,46,52,58,65,69,78,87,
          92,104,117,131,139,156,175,185,
          208,233,262,277,311,349,370,415,
          466,523,554,622,698,740,831,932,
          1047,1109,1245,1397,1480,1661,1865,2093,
          2217,2489,2794,2960,3322,3729,4186,4435,
          4978,5588,5920,6645,35669,33772,1772,18119);

  Octave: Integer = 3; {Thirth Octave - Starts with half C}
  GenNoteType: Integer = 4; {Quarter of note}
  Tempo: Integer = 120; {120 BPM}
  PlayFrac: Byte = 7; {Normal - 7/8 of time}

Var vq: LongInt;
    TmpPitch: LongInt;

{ Write value on Sound port}
procedure SetPort(address, value: Word);
var
  bValue: Byte;
begin
   bValue := trunc(value and 255);
   asm
     mov DX, address
     mov AL, bValue
     out DX, AL
   end;
end;

{ Read value on Sound port}
function GetPort(address: Word): Word;
var
   bValue: Byte;
begin
   asm
     mov DX, address
     in AL, DX
     mov bValue, AL
   end;
   result := bValue;
end;

{ Stop sound}
procedure NoSound;
var
   wValue: Word;
begin
   wValue := GetPort($61);
   wValue := wValue and $FC;
   SetPort($61, wValue);
end;

{Make sound with passed frequency}
procedure Sound(Freq: Word);
var
   B: Word;
begin
   if Freq > 18 then begin
      Freq := Word(1193181 div LongInt(Freq));
      B := GetPort($61);
      if (B and 3) = 0 then begin
         SetPort($61, B or 3);
         SetPort($43, $B6);
      end;
      SetPort($42, Freq);
      SetPort($42, (Freq SHR 8));
   end;
end;

{Delay for x seconds }
procedure Delay(MSecs: Integer);
var
   FirstTickCount : LongInt;
begin
   FirstTickCount:=GetTickCount;
   repeat
      Application.ProcessMessages;
   until ((GetTickCount-FirstTickCount) >= LongInt(MSecs));
end;


{Exec string on music standard PLAY of basic }
Procedure PlaySong (TuneString:string);
  Var
    PlayTime: LongInt;
    IdleTime: LongInt;
    DotTime: LongInt;
    NoteTime : LongInt;
    NoteType: Integer;
    PitchIndex: Integer;
    Position: Integer;
    Number : Integer;
    Code: Integer;
    TuneStrLen: Integer;
    Character: Char;
    PlayDone: Boolean;


  Procedure NVal(Pos:integer; var v, code: integer);
  Var
      Posn:integer;
  Begin
     v := 0;
     posn := Pos;
     while (posn <= TuneStrLen) and (TuneString[posn] in ['0'..'9']) do
     Begin
       v := v*10 + ord(TuneString[posn]) - ord ('0');
       Inc(posn);
     End;
     code := posn - Pos + 1;
  End;

   Procedure CheckDots; {There are points after note?}
   Begin
      While (Position <= TuneStrLen) and (TuneString[Position] = '.') do

       Begin
          DotTime := DotTime + DotTime div 2;
          inc(Position)
       End;
   End;

Begin
  PlayDone := False;
  TuneStrLen := length(TuneString);
  Position := 1;
  Repeat
    NoteType := GenNoteType;
    DotTime := 1000;
    Character := upcase(TuneString[Position]);
    Case Character Of
      'A'..'G' : Begin
                 PitchIndex := (ord(Character)-64)+Octave*7;
                 If (Character='A') or (Character='B') Then
                   PitchIndex := PitchIndex + 7;
                 inc(Position);

                 {Bemol ou sustenido?}
                 if Position <= TuneStrLen then
                   case TuneString[Position] of
                     '#','+': begin
                              PitchIndex := PitchIndex+SharpOffset;
                              inc(Position);
                              end;
                     '-': begin
                          PitchIndex := PitchIndex+SharpOffset - 1;
                          inc(Position);
                          end;
                     End;

                 if (Position <= TuneStrLen) and
                 (TuneString[Position] in ['0'..'9']) then begin
                   NVal(Position,NoteType,Code);
                   inc(Position, Code - 1)
                 end;
                 CheckDots;
                 {Toca a nota}
                 NoteTime := Round(DotTime/Tempo/NoteType*240);
                 PlayTime := Round(NoteTime*PlayFrac/8);
                 IdleTime := NoteTime-PlayTime;
                 Sound(PitchArray[PitchIndex]);
                 Delay(PlayTime);
                 if IdleTime <> 0 then begin
                    NoSound;
                    Delay(IdleTime)
                   end;
                 End;
      'L' : {Duracao 1 - 64 }
            Begin
            NVal (Position+1,GenNoteType,Code);
            if (GenNoteType < 1) or (GenNoteType > 64) then
              GenNoteType := 4;
            inc(Position, Code);
            End;
      'M' : {"S" staccato,"L" legato,"N" normal.}
            Begin
            if Position < TuneStrLen then
              begin
              Case upcase(TuneString[Position+1]) Of
                'S' : PlayFrac := 6;
                'N' : PlayFrac := 7;
                'L' : PlayFrac := 8;
                End;
              inc(Position, 2);
              end;
            End;
      'O' : Begin
            NVal (Position+1,Octave,Code);
            Octave := Octave+BaseOctave;
            if Octave > 7 then
              Octave := 3;
            inc(Position, Code);
            End;
      'P' : Begin
            NoSound;
            NVal (Position+1,NoteType,Code);
            if (NoteType < 1) or (NoteType > 64) then
              NoteType := GenNoteType;
              inc(Position, Code);
              CheckDots;
              IdleTime := DotTime Div Tempo * (240 Div NoteType);
              Delay (IdleTime);
              End;
      'T' : {Tempo - BPM (32 - 255)}
            Begin
            NVal (Position+1,Tempo,Code);
            if (Tempo < 32) or (Tempo > 255) then
              Tempo := 120;
            inc(Position, Code);
            End;
      Else
        inc(Position); {Ignore wrong caracters}
      End;
    Until ((Position > TuneStrLen) Or (PlayDone));
    NoSound;
    End;
End.

-------------------------------------------------------------
And here, some musics yet for PlaySong.

William Tell Overture
=====================
PlaySong('O2L16T155P8MSO1BBB8BBB8BBO2E8F#8G#8O1BBB8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#');
PlaySong('MLB4BMSAG#F#E8G#8E8O3BBB8BBB8BBO4E8F#8G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BB');
PlaySong('O4E8F#8G#8MLEG#B4BAG#F#MSE8G#8E8P2');

Familia Adams;
==============
PlaySong('O3T220L8CDEFP4O0L4FP8FP8O3L8DEF#GP4O1L4GP8GP8O3L8DEF#GP4DEF#GP4CDEFP4O1L4FP8FP8');
PlaySong('P4T187O3L8CF.AF.DO2B-.O3GP4FE.GE.CO2A.O3FP4CF.AF.DO2B-.O3GP4FL64EFL8E.CD.EFP4');
PlaySong('O3T220L8CDEFP4O0L4FP8FP8O3L8DEF#GP4O1L4GP8GP8O3L8DEF#GP4DEF#GP4CDEFP4O1L4FP8FP8');
PlaySong('P4T187O3L8CF.AF.DO2B-.O3GP4FE.GE.CO2A.O3FP4CF.AF.DO2B-.O3GP4FL64EFL8E.CD.EFP2');

Beverly Hills Cop
=================
PlaySong('t125msl4o3fg#l8fl16fl8a#l8fd#l4fl4o4cl8o3fl16fl8o4c#co3g#fo4cl8fo3l16fl8d#l16d#l8cl8gl4fp2');
PlaySong('t125msl4o3fg#l8fl16fl8a#l8fd#l4fl4o4cl8o3fl16fl8o4c#co3g#fo4cl8fo3l16fl8d#l16d#l8cl8gl4fp2');
PlaySong('o1l4ffl8d#l16d#l8d#l8cd#l4ffp8l16fl8fcfl4c#c#l8d#l16d#l8d#d#d#fp2l8fco0l8a#g#l4f');
PlaySong('o1l4fl8d#l16d#l8d#l8cd#l4ffp8l16fl8fcfl4c#c#l8d#l16d#l8d#d#d#fp2');

James bond theme
================
PlaySong('mll8t125O1b4ebo2c4o1eo2cc#4o1eo2c#c4o1eo2cO1b4ebo2c4o1eo2cc#4o1eo2c#c4o1eo2c');
PlaySong('t150mno3ef#16f#16f#f#3o2eeemno3eg16g16gg3o2f#F#F#mno3ef#16f#16f#f#3o2eee');
PlaySong('mno3eg16g16gg3o2f#F#F#mno3ef#16f#16f#f#3o2eeemno3eg16g16gg3o2f#F#e');
PlaySong('mlo4d#o3b64o4dd2o2g64bf#64amlg24b1P2');

Leave it to beaver
==================
PlaySong('MST190O2L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFL4DL8<B-L4G..P16');
PlaySong('L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F..P8O3L4AL8AL4G.L8FGFL4E-L8EDE-EFGG+L4A..P8');
PlaySong('O1L4GL8GL4F.L8EFEL4D-L8DDEFG>G<G>C<B-AG.P16O2L8CL4FL8A>C<AFL4GL8B-L4>D');
PlaySong('L8C<B>CFL4DL8<B-L4G..P16O3L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F.L8>FP2');

London Bridge
=============
PlaySong('MST190O2L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFL4DL8<B-L4G..P16');
PlaySong('L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F..P8O3L4AL8AL4G.L8FGFL4E-L8EDE-EFGG+L4A..P8');
PlaySong('O1L4GL8GL4F.L8EFEL4D-L8DDEFG>G<G>C<B-AG.P16O2L8CL4FL8A>C<AFL4GL8B-L4>D');
PlaySong('L8C<B>CFL4DL8<B-L4G..P16O3L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F.L8>FP2');

My Darling Clementine
=====================
PlaySong('T120MNO2L8G.L16GL4GDL8B.L16BL4BGL8GBO3L4DDL8CO2BL2AL8ABO3L4CCO2L8B.L16AL4BGL8GB');
PlaySong('L4ADL8F#.L16AL2GL8G.L16GL4GDL8B.L16BL4BGL8GBO3L4D.L8DCO2BL2AL8ABO3L4CC');
PlaySong('O2L8B.L16AL4BGL8GBL4ADL8F#.L16AL2GL8G.L16GL4GDL8B.L16BL4BGL8GBO3L4DDL8C');
PlaySong('O2BL2AL8ABO3L4CCP2');

The Entertainers
================
PlaySong('T120MNO3L8DD#EO4L4CO3L8EO4L4CO3L8EO4L4C.P4P8L8CDD#ECDL4EL8O3BL4O4DCP4P4O3L8DD#EL4');
PlaySong('O4CO3L8EO4L4CO3L8EL4O4C.P4P4O3L8AGF#AO4CL4EL8DCO3AO4L4DP4P4O3L8DD#EL4O4C');
PlaySong('O3L8EO4L4CO3L8EO4L4C.P4P4L8CDD#ECDL4EL8O3BO4L4DCP4P4L8CDECDL4EL8CDCECDL4E');
PlaySong('L8CDCECDL4EO3BO4L4ECP2');
---------------------------------------





491   [일반/컴포넌트] TRichEdit 의 선택된 영역만 인쇄하기  김영대 2003/03/07 4432 718
490   [시스템] CPU 종류 구하기  김영대 2003/03/07 4782 1193
  [시스템] 사운드파일 없이 PC 스피커로 음악연주  김영대 2003/03/07 4616 923
488   [네트웍/인터넷] 프로그램으로 네트워크 드라이브 연결/해제  김영대 2003/03/07 6683 1245
487   [일반/컴포넌트] 윈도우즈 종료와 같은 그늘진 화면 만들기  김영대 2003/03/07 3131 836
486   [일반/컴포넌트] 아이콘 사이트  김영대 2003/03/07 3606 1067
485   [시스템] 윈도우즈 시스템 표준 폰트 구하기  김영대 2003/03/07 3010 846
484   [네트웍/인터넷] RS232 통신  김영대 2003/03/07 6892 1853
483   [일반/컴포넌트] 주어진 영역의 화면 캡처  김영대 2003/03/07 3554 1008
482   [일반/컴포넌트] 숫자를 영문 표기로 바꾸기  김영대 2003/03/07 4238 886
481   [일반/컴포넌트] 숫자를 한글 표기로 바꾸기  김영대 2003/03/07 3594 927
480   [일반/컴포넌트] RichEdit 의 내용을 Bitmap 으로 만들기 2  김영대 2003/03/07 3760 979
479   [COM/OLE] MS-WORD 종료시키기  김영대 2003/03/07 2648 742
478   [윈도우즈 API] 시스템 사운드 연주하기  김영대 2003/03/07 4775 1296
477   [일반/컴포넌트] Algorithm to sort a TStringGrid #2  김영대 2003/03/07 4760 1197
476   [윈도우즈 API] 외부 프로그램의 좌표,상태 구하기  김영대 2003/03/07 3154 1013
475   [윈도우즈 API] 윈도우즈 Telnet 으로 호스트 접속하기  김영대 2003/03/07 4060 1117
474   [일반/컴포넌트] 특정한 폴더로 이동한 DOS 창 띄우기  김영대 2003/03/07 4093 1134
473   [시스템] DOS 명령어 실행하고 결과 받아오기  김영대 2003/03/07 6531 1548
472   [윈도우즈 API] NT의 현재 user가 administrative privilege 를 가지고 있는지?  김영대 2003/03/07 2964 808
471   [일반/컴포넌트] 두개의 StringGrid sync 마추기  김영대 2003/03/07 3690 1017
470   [일반/컴포넌트] 윈도우의 title bar 폰트 바꾸기  김영대 2003/03/07 3211 839
469   [네트웍/인터넷] 네트워크 공유 설정/해제 하기 (Windows 9x)  김영대 2003/03/07 4361 1078
468   [네트웍/인터넷] 네트워크 공유 정보 읽어오기 (WIndows 9x)  김영대 2003/03/07 3631 969
467   [일반/컴포넌트] 눌려진 키보드 키의 명칭 구하기  김영대 2003/03/07 7358 1437
466   [윈도우즈 API] Windows98 에서의 SetForegroundWindow  김영대 2003/03/07 5722 1489
465   [윈도우즈 API] Task bar 에 나타나지 않는 프로그램 만들기  김영대 2003/03/07 5137 1508
464   [COM/OLE] Outlook 사용하기  김영대 2003/03/07 3456 1090
463   [시스템] 지정한 drive가 CD-ROM 인지 검사하기  김영대 2003/03/07 6275 1649
462   [시스템] 어떤 어플리케이션이 시작 되는지 hook으로 알아내기  김영대 2003/03/07 5081 1507
461   [윈도우즈 API] 윈도우즈 탐색기의 아이콘 뽑아내서 사용하기  김영대 2003/03/07 6445 1887
460   [윈도우즈 API] System Images  김영대 2003/03/07 6284 1828
459   [윈도우즈 API] 컴퓨터/파일/폴더 찾기 화면 띄우기  김영대 2003/03/07 6146 1470
458   [일반/컴포넌트] Unix-format time 을 TDateTime 로 바꾸기  김영대 2003/03/07 4086 1121
457   [일반/컴포넌트] 실행시 component 를 Move/Resize 시키기  김영대 2003/03/07 3295 951
456   [일반/컴포넌트] TMemo 를 화면크기로 인쇄하기  김영대 2003/03/07 2728 692
455   [일반/컴포넌트] SpeedButton 에 OnMouseEnter/OnMouseExit 이벤트 넣기  김영대 2003/03/07 3930 1041
454   [윈도우즈 API] 키보드의 Scroll Lock 켜기/끄기  김영대 2003/03/07 4136 1135
453   [데이터베이스] table packing 하기  김영대 2003/03/07 3446 1000
452   [윈도우즈 API] reboot Windows  김영대 2003/03/07 3865 1119

[이전 10개] [1]..[11][12] 13 [14][15][16][17][18][19][20]..[25] [다음 10개]
 

Copyright 1999-2022 Zeroboard / skin by zero