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

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


Category

  김영대(2003-03-07 10:19:49, Hit : 4637, 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   [일반/컴포넌트] 숫자를 한글 표기로 바꾸기  김영대 2003/03/07 3610 927
490   [일반/컴포넌트] 숫자를 영문 표기로 바꾸기  김영대 2003/03/07 4244 890
489   [일반/컴포넌트] 주어진 영역의 화면 캡처  김영대 2003/03/07 3558 1008
488   [네트웍/인터넷] RS232 통신  김영대 2003/03/07 6916 1855
487   [시스템] 윈도우즈 시스템 표준 폰트 구하기  김영대 2003/03/07 3019 850
486   [일반/컴포넌트] 아이콘 사이트  김영대 2003/03/07 3613 1067
485   [일반/컴포넌트] 윈도우즈 종료와 같은 그늘진 화면 만들기  김영대 2003/03/07 3138 840
484   [네트웍/인터넷] 프로그램으로 네트워크 드라이브 연결/해제  김영대 2003/03/07 6716 1250
  [시스템] 사운드파일 없이 PC 스피커로 음악연주  김영대 2003/03/07 4637 923
482   [시스템] CPU 종류 구하기  김영대 2003/03/07 4802 1194
481   [일반/컴포넌트] TRichEdit 의 선택된 영역만 인쇄하기  김영대 2003/03/07 4472 725
480   [일반/컴포넌트] TRichEdit 의 64K 한계  김영대 2003/03/07 4027 1097
479   [시스템] 설치된 프린터 드라이버 정보 구하기  김영대 2003/03/07 3083 814
478   [일반/컴포넌트] PASCAL 포인터 연산  김영대 2003/03/07 2828 789
477   [시스템] Time Zone 정보를 시분으로 읽어오기  김영대 2003/03/07 2909 790
476   [일반/컴포넌트] {$I-} and {$I+} do not work under NT4.0  김영대 2003/03/07 2315 591
475   [시스템] Thread 사용하기  김영대 2003/03/07 4216 1153
474   [일반/컴포넌트] 열거형(Enumerated) 상수를 문자열로 바꾸기  김영대 2003/03/07 4338 1277
473   [일반/컴포넌트] 폼의 최소화시 에니매이션 아이콘 보여주기  김영대 2003/03/07 3176 888
472   [일반/컴포넌트] 윈도우즈 제어판 화면 띄우기  김영대 2003/03/07 4568 1246
471   [데이터베이스] TDBGrid - Boolean CheckBox  김영대 2003/03/07 3249 807
470   [일반/컴포넌트] 파일의 버전정보 읽어오기  김영대 2003/03/07 3431 891
469   [일반/컴포넌트] MS-OutLook 으로 메시지 보내기  김영대 2003/03/07 5132 1175
468   [일반/컴포넌트] MessageDlg()의 default 버튼 선택해서 띄우기  김영대 2003/03/07 3470 993
467   [네트웍/인터넷] 기본 인터넷 윕브라우저의 파일명 구하기  김영대 2003/03/07 2861 783
466   [네트웍/인터넷] TCP/IP 가 설치되어 있는지 검사하기  김영대 2003/03/07 3345 999
465   [시스템] Message Queue에 특정 메시지가 있는지 검사  김영대 2003/03/07 3199 892
464   [윈도우즈 API] EXCEL 종료시키기  김영대 2003/03/07 4673 1180
463   [시스템] 화면보호기가 설치되어 있는지 검사하기  김영대 2003/03/07 3978 1153
462   [윈도우즈 API] TreeView의 hint popup 없애기  김영대 2003/03/07 5669 1811
461   [윈도우즈 API] NT Server or NT Workstation 구분하기  김영대 2003/03/07 3689 1094
460   [알고리즘] Bubble, Selection, Quick Sort algorithm  김영대 2003/03/07 3155 927
459   [시스템] 두개의 파일이 완전히 동일한지 검사하기2  김영대 2003/03/07 3376 973
458   [윈도우즈 API] 실행된 Tray Icon 변경하기  김영대 2003/03/07 6409 1912
457   [시스템] BIOS 함수를 사용한 drive 접근방법  김영대 2003/03/07 3142 905
456   [일반/컴포넌트] TCanvas or TBitmap -> TGIFImage  김영대 2003/03/07 4862 1150
455   [일반/컴포넌트] Memo, RichEdit 선택행의 들여쓰기/내여쓰기  김영대 2003/03/07 3236 709
454   [일반/컴포넌트] 숫자앞의 무효한 0 제거하기  김영대 2003/03/07 4050 1099
453   [시스템] 윈도우즈에 설치된 프린터 리스트 구하기  김영대 2003/03/07 4254 1120
452   [시스템] PC 스피커 울리기(Sound, NoSound)  김영대 2003/03/07 4425 1204

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

Copyright 1999-2022 Zeroboard / skin by zero