Delphinin (D) si

 

Object bir programlama dili olan delphi babadır kraldır. Hem amatorlerin hemde profosyonellerin kullanabileceği componentlerle gelişmeye açık çok baba bir dildir.

 

 

 

Form. Nesnesi

 

Bildiğimiz üzere günümüzde program görsel bir sayfanın üzerine yerleştiriliyor. Neyse Formumuz. Kendisine özelliği barındırdığı gibi bütün componentelerede ev sahipliği yapar.

 

File/ New / Application dan yeni bir proje oluşturduk bir adet forumumzda otomatikman geldi Formun üzerinde Form1 bir yazıyor hemen form aktifken F11 tuşuna basıyoruz ve object inspector geliyor burada forumumuza atin işlemleri görebiliyor Formun başlığından rengine üzende kullanılan yazı tiplerine kadar her şeyi görmek mümküm.

 

Capiton= Benim Forumum ‘yazın formun başlığında benim formum yazdığını göreceksiniz.

 

Color Yerinden regini değiştire bilirsiniz

 

Biraz İngilizce ile buradaki bütün değişiklikeleri kolayca yapabilirsiniz.

 

Simdi Formun Actionlarına bakalım

 

Child ve midi formlar

En güzel örnek olarak Excel verebiliriz. Excel ana tablosu aldınta açtığınız diğer Excel formları onun çocukları gibi olacaktır ve ondan alta ayrılmayacaktir.

 

Bu konuya ilerde daha fazla değineceğiz

 

OnShow

Bu action olayında yani forum her ekranda göründüğündeki bunu su sekilde bir kodla yapabiliriz.

 

Form1.show; (gösterir)

Form1.close; (kapatır)

 

Not close il form tamamen kapanmaz sadece size gözükmez Formun on close oleyina

Cafree yazmanız gerekmekteridir.

 

Simdi on show olduğunda ne yapmak istiyorsanız onu yaptırabilirsiniz mesela formun onshow olayıki bu pencere F11 bastığnızda gelen yada her zaman soltarafta gözüken pencerenin üstten ikinci sekmesinin alt kısımlarına doğrudur.

 

Söyle bir kod yazıyoruz hemen

 

Showmessage(‘Selam Ben Formum Beni Açtın’

 

Simdi bunun pek aklı başında olmayan bir form oluduğunu biliyoruz Burada kullanılma dikkat edersek Showmessage küçük ve zararsız basit bir okadarda kolay kullanıylı bir uyarı mesajıdır. Form açıldığında size Selam ben Formum Beni Açtın diyecek ve alt taki ok butonuna basınca kapanacaktır.

 

Kusura bakmayın iş ortamında ancak bu kadar yazabildim ama devamını getireceğim eğer istek olursa delphiyi sıfırdan anlatmaya çalışacağım Bu arada kimi arkadaşlar olabilir neden değişken filan anlatmadın diye onlara hiç girecek vaktim yok zaten herkesin aşağı yukarı bildiği bir programlama dilidir

formun animasyonlu açılması

interface

 

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls;

 

type

TForm1 = class(TForm)

Timer1: TTimer;

Timer2: TTimer;

procedure Timer1Timer(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure FormCreate(Sender: TObject);

procedure Timer2Timer(Sender: TObject);

procedure FormShow(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

PosXAkhir, PosYAkhir,

MarginAtas, MarginKiri, ke,

lebar, tinggi : integer;

LeftTopDef, WiHiDef : TPoint;

FullRgn, FullDasRgn : THandle;

buka, tutup : boolean;

public

{ Public declarations }

end;

 

var

Form1: TForm1;

 

implementation

 

{$R *.DFM}

 

procedure TForm1.Timer1Timer(Sender: TObject);

begin

inc(ke);

if ke > 7 then Application.Terminate;

Height := height - tinggi;

Width := width - lebar;

left := left + MarginKiri;

Top := Top + MarginAtas;

FullRgn := CreateRectRgn(0, 0, Width, Height);

FullDasRgn := CreateRectRgn(1, 1, Width-1, Height-1);

CombineRgn( FullRgn, FullRgn, FullDasRgn, RGN_DIFF );

SetWindowRgn(Handle, FullRgn, TRUE);

end;

 

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

var pt : TPoint;

begin

FullRgn := CreateRectRgn(0, 0, Width, Height);

FullDasRgn := CreateRectRgn(1, 1, Width-1, Height-1);

CombineRgn( FullRgn, FullRgn, FullDasRgn, RGN_DIFF );

SetWindowRgn(Handle, FullRgn, TRUE);

 

GetCursorPos(pt); //

PosXAkhir := pt.x; // Last position mouse pointer

PosYAkhir := pt.y; //

 

lebar := width div 12; //

tinggi := height div 12; //

MarginAtas := (PosYAkhir-Top) div 12; //

MarginKiri := (PosXAkhir-Left) div 12; //

 

ke := 0;

tutup := true;

ShowWindow(Application.handle,sw_hide); // hide flicker on taskbar and another

timer1.Enabled := true;

Application.Run; // Make Application run again then terminate with timer1

end;

 

procedure TForm1.FormCreate(Sender: TObject);

var pt : TPoint;

begin

GetCursorPos(pt); //

PosXAkhir := pt.x; // Last position mouse pointer

PosYAkhir := pt.y; //

 

LeftTopDef := Point(Left,Top); // Default Position

WiHiDef := Point(width,height); // Default Size

 

width := 3; //

height := 3; // Set Form position

left := PosXAkhir; //

top := PosYAkhir; //

 

ke := 0;

buka := true;

tutup := false;

 

FullRgn := CreateRectRgn(0, 0, Width, Height); //

FullDasRgn := CreateRectRgn(1, 1, Width-1, Height-1); // Hide Caption before Formshow

CombineRgn( FullRgn, FullRgn, FullDasRgn, RGN_DIFF ); //

SetWindowRgn(Handle, FullRgn, TRUE); //

end;

 

procedure TForm1.Timer2Timer(Sender: TObject);

begin

inc(ke);

if ke > 10 then

begin

left := LeftTopDef.x;

top := LEftTopDef.y;

width := WiHiDef.x;

height := WiHiDef.y;

FullRgn := CreateRectRgn(0, 0, Width, Height);

CombineRgn( FullRgn, FullRgn, FullRgn, RGN_COPY );

SetWindowRgn(Handle, FullRgn, TRUE);

timer2.Enabled := false;

FormShow(sender); exit;

end;

width := width + ((WiHiDef.x-width) div 15);

height := height + ((WiHiDef.y-height) div 15);

Top := Top - ((Top -LeftTopDef.Y) div 15);

Left := Left - ((Left-LeftTopDef.X) div 15);

 

FullRgn := CreateRectRgn(0, 0, Width, Height);

FullDasRgn := CreateRectRgn(1, 1, Width-1, Height-1);

CombineRgn( FullRgn, FullRgn, FullDasRgn, RGN_DIFF );

SetWindowRgn(Handle, FullRgn, TRUE);

end;

 

procedure TForm1.FormShow(Sender: TObject);

begin

if buka then

begin

showWindow(Application.handle,sw_hide);

buka := false;

timer2.Enabled := true; exit;

end;

if tutup then

begin

showWindow(Application.handle,sw_hide);

exit;

end;

showWindow(Application.handle,sw_shownormal); // make show icon on taskbar

end;

 

procedure TForm1.FormDestroy(Sender: TObject);

begin

DeleteObject(FullRgn); // Just free Object

DeleteObject(FullDasRgn); //

end;

 

end.

ProgressBar (component) çok güzel

 

 

interface

 

uses

Windows, Classes, Controls, Graphics, Messages, Types, Forms, Dialogs,

Math, SysUtils, ComCtrls;

 

type

TColorScheme = (csCustom, csDesert, csGrass, csSilver, csSky, csRose, csSun,

csHackers, csNight, csVelvet, csMetal, csViolet, csToxic);

TFillDirection = (fdHorizontal, fdVertical, fdDiagonal);

 

TXiProgressBar = class(TGraphicControl)

private

FColorBorder: TColor;

FBackColorFace: TColor;

FBackColorGrad: TColor;

FForeColorFace: TColor;

FForeColorGrad: TColor;

FOrientation: TProgressBarOrientation;

FColorScheme: TColorScheme;

FPosition: Integer;

FMin: Integer;

FMax: Integer;

FStep: Integer;

procedure SetColors(Index: Integer; Value: TColor);

procedure SetPosition(Value: Integer);

procedure SetMin(Value: Integer);

procedure SetMax(Value: Integer);

procedure SetStep(Value: Integer);

procedure SetColorScheme(Value: TColorScheme);

procedure SetOrientation(Value: TProgressBarOrientation);

procedure GradientFillRect(Canvas: TCanvas; Rect: TRect;

StartColor, EndColor: TColor; Direction: TFillDirection);

protected

procedure Paint; override;

public

constructor Create(AOwner: TComponent); override;

procedure StepIt;

published

property ColorBorder: TColor index 0 read FColorBorder write SetColors;

property BackColorFace: TColor index 10 read FBackColorFace write SetColors;

property BackColorGrad: TColor index 11 read FBackColorGrad write SetColors;

property ForeColorFace: TColor index 20 read FForeColorFace write SetColors;

property ForeColorGrad: TColor index 21 read FForeColorGrad write SetColors;

property ColorScheme: TColorScheme read FColorScheme write SetColorScheme;

property Max: Integer read FMax write SetMax;

property Min: Integer read FMin write SetMin;

property Position: Integer read FPosition write SetPosition;

property Step: Integer read FStep write SetStep;

property Orientation: TProgressBarOrientation read FOrientation write SetOrientation;

property Align;

property Anchors;

property Constraints;

property Cursor;

property DragCursor;

property DragKind;

property DragMode;

property Enabled;

property HelpContext;

property HelpKeyword;

property Hint;

property ShowHint;

property Visible;

property OnContextPopup;

property OnDragDrop;

property OnDragOver;

property OnEndDock;

property OnEndDrag;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDock;

property OnStartDrag;

property PopupMenu;

property OnClick;

end;

 

procedure Register;

 

 

 

implementation

 

procedure Register;

begin

RegisterComponents('Plus', [TXiProgressBar]);

end;

 

constructor TXiProgressBar.Create(AOwner: TComponent);

begin

inherited;

Width:= 200;

Height:= 16;

FMin:= 0;

FMax:= 100;

FStep:= 10;

FPosition:= 0;

FOrientation:= pbHorizontal;

ColorScheme:= csDesert;

end;

 

procedure TXiProgressBar.Paint;

var

ScrBmp: TBitmap;

Pos: Integer;

begin

if not Visible then Exit;

 

ScrBmp:= TBitmap.Create;

ScrBmp.Width:= ClientWidth;

ScrBmp.Height:= ClientHeight;

 

case FOrientation of

pbHorizontal: begin

Pos:= Round((ScrBmp.Width -2) * (FPosition-FMin) / (FMax-FMin));

 

GradientFillRect(ScrBmp.Canvas,

Rect(1, 1, ScrBmp.Width -1, ScrBmp.Height -1),

FBackColorFace, FBackColorGrad, fdVertical);

 

GradientFillRect(ScrBmp.Canvas,

Rect(0, 0, Pos, ScrBmp.Height),

FForeColorFace, FForeColorGrad, fdVertical);

 

ScrBmp.Canvas.Pen.Color:= ScrBmp.Canvas.Pixels[1, 1];

ScrBmp.Canvas.MoveTo(1, 1);

ScrBmp.Canvas.LineTo(1, Height);

ScrBmp.Canvas.Pen.Color:= ScrBmp.Canvas.Pixels[2, Height-2];

ScrBmp.Canvas.MoveTo(Pos, 1);

ScrBmp.Canvas.LineTo(Pos, Height);

end;

pbVertical: begin

Pos:= ScrBmp.Height-Round((ScrBmp.Height-2) * (FPosition - FMin) / abs(FMax-FMin)+1);

 

GradientFillRect(ScrBmp.Canvas,

Rect(1, 1, ScrBmp.Width -1, ScrBmp.Height),

FBackColorFace, FBackColorGrad, fdHorizontal);

 

GradientFillRect(ScrBmp.Canvas,

Rect(0, Pos, ScrBmp.Width, ScrBmp.Height),

FForeColorFace, FForeColorGrad, fdHorizontal);

 

ScrBmp.Canvas.Pen.Color:= ScrBmp.Canvas.Pixels[2, Height-2];

ScrBmp.Canvas.MoveTo(1, ScrBmp.Height-2);

ScrBmp.Canvas.LineTo(ScrBmp.Width, ScrBmp.Height-2);

ScrBmp.Canvas.Pen.Color:= ScrBmp.Canvas.Pixels[Width-3, Height-3];

ScrBmp.Canvas.MoveTo(1, Pos);

ScrBmp.Canvas.LineTo(ScrBmp.Width, Pos);

end;

end;

 

 

ScrBmp.Canvas.Pen.Color:= FColorBorder;

ScrBmp.Canvas.Brush.Style:= bsClear;

ScrBmp.Canvas.Rectangle(0, 0, ScrBmp.Width, ScrBmp.Height);

 

case FOrientation of

pbHorizontal: Canvas.Draw(0, 0, ScrBmp);

pbVertical: begin

// Rotate the image;

Canvas.Draw(0, 0, ScrBmp);

end;

end;

ScrBmp.Free;

end;

 

procedure TXiProgressBar.SetColors(Index: Integer; Value: TColor);

begin

case Index of

0: FColorBorder:= Value;

10: FBackColorFace:= Value;

11: FBackColorGrad:= Value;

20: FForeColorFace:= Value;

21: FForeColorGrad:= Value;

end;

FColorScheme:= csCustom;

invalidate;

end;

 

procedure TXiProgressBar.StepIt;

begin

Inc(FPosition, FStep);

Paint;

end;

 

procedure TXiProgressBar.SetPosition(Value: Integer);

begin

if Value < FMin then Exit;

FPosition:= Value;

Paint;

end;

 

procedure TXiProgressBar.SetMin(Value: Integer);

begin

if Value > FMax then Exit;

FMin:= Value;

Paint;

end;

 

procedure TXiProgressBar.SetMax(Value: Integer);

begin

if Value < FMin then Exit;

FMax:= Value;

Paint;

end;

 

procedure TXiProgressBar.SetStep(Value: Integer);

begin

FStep:= Value;

Paint;

end;

 

procedure TXiProgressBar.SetOrientation(Value: TProgressBarOrientation);

begin

FOrientation:= Value;

Invalidate;

end;

 

procedure TXiProgressBar.SetColorScheme(Value: TColorScheme);

begin

FColorScheme:= Value;

case FColorScheme of

csDesert: begin

FColorBorder:= $00005680;

FBackColorFace:= $00C6ECFF;

FBackColorGrad:= clWhite;

FForeColorFace:= $009BDEFF;

FForeColorGrad:= $00007BB7;

end;

csGrass: begin

FColorBorder:= $00156F37;

FBackColorFace:= $00CBF5DC;

FBackColorGrad:= clWhite;

FForeColorFace:= $00C9F5DB;

FForeColorGrad:= $0028C162;

end;

csRose: begin

FColorBorder:= $0000009D;

FBackColorFace:= $00D7D7FF;

FBackColorGrad:= clWhite;

FForeColorFace:= $00E8E8FF;

FForeColorGrad:= $008080FF;

end;

csSilver: begin

FColorBorder:= $006B6B6B;

FBackColorFace:= $00E0E0E0;

FBackColorGrad:= clWhite;

FForeColorFace:= $00F0F0F0;

FForeColorGrad:= $00ADADAD;

end;

csSky: begin

FColorBorder:= $00B35900;

FBackColorFace:= $00FFEAD5;

FBackColorGrad:= clWhite;

FForeColorFace:= $00FFEEDD;

FForeColorGrad:= $00FFAE5E;

end;

csSun: begin

FColorBorder:= $00006464;

FBackColorFace:= $00CEFFFF;

FBackColorGrad:= clWhite;

FForeColorFace:= $00DFFFFF;

FForeColorGrad:= $0005BCDC;

end;

 

csHackers: begin

FColorBorder:= clBlack;

FBackColorFace:= $00005500;

FBackColorGrad:= clGreen;

FForeColorFace:= $0091ECAE;

FForeColorGrad:= $0000AA00;

end;

csNight: begin

FColorBorder:= clBlack;

FBackColorFace:= $00804000;

FBackColorGrad:= $00A85400;

FForeColorFace:= $00FFCB97;

FForeColorGrad:= $00EC7600;

end;

csVelvet: begin

FColorBorder:= clBlack;

FBackColorFace:= $00000059;

FBackColorGrad:= $0046468C;

FForeColorFace:= $009F9FF2;

FForeColorGrad:= $004848BB;

end;

csMetal: begin

FColorBorder:= clBlack;

FBackColorFace:= $00464646;

FBackColorGrad:= $006F6F6F;

FForeColorFace:= $00CECECE;

FForeColorGrad:= $00737373;

end;

csViolet: begin

FColorBorder:= clBlack;

FBackColorFace:= $00800040;

FBackColorGrad:= $00CA0065;

FForeColorFace:= $00FFB7DB;

FForeColorGrad:= $00FF3399;

end;

csToxic: begin

FColorBorder:= clBlack;

FBackColorFace:= $002C5656;

FBackColorGrad:= $003E7B7B;

FForeColorFace:= $00BCDEDE;

FForeColorGrad:= $00468E8E;

end;

end;

invalidate;

end;

 

procedure TXiProgressBar.GradientFillRect(Canvas: TCanvas; Rect: TRect;

StartColor, EndColor: TColor; Direction: TFillDirection);

var

Steps: Integer;

StartR, StartG, StartB, EndR, EndG, EndB: Byte;

CrrR, CrrG, CrrB: Double;

IncR, IncG, incB: Double;

i: integer;

begin

case Direction of

fdVertical: Steps:= Rect.Bottom - Rect.Top;

fdHorizontal: Steps:= Rect.Right - Rect.Left;

fdDiagonal: Steps:= Rect.Bottom - Rect.Top + Rect.Right - Rect.Left;

end;

 

StartR:= GetRValue(StartColor); EndR:= GetRValue(EndColor);

StartG:= GetGValue(StartColor); EndG:= GetGValue(EndColor);

StartB:= GetBValue(StartColor); EndB:= GetBValue(EndColor);

 

IncR:= (EndR - StartR) / steps;

IncG:= (EndG - StartG) / steps;

IncB:= (EndB - StartB) / steps;

 

CrrR:= StartR;

CrrG:= StartG;

CrrB:= StartB;

 

for i:= 0 to Steps do begin

Canvas.Pen.Color:= RGB(Round(CrrR), Round(CrrG), Round(CrrB));

case Direction of

fdVertical: begin

Canvas.MoveTo(Rect.Left, i);

Canvas.LineTo(Rect.Right + Rect.Left, i);

end;

fdHorizontal: begin

Canvas.MoveTo(i, Rect.Top);

Canvas.LineTo(i, Rect.Top + Rect.Bottom);

end;

fdDiagonal: begin

Canvas.MoveTo(i, Rect.Top);

Canvas.LineTo(Rect.Left, i);

end;

end;

CrrR:= CrrR + IncR;

CrrG:= CrrG + IncG;

CrrB:= CrrB + IncB;

end;

end;

 

end[/b]

heceleme(very hoş)

 

interface

 

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ALScrollingText;

 

type

TForm1 = class(TForm)

Memo1: TMemo;

Memo2: TMemo;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

function sesli(harf:string):boolean;

public

{ Public declarations }

end;

 

var

Form1: TForm1;

 

implementation

{$R *.dfm}

 

function tform1.sesli(harf:string):boolean;

begin

 

result:=false;

 

if harf='a'then result:=true;

if harf='e'then result:=true;

if harf='ı'then result:=true;

if harf='i'then result:=true;

if harf='o'then result:=true;

if harf='ö'then result:=true;

if harf='u'then result:=true;

if harf='ü'then result:=true;

 

if harf='A'then result:=true;

if harf='E'then result:=true;

if harf='I'then result:=true;

if harf='İ'then result:=true;

if harf='O'then result:=true;

if harf='Ö'then result:=true;

if harf='U'then result:=true;

if harf='Ü'then result:=true;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

var

i:integer;

begin

Memo2.Text := EmptyStr;

for i := 1 to length(Memo1.Text) do

begin

if//if 1

not sesli(copy(Memo1.Text,i,1))

and sesli(copy(Memo1.Text,i+1,1))

and not (copy(Memo1.Text,i,1)=' ')

and not (copy(Memo1.Text,i-1,1)=' ')

and not (copy(Memo1.Text,i+1,1)=' ')

then

begin

Memo2.text := Memo2.text+'-';

end;//if 1

if sesli(copy(memo1.Text,i,1))

and sesli(copy(memo1.Text,i-1,1))

then

begin

Memo2.text := Memo2.text+'-';

end;//if

Memo2.Text := Memo2.Text + copy(Memo1.Text,i,1);

end;//for

 

if copy(Memo2.Text,1,1) = '-' then

begin

Memo2.Text := copy(Memo2.Text,2,length(Memo2.text)-1);

end;

end;

 

end.

//bbeb

Handle list Show/Hide

 

interface

 

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

 

type

EnumWindowsProc = function (Hwnd : THandle;Param:Pointer):Boolean;stdcall;

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

Button4: TButton;

ComboBox1: TComboBox;

Label1: TLabel;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure Button4Click(Sender: TObject);

 

private

{ Private declarations }

public

{ Public declarations }

end;

 

var

Form1: TForm1;

 

implementation

 

{$R *.dfm}

function GetTitle(Hwnd : THandle;Param:Pointer):Boolean;stdcall;

var

Text : string;

begin

SetLength(Text,100);

GetWindowText(Hwnd,Pchar(Text),100);

Form1.ComboBox1.Items.Add(Text);

GetTitle := True;

Form1.Label1.Caption := IntToStr(Form1.ComboBox1.Items.Count);

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

Windows.ShowWindow(FindWindow(nil,PChar(ComboBox1. Text)),SW_SHOW);

end;

 

procedure TForm1.Button2Click(Sender: TObject);

begin

Windows.ShowWindow(FindWindow(nil,PChar(ComboBox1. Text)),SW_HIDE);

end;

 

procedure TForm1.Button3Click(Sender: TObject);

begin

Close;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

var

WindowProc : EnumWindowsProc;

begin

ComboBox1.Items.Clear;

WindowProc := GetTitle;

EnumWindows(@WindowProc,0);

end;

 

procedure TForm1.Button4Click(Sender: TObject);

var

WindowProc : EnumWindowsProc;

begin

ComboBox1.Items.Clear;

WindowProc := GetTitle;

EnumWindows(@WindowProc,0);

end;

 

end.

Sisteminiz beep'lemesin

 

 

{burada system beep'ini kapatıyoruz via speakerdan(kasa speakerı) gelen sesi değil sakın karıştırmayın }

 

// Disable System beep:

procedure TForm1.Button1Click(Sender: TObject);

begin

SystemParametersInfo(SPI_SETBEEP, 0, nil, SPIF_SENDWININICHANGE);

end;

 

 

// Enable System beep:

procedure TForm1.Button2Click(Sender: TObject);

begin

SystemParametersInfo(SPI_SETBEEP, 1, nil, SPIF_SENDWININICHANGE);

end;

 

 

//test (aktif ve deaktif edip beepletin)

procedure TForm1.Button2Click(Sender: TObject);

begin

Beep;

end;

Via speaker melodi çaldırma

 

{Flashback:aklıma geldide aynı method ile okulda i8085 işlemcisine direkt belirli frekans aralıkları

göndererek böyle bişi yapmiştık daha doğrusu bir org üstelik asm ile ne kadar debelenmiştik}

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;

 

function GetPort(address: Word): Word;

var

bValue: Byte;

begin

asm

mov dx, address

in al, dx

mov bValue, al

end;

GetPort := bValue;

end;

 

procedure Sound(aFreq, aDelay: Integer);

 

procedure DoSound(Freq: Word);

var

B: Byte;

begin

if Freq > 18 then

begin

Freq := Word(1193181 div Longint(Freq));

B := Byte(GetPort($61));

 

if (B and 3) = 0 then

begin

SetPort($61, Word(B or 3));

SetPort($43, $B6);

end;

 

SetPort($42, Freq);

SetPort($42, Freq shr ;

end;

end;

 

procedure Delay(MSecs: Integer);

var

FirstTickCount: LongInt;

begin

FirstTickCount := GetTickCount;

repeat

Sleep(1);

//or use Application.ProcessMessages instead of Sleep

until ((GetTickCount - FirstTickCount) >= Longint(MSecs));

end;

 

begin

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin

Windows.Beep(aFreq, aDelay);

end

else

begin

DoSound(aFreq);

Delay(aDelay);

end;

end;

 

procedure NoSound;

var

Value: Word;

begin

if not (Win32Platform = VER_PLATFORM_WIN32_NT) then

begin

Value := GetPort($61) and $FC;

SetPort($61, Value);

end;

end;

 

//test :nota sallama

procedure TForm1.Button1Click(Sender: TObject);

begin

Sound(500, 1000);

Sound(780, 1500);

Sound(750, 1060);

Sound(700, 1800);

Sound(900, 1900); {çok kötü bundan daha kötüsü olamaz}

NoSound;

end;

Ses çalma ve video oynatma (non media player(mediaplayer componenti kullanmadan))

 

procedure TForm1.Button1Click(...);

begin

MCISendString(PChar(' play ' + 'C:\test.mid'), nil, 0, 0);

end; {stop} {.wav}

{pause} {.mp3}

{.wma}

 

veya

 

procedure TForm1.Button1Click(...);

begin

PlaySound('C:\test.wav', 0, SND_FILENAME + SND_ASYNC);

end; {SND_LOOP } {SND_SYNC}

Wav. dosyasının kanal sayısı,bit'ini ve örnekleme kalitesini bulma

 

 

{wav dosyasının örnekleme kalitesi(khz cinsinden) bit sayısı bitrate ve ortalama saniyede geçen byte boyutu }

unit Unit1;

 

interface

 

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, MMSystem, StdCtrls;

 

type

TForm1 = class(TForm)

OpenDialog1: TOpenDialog;

Button1: TButton;

ListBox1: TListBox;

procedure Button1Click(Sender: TObject);

private

procedure OpenMedia(WaveFile : string);

function GetStatus(StatusRequested : DWord) : longint;

procedure CloseMedia;

 

public

{ Public declarations }

end;

 

var

Form1: TForm1;

MyError, dwFlags: Longint;

FDeviceID : Word;

implementation

 

{$R *.dfm}

procedure TForm1.OpenMedia(WaveFile: string);

var

MyOpenParms: TMCI_Open_Parms;

begin

with MyOpenParms do

begin

dwCallback := Handle; // TForm1.Handle

lpstrDeviceType := PChar('WaveAudio');

lpstrElementName := PChar(WaveFile);

end; {with MyOpenParms}

dwFlags := MCI_WAIT or MCI_OPEN_ELEMENT or MCI_OPEN_TYPE;

MyError := mciSendCommand(0, MCI_OPEN, dwFlags, Longint(@MyOpenParms));

// one could use mciSendCommand(DevId, here to specify a particular device

if MyError = 0 then

FDeviceID := MyOpenParms.wDeviceID

else

raise Exception.Create('Open Failed');

end;

 

function TForm1.GetStatus(StatusRequested: DWORD): Longint;

var

MyStatusParms: TMCI_Status_Parms;

begin

dwFlags := MCI_WAIT or MCI_STATUS_ITEM;

with MyStatusParms do

begin

dwCallback := Handle;

dwItem := StatusRequested;

end;

MyError := mciSendCommand(FDeviceID,

MCI_STATUS,

MCI_WAIT or MCI_STATUS_ITEM,

Longint(@MyStatusParms));

if MyError = 0 then

Result := MyStatusParms.dwReturn

else

raise Exception.Create('Status call to get status of ' +

IntToStr(StatusRequested) + ' Failed');

end;

 

procedure TForm1.CloseMedia;

var

MyGenParms: TMCI_Generic_Parms;

begin

if FDeviceID > 0 then

begin

dwFlags := 0;

MyGenParms.dwCallback := Handle; // TForm1.Handle

MyError := mciSendCommand(FDeviceID, MCI_CLOSE, dwFlags, Longint(@MyGenParms));

if MyError = 0 then

FDeviceID := 0

else

begin

raise Exception.Create('Close Failed');

end;

end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

OpenMedia(OpenDialog1.FileName);

with ListBox1.Items do

begin

Add('Average Bytes / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC) ));

Add('Bits / Sample : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_BITSPERSAMPLE)) );

Add('Samples / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_SAMPLESPERSEC)) );

Add('Channels : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_CHANNELS)));

end;

CloseMedia;

end;

end;

end.