Programlama yapalım ve Öğrenelim.

Programa Özel Kursör

Aşağıdaki kodu kullanarak programınızda kullandığınız kursör'leri değiştirebilirsiniz.

procedure TForm1.FormCreate(Sender: TObject);

const crMyCursor = 5; //Burdaki 5 değeri yerine mevcut kursör değerleriyle çakışmayacak herhangi bir değerde verilebilir

var Dosya:String;

begin

Dosya:=ExtractFileDir(Application.ExeName)+'Kursor';

Screen.Cursors[crMyCursor]:= LoadCursor(HInstance, Pchar(Dosya+'dinosaur.ani'));

Cursor := crMyCursor;

Screen.Cursors[crHourglass] := LoadCursorfROMfILE(Pchar(Dosya+'horse.ani'));

Screen.Cursors[crNone] := LoadCursorfROMfILE(Pchar(Dosya+'drum.ani'+#0));

Screen.Cursors[crDefault] := LoadCursorfROMfILE(Pchar(Dosya+'fillitup.ani'+#0));

Screen.Cursors[crSize] := LoadCursorfROMfILE(Pchar(Dosya+'hand.ani'+#0));

Screen.Cursors[crSizeNESW] := LoadCursorfROMfILE(Pchar(Dosya+'metronom.ani'+#0));

Screen.Cursors[crSizeNS] := LoadCursorfROMfILE(Pchar(Dosya+'3dgns.cur'+#0));

Screen.Cursors[crSizeNWSE] := LoadCursorfROMfILE(Pchar(Dosya+'dinosau2.ani'+#0));

Screen.Cursors[crSizeWE]:= LoadCursorfROMfILE(Pchar(Dosya+'banana.ani'+#0));

Screen.Cursors[crNoDrop]:= LoadCursorfROMfILE(Pchar(Dosya+'handNo.ani'+#0));

Screen.Cursors[crSQLWait]:= LoadCursorfROMfILE(Pchar(Dosya+'barber.ani'+#0));

Screen.Cursors[crDrag]:= LoadCursorfROMfILE(Pchar(Dosya+'Droppage.Cur'+#0));

end;

Programınızı kaydettiğiniz dizinin altına "Kursor" isimli bir dizin açmayı ve yukarıda adı

geçen ve uzantısı .ani veya .cur olan dosyaları bu dizinin altına kopyalamayı unutmayın.

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

StringGrid'i keşfedelim

StringGrid'i keşfedelim

Komponentsiz bir örnek neler yapılabileceğine dair Arşivimden

uses

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

Dialogs, StdCtrls, Grids, HusoEdit;

type

TForm1 = class(TForm)

StringGrid1: TStringGrid;

procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;

Rect: TRect; State: TGridDrawState);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure StringGridRotateTextOut(Grid: TStringGrid; ARow, ACol: Integer; Rect: TRect;

Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);

var

lf: TLogFont;

tf: TFont;

begin

if (Size > Grid.ColWidths[ACol] div 2) then

Size := Grid.ColWidths[ACol] div 2;

with Grid.Canvas do

begin

Font.Name := Schriftart;

Font.Size := Size;

Font.Color := Color;

tf := TFont.Create;

try

tf.Assign(Font);

GetObject(tf.Handle, SizeOf(lf), @lf);

lf.lfEscapement := 900;

lf.lfOrientation := 0;

tf.Handle := CreateFontIndirect(lf);

Font.Assign(tf);

finally

tf.Free;

end;

FillRect(Rect);

if Alignment = taLeftJustify then

TextRect(Rect, Rect.Left + 2,Rect.Bottom - 2,Grid.Cells[ACol, ARow]);

if Alignment = taCenter then

TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size +

Size div 3,Rect.Bottom - 2,Grid.Cells[ACol, ARow]);

if Alignment = taRightJustify then

TextRect(Rect, Rect.Right - Size - Size div 2 - 2,Rect.Bottom -

2,Grid.Cells[ACol, ARow]);

end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;

Rect: TRect; State: TGridDrawState);

begin

if ACol = 1 then

StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL',

12,clRed, taLeftJustify);

if ACol = 2 then

StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clBlue, taCenter);

if ACol > 2 then

StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12,clGreen,

taRightJustify);

end;

Yeri gelmişken sadece Tek bir hücrenin Font özelliklerini kullanmasını isterseniz.

OnDrawSell eventinde Fonksiyonumuzu

if (ACol = 2) and (ARow = 2) then

StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clBlue, taCenter);

Çağırmalıyız.

Hem satır hemde sutun numarasını veriyoruz.

Son olarak ilave etmek istediğim bir şey var Oda Hücrelere giriş yaparken Renk siyah olacaktır. Bunuda OnGetEditText eventinde

Uses kısmına StdCtrls Ekleyelim.

TEdit(StringGrid1.Controls[0]).Font.Color := ClRed;

Yazmamız yeterli olacak.

Gördü?ünüz Gibi Componentlik bir olay yok Ama isterseniz bu kadar bilgiden sonra Component yazabilirsiniz.

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

Harfe duyarlı aratma(filtreleme)

aratma

table kullanarak aratma(filtreleme)

1-öncelikle table ile kullanılacak database bağlantısını yapıyoruz

2-sorgulamanın yapılacağı alanın (harf girilecek edit olabilir )change olayına

table1.FilterOptions:=[focaseinsensitive];//aratmanın büyük küçük harf duyarlılığını aktif hale getirir

table1..Filter:='tablodakifiltrelenecek alan(örnek:firma_adi) ='+quotedstr(edit2.Text+'*'); // edit2 nin içine yazılan her harfe göre filtrelemeyi yapar

table1.Filtered:=true;// aratma(filtreleme) işlemini aktif hale getirir

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

Başka bir programdaki butonları Enable veya Disable yapın.

unit Unit1;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Label1: TLabel;

Edit1: TEdit;

Label2: TLabel;

Edit2: TEdit;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

var

FoundWindow: HWND;

hNotepadWindow: HWND;

begin

hNotepadWindow := FindWindow(nil, PChar(Edit1.Text));

FoundWindow := FindWindowEx(hNotepadWindow, 0, 'TButton', PChar(Edit2.Text));

EnableWindow(FoundWindow, FALSE);

end;

procedure TForm1.Button2Click(Sender: TObject);

var

FoundWindow: HWND;

hNotepadWindow: HWND;

begin

hNotepadWindow := FindWindow(nil, PChar(Edit1.Text));

FoundWindow := FindWindowEx(hNotepadWindow, 0, 'TButton', PChar(Edit2.Text));

EnableWindow(FoundWindow, TRUE);

end;

end.

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

delphi dosya gönderme

Delphi nmstrm nmstrmserv1 bileşenleri ile dosya gönderiyorum.

Nmstrm1.bytessent deyince ne kadar byte gönderilmiş görüyorum.

ama nmstrmserv1.BytesRecvd deyince 0 gözüküyor.nedendir sizce?

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

Treeview - Seçili itemi Renklendirme

Delphi Türk forumunda sormuştum bana lazım oluştu.

AjanX76 arkadaşımız da cevap yazmış sağ olsun.

Kod işimi gördü benim, belki başkasına da lazım olur diye buraya ekliyorum.

TreeView'in "OnCustomDrawItem" event'ını "TreeView1CustomDrawItem" yap,

Kodlar aşağıda :

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

type

TForm1 = class(TForm)

TreeView1: TTreeView;

Button1: TButton;

procedure TreeView1CustomDrawItem(Sender: TCustomTreeView;

Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);

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

procedure TForm1.TreeView1CustomDrawItem(Sender: TCustomTreeView;

Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);

begin

if (cdsSelected in State) AND (cdsFocused in State) then

TreeView1.Canvas.Brush.Color := clred

else

TreeView1.Canvas.Brush.color:= clWhite;

end;

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

Programlarınızda Lisans Modülü

Selam.

Bir arkadaşımız demiş sıkıntıdayım lisans ile ilgili olarak

Sadece bir öneri : kodbank'da "fakrika seri" diye arat.

hdd nin fabrika seri numarasını alırsın.

bir edite aktarırsın. bir algoritma ile onu şifrelersin

sonra aynı algoritma başka bir programda da olur.

Program müşteriye vermeniz gereken şifre kısmında o algoritmadan ürettiği

şifreyi verir. müşteri de o şifreyi sana söyler. sen de o algoritmadan

yeni şifre üretirsin. aynı şifreyi senin programın da üretir.

sen müşteriye şifreyi verirsin müşteri şifreyi girer ve kabul edildiğinde

lisanslanmış olur..

Çalışmalarında başarılar dilerim.

İskender UZUN

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

programıı maxzimize etmek ile ilgili cevap

programa ait formun Properties özelliğinin WindowsState özelliğini

wsMazimized yapıldığında olacaktır.

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

YARDIIIIIIIMMMMMMMMMMM

ARKADAŞLAR YAPTIGIM PROJEYI ÇALIŞTIRIYORUM FAKAT PROGRAMI KAPATINCA PROJECT İN SARI RENKLİ UYGULAMA DOYSAI ACILMIYO.LÜTFEN YARDIM EDİN.

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

TreeView - Grup,Alt Grup ve Eleman Ekleme

//Daha önceden aşağıya kopyala-yapıştırla ekleyeceğim kod verilmiş. Kodu gönderen

//arkadaşa teşekkürler.

//Treeview de bir SQL tablosuna göre ağaç yapısı oluşturma soruluyor.

//Kodu ekliyorum.

function GetTreeItems(ParentNodes: TTreeNodes; CheckName: String): TTreeNode;

var i: Integer; SCheckName: String;

begin

Result := nil;

SCheckName := AnsiUpperCase(CheckName);

for i := 0 to ParentNodes.Count - 1 do

begin

if AnsiUpperCase(ParentNodes[i].Text) = SCheckName then

begin

Result := ParentNodes[i];

Break;

end;

//Burada treeview e grup ve eleman ekleme nasıl yapılabilir gayet açık.

//Sanırım senin tablonda grup>altgrup>eleman şeklinde bir yapı var.

//kullanımı

//önce grup ekle, grup eklemek için lazım olan kod :

TreeView1.Items.AddChild(GetTreeItems(TreeView1.Items, ''), Grup_Adı);

//sonra alt grup ekle, alt grup eklemek için lazım olan kod

TreeView1.Items.AddChild(GetTreeItems(TreeView1.Items, 'Grup_Adı'), 'Alt_Grup_Adı');

//Son olarak da alt grubun altına bir eleman ekle

TreeView1.Items.AddChild(GetTreeItems(TreeView1.Items, 'Alt_Grup_Adı'), 'Elemanın_Adı');

//bu grup oluşturma ve alt grup oluşturma işini for i:=0 to query1.recordcount-1 do begin

//gibi döngülerle halletmelisin.

//yardımcı olabilmişsem ne mutlu bana!

//Çalışmalarında başarılar dilerim.

//Saygılarımla

//İskender UZUNOSMANOĞLU

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

Treeview

Herkese selam buraya mecbur kalmasam asla yardım için kod yazmazdım...

Öncelikle bu kabalığımdan dolayı özür dilerim... Lütfen yardım edin...

Sorunum şu: Aşağıdaki Kod yapısında SQL de bir datam var...

Nasıl bir Kod yazmalıyım ki : Aşağıdaki Treeview olarak listeleyebileyim...

İnşallah aranızda bu kabalığıma bakmadan bu sorunumu çözebilecek bir arkadaş vardır..

Bu Tablo yapısı

MAMUL HAMMADDE

MM1 YM1

MM1 YM2

YM1 HM1

YM1 HM2

YM2 HM3

Bu sistenilen Treeview Yapısı

MM1

|--YM1

| |--HM1

| |--HM2

|--YM2

|--HM3

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

Delphi 7 türkçe menü

Arkadaşlar isteyen olursa mail atsın delphi7'ye ait türkçe menü

dosyasını göndereyim

Menülerin büyük bölümü türkçeleştirilmiştir....

//mailto : ozcantemp@hotmail.com

21.59 4 Mayıs Cuma 2007 tarihi ile Delphi7 Türkçe Menü yama paketini buraya Ekliyorum iyi yada kötü yorumlarınızı Eklerseniz Askerden Geldiğimde Sizlerden gelen ilgiye Göre Bu çalışmalarıma devam edeceğim.. Hepinize Çalışmalarınızda Başarılar Dilerim....

Link-1

<OzelFormat Deger="Link:http://rapidshare.tc/4106869">Delphi7 Türkçe Menü İndirmek İçin Tıklayın</OzelFormat>

Link-2 Daima Çalışır...

<OzelFormat Deger="Link:http://mavikumsal.com/delphi/delphi7_TR_YAMA.rar">Delphi7 Türkçe Menü İndirmek_İçin Tıklayın</OzelFormat>

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

ADOConnection ile Tablo Kontrolü

TableExists fonksiyonu ile veritabanında tablonun var olup olmadığını kontrol etme hem delphi hem c++ builder kodu:

function TableExists(AADOConnection: TADOConnection; ATableName: string): boolean;

var

AStrings: TStringList;

begin

AStrings := TStringList.Create;

try

AADOConnection.GetTableNames(AStrings);

Result := AStrings.IndexOf(ATableName) <> -1;

finally

AStrings.Free;

end;

bool TableExists(TADOConnection AADOConnection,AnsiString ATableName)

{

TStringList *AStrings = new TStringList;

try {

AADOConnection.GetTableNames(AStrings);

return AStrings->IndexOf(ATableName) != -1;

}

__finally {

delete AStrings;

}

};

Kullanımı:

procedure TForm1.Button2Click(Sender: TObject);

begin

if TableExists(ADOConnection1;'stok_table') then

showmessage('tablo olusturlmus')

else

showmessage('tablo yok.olusturulsun mu????')

end;

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

tetris oyunun kodlarını bilen bi hayır sever yok mu çok lazım....hhhharon@hotmail.com

tetris oyun kodunu bilen varsa LÜTFEN göndersin

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

DBGrid To CSV

{Kendi programım için geliştirdiğim tablo dönüştürme kodu. Herhangi bir OLE bağlantsı yapmadığı için oldukça hızlı çalışır. 10000 tane kayıt ile denedim baya hızlı...neyse buyrun kodlar}

/////////////////////////////////////////////////////////////////

procedure TForm1.DBGridToCSV(dataset:TDataSet;dbg:TDBGrid);

var

f:textfile;

n,i:integer;

dosya:string;

satir,deger:ansistring;

begin

dosya:= SaveDialog1.FileName+'.csv';

AssignFile(f, dosya);

Rewrite(f);

ProgressBar1.Position:=0;

ProgressBar1.Maximum:=dataset.RecordCount;

for n:=0 to dbg.Columns.Count-1 do

begin

satir:=dbg.Columns.Items[n].Title.Caption;

deger:=deger+satir+';';

end;

writeln(f,deger);

deger:='';

i:=0;

dataset.DisableControls;

dataset.First;

while not dataset.Eof do

begin

Application.ProcessMessages;

for n:=0 to dbg.Columns.Count-1 do

begin

satir:=dbg.Fields[n].text;

deger:=deger+satir+';';

end;

writeln(f,deger);

deger:='';

Flush(f);

inc(i);

ProgressBar1.Position:=i;

Label2.Caption:='Çıkarılıyor... '+'['+inttostr(i)+'/'+IntToStr(dataset.RecordCount)+']';

dataset.Next;

end;

CloseFile(f);

dataset.EnableControls;

end;

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

Formu Panele Gömmek - Kasmaya Gerek Yok

// Arkadaşlar öncelikle belirteyim kodbanktaki kodları inceledim birşeyleri yapabilmek için

// o kadar kasmışlarki bunu göndermem gerektiğini düşündüm ayrıca kasmıyor

// Örnek olarak : 2 Form olsun ilk formdaki panele 2.formu gömüyoruz.

//Gerekenler

// 2tane form 1 tane panel 1 de düğme

// Form1 den yazıyoruz butonun click olayına

procedure Form1.Button1Onclik (Sender: TObject);

begin

//Form 2 create yapılmış olmalı ancak gösterilmeyecek

if FindComponent('TForm2') then

begin

Form2.Create();// tam olarak hatırlamıyorum delphi açık değil şuan

Form2.Parent := Form1.Panel1.Parent;

Form2.Show;

end;

// Böylece form 2 yi panel 1 e attık peki sistem menüsü ve buttonları ne oldu?

// Onuda panel e yada form2 de bir button oluşturup göster diyoruz o buttona tıklayınca form2.Close ediyor Form2.Close olayınada Form2.Destroy diyoruz.Böylece hatasız bir şekilde kapatıyor.

// Daha ilerisindede şöyle olur ben şahsen bu yöntemi kullanıyorum.

{ Form1 de bir menü olur ve kapat menüsüne tıklayınca Panel in içindeki formun adını alır ve o forma Close event ını gönderir.

}

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

Delphi ile Mp3 dosya çalmak (En kolay/yalın anlatım ile...)

unit Unit1;

interface

uses

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

Dialogs,MPlayer;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

Mp3Player: TMediaPlayer;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

var Mp3Dosyasi:string;

begin

Mp3Player:=TMediaplayer.CreateParented(Form1.Handle);//Mp3Player nesnesini türetiyoruz...

Mp3Dosyasi:='1.mp3';// buraya path(yolu) ile beraber çalmak istediğiniz mp3 dosyayı yazınız...

if not FileExists(Mp3Dosyasi) then begin ShowMessage('1.MP3 dosyası bulunamadı...');Halt;end;//Bu satırı kendinize göre düzeltin.

Mp3Player.Close;

Mp3Player.FileName:=Mp3Dosyasi;

Mp3Player.Open;

Show;//Formu göster

Mp3Player.play;// ve çalmaya başla ...

end;

end.

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

Döviz Kuru (Merkez Bankası)

Merkez Bankasindan Gunluk Doviz Kurlarini Alma

********************************************************

* [1 Adet IdHTTP Component] Indy Clients icerisinde *

* [2 Adet Label] Form uzerine ekleyin ve *

********************************************************

**********************************************************************

*'Daha Önce Verildiğini Biliyorum Ama Bunda EURO alıyor ve Labele *

*'aktarım yapıyor. *

*'ERKAN OKMAN *

*'erkanokman@hotmail.com Çok Teşekkür ediyorum *

**********************************************************************

procedure TForm1.FormCreate(Sender: TObject);

var

z,ze,s,se,alis,alise,satis,satise,aranan,aranan2:string;

yer,yere,i:Integer;

begin

s:=IDHttp1.Get('http://www.tcmb.gov.tr/kurlar/today.html');

z:=IDHttp1.Get('http://www.tcmb.gov.tr/kurlar/today.html');

se:=IDHttp1.Get('http://www.tcmb.gov.tr/kurlar/today.html');

ze:=IDHttp1.Get('http://www.tcmb.gov.tr/kurlar/today.html');

aranan:='1 ABD DOLARI';

aranan2:='1 EURO';

for i:=1 to 1 do

begin

yer:=pos(aranan,s);

yer:=pos(aranan,z);

yere:=pos(aranan2,se);

yere:=pos(aranan2,ze);

if yer=0 then

begin

ShowMessage('Kur bilgisi yok');

exit;

end

else

begin

yer:=yer+length(aranan);

yere:=yere+length(aranan2);

s:=copy(s,yer,length(s)-yer);

z:=copy(z,yer,length(s)-yer);

se:=copy(se,yere,length(se)-yere);

ze:=copy(ze,yere,length(se)-yere);

s:=trim(s);

z:=trim(z);

se:=trim(se);

ze:=trim(ze);

alis:=copy(s,1,9);

satis:=copy(z,14,9);

alise:=copy(se,1,10);

satise:=copy(ze,14,10);

label5.caption:= alis + 'YTL' ;

label7.caption:= satis + 'YTL' ;

label11.caption:= alise + 'YTL' ;

label9.caption:= satise + 'YTL' ;

end;

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

kendine güvenen programcı ?

merhaba arkadaşlar aranıza yeni katıldım yaklaşık 8 aydır bir programcı arıyorum umarım bu programcı burda çıkar kesinlikle parasal olarak bir sıkıntı yok yeterki istediğim oyunu ala bileyim

örnek olara www.hakkarim.net sitesindeki 101 oyunu yapmak istiyorum tabi kendi siteme göre bana yardımcı olacak programcı arkadaşları bekliyorum

tşk ederim

email: erekbilgisayar@hotmail.com

msn : erekbilgisayar@hotmail.com msn den irtibata geçseniz sevinirim

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

Program ı maximize yapmak

Arkadaşlar mesela bir program var. Bunu delphi ile bir kod la nasıl maximize ederim. Kendi programını değil. Delphi ile başka bir programın . Yani X.exe var delphi ile bir kod yazıcam bu x.exe maximize olcak.Bunu msn için kullanıcam.Yani bi program yapıcam çalıştığında msn messenger sağ alt köşeden maximize olcak. Yardımlarınızı bekliyorum

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

bmptopdf

unit bmp2pdf;

interface

uses

Windows,Classes, Graphics, SysUtils;

procedure BMPtoPDF(BMP:TBitmap;SaveName:String);

implementation

type

pRGBArray = ^TRGBArray;

TRGBArray = array[0..32768-1] of TRGBTriple;

procedure Write_CrossReferenceTable(AStream: TStream;PosArray : array of Dword;Count:Integer);

Var

i :Integer;

begin

With TStringStream(AStream) do

begin

WriteString('xref'#10);

WriteString(Format('0 %d'#10,[Count+1]));

WriteString('0000000000 65535 f '#10);

for i:= 0 to Count-1 do

begin

WriteString(Format('%0.10d',[PosArray[i]])+' 00000 n '#10);

end;

procedure Write_ContentsObject(AStream: TStream;Index : Dword; Width,Height : Integer);

Var

MemoryStream : TMemoryStream;

begin

MemoryStream:=TMemoryStream.Create;

Try

// Stream

With TStringStream(MemoryStream) do

begin

WriteString('q'#10);

WriteString(Format('%d 0 0 %d 0 0 cm'#10,[Width,Height]));

WriteString('/Im0 Do'#10);

WriteString('Q'#10);

end;

MemoryStream.Position:=0;

// Object

With TStringStream(AStream) do

begin

WriteString(Format('%d 0 obj'#10,[Index]));

WriteString(Format('<< /Length %d >>'#10,[MemoryStream.Size]));

WriteString('stream'#10);

AStream.CopyFrom(MemoryStream,MemoryStream.Size) ;

WriteString('endstream'#10);

WriteString('endobj'#10);

end;

finally

MemoryStream.Free;

end;

procedure GetBitmapData(AStream :TStream;BMP:TBitmap);

var

tmp :TBitmap;

Buffer : Pointer;

SrcRow,DestRow : pRGBArray;

Row,Col,DestCnt : Integer;

begin

DestCnt:=0;

tmp := TBitmap.Create;

tmp.Assign(BMP);

tmp.PixelFormat:=pf24bit;

GetMem(Buffer,tmp.Width*tmp.height*3);

DestRow :=Buffer;

try

for Row:=0 to tmp.Height-1 do

begin

SrcRow :=tmp.ScanLine[Row];

for Col:=0 to tmp.Width-1 do

begin

DestRow[DestCnt].rgbtBlue := SrcRow[Col].rgbtRed;

DestRow[DestCnt].rgbtGreen := SrcRow[Col].rgbtGreen;

DestRow[DestCnt].rgbtRed := SrcRow[Col].rgbtBlue;

Inc(DestCnt);

end;

AStream.Write(DestRow^,tmp.Width*tmp.Height*3);

finally

tmp.Free;

FreeMem(Buffer);

end;

procedure BMPtoPDF(BMP:TBitmap;SaveName:String);

Var

AStream,BitsData : TStream;

ObjectIndex : Integer;

ObjectPosArray : array [0..10] of Dword;

begin

if BMP=nil then

raise Exception.Create('Bitmap is nil');

if SaveName='' then

raise Exception.Create('SaveName is nil');

ObjectIndex :=0;

AStream :=TFileStream.Create(SaveName,fmCreate) ;

BitsData :=TMemorySTream.Create;

Try

GetBitmapData(BitsData,BMP);

BitsData.Position:=0;

// PDF version

TStringStream(AStream).WriteString('%PDF-1.2'#10);

// Catalog

ObjectPosArray[ObjectIndex] :=AStream.Position;

With TStringStream(AStream) do

begin

WriteString(Format('%d 0 obj'#10,[ObjectIndex+1]));

WriteString('<<'#10);

WriteString('/Type /Catalog'#10);

WriteString('/Pages 2 0 R'#10);

// View Option (100%)

WriteString('/OpenAction [3 0 R /XYZ -32768 -32768 1 ]'#10);

WriteString('>>'#10);

WriteString('endobj'#10);

end;

Inc(ObjectIndex);

// Parent Pages

ObjectPosArray[ObjectIndex] :=AStream.Position;

With TStringStream(AStream) do

begin

WriteString(Format('%d 0 obj'#10,[ObjectIndex+1]));

WriteString('<<'#10);

WriteString('/Type /Pages'#10);

WriteString('/Kids [ 3 0 R ]'#10);

WriteString('/Count 1'#10);

WriteString('>>'#10);

WriteString('endobj'#10);

end;

Inc(ObjectIndex);

// Kids Page

ObjectPosArray[ObjectIndex] :=AStream.Position;

With TStringStream(AStream) do

begin

WriteString(Format('%d 0 obj'#10,[ObjectIndex+1]));

WriteString('<<'#10);

WriteString('/Type /Page'#10);

WriteString('/Parent 2 0 R'#10);

WriteString('/Resources'#10);

WriteString('<<'#10);

WriteString('/XObject << /Im0 4 0 R >>'#10);

WriteString('/ProcSet [ /PDF /ImageC ]'#10);

WriteString('>>'#10);

WriteString(Format('/MediaBox [ 0 0 %d %d ]'#10, [BMP.Width,BMP.Height]));

WriteString('/Contents 5 0 R'#10);

WriteString('>>'#10);

WriteString('endobj'#10);

end;

Inc(ObjectIndex);

// XObject Resource

ObjectPosArray[ObjectIndex] :=AStream.Position;

With TStringStream(AStream) do

begin

WriteString(Format('%d 0 obj'#10,[ObjectIndex+1]));

WriteString('<<'#10);

WriteString('/Type /XObject'#10);

WriteString('/Subtype /Image'#10);

WriteString('/Name /Im0'#10);

WriteString(Format('/Width %d'#10,[BMP.Width]));

WriteString(Format('/Height %d'#10,[BMP.Height]));

WriteString('/BitsPerComponent 8'#10);

WriteString('/Filter []'#10);

WriteString('/ColorSpace /DeviceRGB'#10);

WriteString(Format('/Length %d >>'#10,[BitsData.Size]));

WriteString('stream'#10);

AStream.CopyFrom(BitsData,BitsData.Size);

WriteString('endstream'#10);

WriteString('endobj'#10);

end;

Inc(ObjectIndex);

// Contents Stream & Object

ObjectPosArray[ObjectIndex] :=AStream.Position;

With TStringStream(AStream) do

begin

Write_ContentsObject(AStream,ObjectIndex+1,BMP.Width,BMP.Height);

end;

Inc(ObjectIndex);

// CrossReferenceTable

ObjectPosArray[ObjectIndex] :=AStream.Position;

Write_CrossReferenceTable(AStream,ObjectPosArray,ObjectIndex);

// trailer

With TStringStream(AStream) do

begin

WriteString('trailer'#10);

WriteString('<<'#10);

WriteString(Format('/Size %d'#10,[ObjectIndex+1]));

WriteString('/Root 1 0 R'#10);

WriteString('>>'#10);

WriteString('startxref'#10);

WriteString(Format('%d'#10,[ObjectPosArray[ObjectIndex]]));

WriteString('%%EOF');

end;

finally

AStream.Free;

BitsData.Free;

end;

end.

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