Animated Bmp den istenilen resim parçasını almak

Animated Bmp den istenilen resim parçasını almak

KULLANIMI :

Genel Formu :

ResimAl(başlangıç,bitiş,yükseklik:Integer;DosyaAdı:String;)

Örnek:

var

dosya:String;

begin

dosya:=ExtractFilePath(Application.ExeName)+'anim1.bmp';

resimal(84,126,42,dosya);

end;

 

kullanılan resmi 24 bit olamalı

 

procedure Tform1.resimal(xbas,xson,y:Integer;FileName:String);

type

TRGBTripleArray=Array[0..32768] of TRGBTriple;

pTRGBTriple=^TRGBTripleArray;

 

var

boyx,i,j:Integer;

bmpsource,bmpdest:TBitmap;

row:pTRGBTriple;

TRGBMatrix:array of array of TRGBTriple;

begin

bmpsource:=TBitmap.Create;

bmpdest:=TBitmap.Create;

try

boyx:=xson-xbas;

SetLength(TRGBMatrix,y+1,boyx+1);

bmpsource.PixelFormat:=pf24bit;

bmpdest.PixelFormat:=pf24bit;

bmpsource.Transparent:=true;

bmpdest.Transparent:=true;

bmpdest.Width:=xson-xbas;

bmpdest.Height:=y;

//ShowMessage(IntToStr(bmpdest.Width)+'X'+IntTostr(bmpdest.Height));

bmpsource.LoadFromFile(FileName);

 

for j:=0 To bmpsource.Height -1 do //bmp yüksekliği

begin

    row:=bmpsource.ScanLine[j];

    for i:=0 to bmpsource.Width - 1 do // belirtilen saturları

    begin

    if (i >= xbas) and (i <= xson) then

       begin

        try

        TRGBMatrix[j,i-xbas]:=row[i];

        except

        on exception do

        exit;

        end;//try

        end;

 

    end;//for i

end;//for j

 

//------------//

 

form1.Canvas.Draw(0,0,bmpsource);

 

for j:=0 To bmpdest.Height-1 do

begin

row:=bmpdest.ScanLine[j];

  for i:=0 To bmpdest.Width-1 do

  row[i]:=TRGBMatrix[j,i];

end;

form1.Canvas.Draw(0,60,bmpdest);

 

finally

bmpsource.Free;

bmpdest.Free;

end;//try

end;

 

Delphi - .....................................

 

Kayıtların Refresh edilmesi

Kayıtların Refresh edilmesi

--------------------------------------------------------------------------------

Delphide table bileşeni ile yapılan kayıtların anında aktif olma özelliği çok kişinin en büyük derdi olmuştur. Aşagıdaki örneklerle bunu telafi etmenin yolları gösterilmiştir...

 

table1.open 'veritabanını aç

table1.refresh 'bilgiyi veritabanına yolla(kaydet)

table1.flushbuffer 'veriyi bellekten silerek güncelle

 

en önemlisi "flushbuffer" özelliğidir.

 

Diğer örnekler ise;

 

table1.applyupdate;

table1.commitupdate;

 

Delphi - .....................................

 

Zaman Sayacı

System tray a yerleşen ve zaman dolduğunda sizi uyaran ufak bir programcık.

unit zamansayaci;

 

interface

 

uses

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

  Dialogs, XPMan, Menus, ComCtrls, StdCtrls, Mask, ExtCtrls,shellapi;

 

type

  TForm1 = class(TForm)

    MaskEdit1: TMaskEdit;

    Edit1: TEdit;

    Timer1: TTimer;

    Button1: TButton;

    Label1: TLabel;

    Label2: TLabel;

    Button2: TButton;

    PopupMenu1: TPopupMenu;

    Gster1: TMenuItem;

    k1: TMenuItem;

    procedure Timer1Timer(Sender: TObject);

    procedure Button1Click(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,

      Y: Integer);

    procedure Button2Click(Sender: TObject);

    procedure Gster1Click(Sender: TObject);

    procedure k1Click(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

  stray:notifyicondata;

implementation

 

{$R *.dfm}

 

procedure TForm1.Timer1Timer(Sender: TObject);

begin

edit1.Text:=timetostr(now);

if edit1.Text=maskedit1.Text then

begin

form1.Show;

timer1.Enabled:=false;

showmessage('Zaman Doldu');

button1.SetFocus;

end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

timer1.Enabled:=true;

maskedit1.SetFocus;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

stray.cbSize:=sizeof(notifyicondata);

stray.Wnd:=form1.Handle;

stray.uID:=0;

stray.szTip:='Zaman Saati'#0;

stray.uCallbackMessage:=$200;

stray.uFlags:=7;

stray.hIcon:=application.Icon.Handle;

shell_notifyicon(0,@stray);

end;

 

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

  Y: Integer);

var

m:tpoint;

begin

getcursorpos(m);

if x=$203 then

begin

form1.Show;

end;

if x=$205 then

begin

popupmenu1.Popup(m.X,m.y);

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

form1.Hide;

end;

 

procedure TForm1.Gster1Click(Sender: TObject);

begin

form1.Show;

end;

 

procedure TForm1.k1Click(Sender: TObject);

begin

form1.Close;

end;

 

end.

 

Delphi - .....................................

 

Animate örneği

Formunuza  bir Animate bileşeni ekleyin ve CommonAVI özelliğine aviCopyFiles atayın ve sonra aşağıdaki kodu bir buttonun onclick olayına ekleyin

 

procedure TForm1.Button1Click(Sender: TObject);

begin

Animate1.Visible:=True;

Animate1.Active:=True;

Animate1.CommonAVI:=AviCopyFiles;

end;

 

end.

 

Delphi - .....................................

 

Mediaplayer da kalan süre

Parçanın kalan süresini bulma

//programa bir timer ve mediaplayer komponenti ekleyin

 

Procedure TForm1.Timer1Timer(Sender: TObject);

Var

Uzunluk,oankidurum,dakika,saniye: Integer;

begin

     //Seçilen parçanın uzunluğunu alır

uzunluk := Mediaplayer1.TrackLengthListBox1.ItemIndex];

      //Parçanın o anki durumunu alır

      oankidurum := Mediaplayer1.Position;

 

  //Dakikayı hesaplar

      Dakika := ((uzunluk-oankidurum) div 1000) Div 60;

 

      //Saniyeleri hesaplar

      Saniye := ((uzunluk -oankidurum) Div 1000) Mod 60;

 

      //Saniyeler 10'dan küçükse sıfır ekler

      If Saniye < 10 Then

      Label2.Caption := '0' + IntToStr(saniye)

      Else

      Label2.Caption := IntToStr(saniye);

 

      //Dakikalar

      Label1.Caption := IntToStr(dakika);

 

End;

 

Delphi - .....................................

 

Bilgisayarı kapat

Bilgisayarınızı ayarlanan saatte kapatmaya yarayan kodlar aşağıdadır. Yararlı olacağını umarım.

unit Unit1;

 

interface

 

uses

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

  Dialogs, StdCtrls, ExtCtrls, Buttons, ComCtrls,ShellApi, XPMan, Menus;

 

type

  TForm1 = class(TForm)

    kapat: TDateTimePicker;

    BitBtn1: TBitBtn;

    Timer1: TTimer;

    Label1: TLabel;

    BitBtn2: TBitBtn;

    XPManifest1: TXPManifest;

    PopupMenu1: TPopupMenu;

    ProgramGster1: TMenuItem;

    Kapat1: TMenuItem;

    Label2: TLabel;

    Timer2: TTimer;

    procedure Timer1Timer(Sender: TObject);

    procedure BitBtn1Click(Sender: TObject);

    procedure BitBtn2Click(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure Kapat1Click(Sender: TObject);

    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,

      Y: Integer);

    procedure ProgramGster1Click(Sender: TObject);

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

    procedure Timer2Timer(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

  stray:NOTIFYICONDATA;

implementation

 

{$R *.dfm}

function cikis(flag : word): Boolean;

var veri      : TOSVersionInfo;

    hToken  : THandle;

    tp      : TTokenPrivileges;

    h       : DWord;

begin

  result := false;

  veri.dwOSVersionInfoSize:=SizeOf(veri);

  GetVersionEx(veri);

  if veri.dwPlatformId = VER_PLATFORM_WIN32_NT then // Windows NT

  begin

      OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES,hToken);

    LookupPrivilegeValue(nil,'SeShutdownPrivilege',tp.Privileges[0].Luid);

    tp.PrivilegeCount := 1;

    tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

    h := 0;

    AdjustTokenPrivileges(hToken,False,tp,0,PTokenPrivileges(nil)^,h);

    CloseHandle(hToken);

    result := ExitWindowsEx(flag,0);

    Application.Terminate;

  end

  else

    begin

    Result := ExitWindowsEx(flag,0);

    Application.Terminate;

  end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);

VAR

KAL:STRING;

begin

bitbtn1.Visible:=false;

bitbtn2.Visible:=true;

if timetostr(kapat.Time)=timetostr(time) then begin

cikis(1);

end;

form1.Hint:=timetostr(kapat.Time-time)+' kaldı';

end;

 

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

timer1.Interval:=1000;

end;

 

procedure TForm1.BitBtn2Click(Sender: TObject);

begin

timer1.Interval:=0;

bitbtn1.Visible:=true;

bitbtn2.Visible:=false;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

kapat.Time:=time;

ZeroMemory(0, 0);

CreateMutex(nil,FALSE,'PROGRAMADI');

if GetLastError = ERROR_ALREADY_EXISTS then

begin

  ShowMessage('Program Zaten Çalışıyor. Program Kapatılacak!');

  Halt(0);

end;

//SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);

  with stray do

  begin

    cbsize:=sizeof(stray);

    wnd:=form1.handle;

    hicon:=Application.icon.Handle;

    uID:=0;

    sztip:=' kaldı';

    uflags:=7;

    uCallBackMessage:=$200;//icon üzerine tıklama kontrolu için

  end;

     Shell_NotifyIcon(0,@stray);

end;

 

procedure TForm1.Kapat1Click(Sender: TObject);

begin

halt(0);

end;

 

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

  Y: Integer);

var nokta:TPoint;

begin

  getCursorPos(nokta);

  if (x=$205) then PopupMenu1.Popup(nokta.x,nokta.y);

  if (x=$203) then BEGIN

  IF FORM1.ACTIVE=FALSE THEN BEGIN FORM1.Show; END

ELSE BEGIN FORM1.Hide; END;END;

  end;

 

procedure TForm1.ProgramGster1Click(Sender: TObject);

begin

IF FORM1.ACTIVE=FALSE THEN BEGIN FORM1.Show; END

ELSE BEGIN FORM1.Hide; END;

end;

 

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

begin

action:=canone;

form1.Hide;

end;

 

procedure TForm1.Timer2Timer(Sender: TObject);

begin

label2.Caption:=timetostr(time);

end;

 

end.

 

Delphi - .....................................

 

Dogum günü

dogum gününü bulan delphi örnegi biraz basit ama kullanışlı

unit Unit1;

 

interface

 

uses

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

  Dialogs, StdCtrls;

 

type

  TForm1 = class(TForm)

    Label1: TLabel;

    Button1: TButton;

    procedure Button1Click(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

 

implementation

 

{$R *.dfm}

 

procedure TForm1.Button1Click(Sender: TObject);

begin

case dayofweek(strtodate(inputbox('gg.aa.yyyy','dogum tarihiniz? gg.aa.yyyy',"))) of

1:label1.Caption:='pazar';

2:label1.Caption:='pazartesi';

3:label1.Caption:='salı';

4:label1.Caption:='çarşamba';

5:label1.Caption:='perşembe';

6:label1.Caption:='cuma';

7:label1.Caption:='cumartesi';

end;

  label1.Caption :=label1.Caption  + ' '+'günü dogmuşsunuz';

 

 

end;

 

end.

 

Delphi - .....................................

 

Sifreleme Desifreleme

Basit bir sifreleme algoritması

 

function sifrele1(SifrelenecekKatar: WideString):WideString;

var

SifrelenecekKarakter : Widestring;

sira                 : Integer;

SifreliKatar         : WideString;

begin

sifreliKatar:=";

for sira:=length(SifrelenecekKatar) downto 1 do begin

    SifrelenecekKarakter := UNICODEMidStr(SifrelenecekKatar,sira,1);

    SifreliKatar         := SifreliKatar + SifrelenecekKarakter;

    end;

    Result := sifreliKatar;

end;

 

function desifrele1(deSifrelenecekKatar: WideString):WideString;

var

deSifrelenecekKarakter : Widestring;

sira                   : Integer;

deSifreliKatar         : WideString;

begin

deSifreliKatar:=";

for sira:=length(deSifrelenecekKatar) to 1 do begin

    deSifrelenecekKarakter := UNICODEMidStr(deSifrelenecekKatar,sira,1);

    deSifreliKatar         := deSifreliKatar + deSifrelenecekKarakter;

    end;

    Result := deSifreliKatar;

end;

 

Delphi - .....................................

 

String Grid alana veri okumak text dosyasından

Text Dosyadan String Grid e veri okumak

--------------------------------------------------------------------------------

Sütun ayracı kullanılarak oluşturulmuş veya excelden export edilmiş

dosyaların içeriklerini okumak ve string gride yazmak için örnek

Text Dosyadan String Grid alana veri okumak

--------------------------------------------------------------------------------

 

Bildiğimiz basit yapıdaki, herhangi bir sütun ayracı ile (tab, virgül, noktalı virgül) ile ayrılmış bir metin dosyasından bu verileri String Grid bir alana okumak ve işlemek nasıl olur?

 

Procedure DosyayiGrideOku ( DOSYAADI : TFileName, DosyaAyraci : Char, Grid : TstringGrid );

var

i : Integer;

s : String;

t : String;

Kolon, satir : Integer;

String_Zinciri : TStringList;

KolonSayisi : Integer;

SatirSayisi : Integer;

AyracYeri : Integer;

BaslangicNoktasi : Integer;

BaslangicKolonu : Integer;

 

Begin

// Listemizi taşıyan yapıyı yaratıyoruz

String_Zinciri := TstringList.create;

try

//Verilerimizi dosyadan Listemize alalım

String_Zinciri.LoadFromFile(DosyaAdi);

 

//Kaç satır veri okuduğumuzu öğrenelim ve bunu Gridin tanımlanmış satır sayısı ile toplayalım

SatirSayisi := String_Zinciri.Count + Grid.FixedRows;

 

// Sıra Geldi Kolon sayımıza

T := String_Zinciri[0];

For i := 0 to Length(T) -1 do

Inc(KolonSayisi, Ord ( IsDelimiteer ( DosyaAyraci, T, i) ) );

Inc (KolonSayisi, 1 + Grid.FixedCols);

 

// Gridin boyutlarını kontrol edip düzenleyelim

if SatirSayisi > Grid.RowCount then Grid.RowCount := SatirSayisi;

if KolonSayisi > Grid.ColCount then Grid.ColCount := KolonSayisi;

 

BaslangicKolonu := Grid.FixedCol - 1;

Satir := Grid.FixedRows - 1 ;

 

// yavaş yavaş verileri atalım

for i := 0 to String_Zinciri.Count -1 do begin

Kolon := BaslangicKolonu;

Inc (Satir);

BaslangicNoktasi := 1;

S := String_Zinciri [i] ;

AyracYeri := Pos(FieldSeparator, S );

Repeat

inc(Kolon);

Grid.Cells[Kolon,Satir] := Copy (S,BaslangicNoktasi, AyracYeri -1);

S := Copy (S, AyracYeri+1 , 999);

AyracYeri := Pos(FieldSeparator, S);

Until AyracYeri = 0;

end; // for döngüsü için end

 

finally

String_Zinciri.Free;

end;

 

End;

 

 

Böylece elimizde sanırım işe yarar bir şey oluştu. Şimdi bunu nasıl kullanacağımıza gelelim.

Tabiki bunu nasıl kullanacağınızı biliyorsunuzdur ben sadece bütünlük bozulmasın ve konu akıcı olmuş görünsün diye bunu yazıyorum :)

 

DosyayiGrideOku ("C:Veri.txt", #9, StringGrid1);

 

Delphi - .....................................

 

Mp3 oynatma programı

güzel bir mp3 oynatma programı

--------------------------------------------------------------------------------

 

unit Unit1;

 

interface

 

uses

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

  Dialogs, MPlayer, ExtCtrls, ComCtrls, StdCtrls, FileCtrl, XPMan;

 

type

  TForm1 = class(TForm)

    DriveComboBox1: TDriveComboBox;

    DirectoryListBox1: TDirectoryListBox;

    FileListBox1: TFileListBox;

    Memo1: TMemo;

    ProgressBar1: TProgressBar;

    Timer1: TTimer;

    MediaPlayer1: TMediaPlayer;

    Label1: TLabel;

    XPManifest1: TXPManifest;

    procedure FormCreate(Sender: TObject);

    procedure Timer1Timer(Sender: TObject);

    procedure FileListBox1Click(Sender: TObject);

    procedure Label1Click(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

 

implementation

 

uses Unit2;

 

{$R *.dfm}

 

procedure TForm1.FormCreate(Sender: TObject);

begin

filelistbox1.Mask:='*.mp3';

memo1.Clear;

end;

 

procedure TForm1.Timer1Timer(Sender: TObject);

begin

if MediaPlayer1.Mode=mpPlaying  then

if ProgressBar1.Max=MediaPlayer1.Length then

ProgressBar1.Position:=MediaPlayer1.Position;

end;

procedure TForm1.FileListBox1Click(Sender: TObject);

var

dosya:TFileStream;

tag:array[0..2] of char;

title,artist,comment,album:array[0..29] of char;

yil:array[0..3] of char;

tur: byte;

begin

mediaplayer1.Close;

memo1.Clear;

dosya:=TFileStream.Create(FileListbox1.FileName, fmOpenRead);

try

dosya.Position:=dosya.Size-128;

dosya.Read(tag,3);

if tag='TAG' then

begin

dosya.Read(title,30);

memo1.lines.add('title:'+title);

dosya.read(artist,30);

memo1.Lines.add('sanatçı:'+artist);

dosya.Read(comment,30);

memo1.lines.add('açıklama:'+comment);

dosya.read(yil,4);

memo1.lines.add('yıl:'+yil);

dosya.Read(tur,1);

memo1.lines.add('tür:'+inttostr(tur));

end

else

begin

memo1.Text:='dosya bilgisi yok';

end;

finally

dosya.Free;

end;

with mediaplayer1 do begin

filename:=filelistbox1.filename;

open;

play;

progressbar1.Max:=mediaplayer1.Length;

end;

caption:=filelistbox1.FileName;

end;

 

procedure TForm1.Label1Click(Sender: TObject);

begin

form2.show;

end;

 

end.

 

Delphi - .....................................