Çok İşe Yarıyan Kodlar ..

Franticorpse

Sayiyi Turkce olarak yazan kod (159 = Yuzellidokuz vb.)

Katirilyona kadar olan sayilari
destekler.
}
const
BIRLER: array[0..9] of string=(", 'Bir', 'Iki', 'Üc', 'Dört', 'Bes', 'Alti',
'Yedi', 'Sekiz', 'Dokuz');
ONLAR : array[0..9] of string=(", 'On', 'Yirmi', 'Otuz', 'Kirk', 'Elli', 'Altmis',
'Yetmis', 'Seksen', 'Doksan');
DIGER : array[0..5] of string=(", 'Bin', 'Milyon', 'Milyar', 'Trilyon', 'Katrilyon');


function SmallNum(N: Integer): string;
var
S: string[3];
begin
Result := ";
S := IntToStr(N);
if (Length(S)=1) then
S := '00' + S
else if (Length(S)=2) then
S := '0' + S;
if S[1]<>'0' then
if S[1]<>'1' then
Result := BIRLER[StrToInt(S[1])] + 'Yüz'
else
Result := 'Yüz';
Result := Result + ONLAR[StrToInt(S[2])];
Result := Result + BIRLER[StrToInt(S[3])];
end;

function NumStr(Num: Currency): string;
var
i, j, n, Nm: Integer;
S, Sn: string;
begin
S := FormatFloat('0', Num);
Sn := ";
if Num = 0 then
Sn := 'Sifir'
else if Length(S) < 4 then
Sn := SmallNum(Round(Num))
else
begin
I := 1;
J := Length(S) mod 3;
if J=0 then
begin
J := 3;
N := Length(S) div 3 - 1;
end
else
N := Length(S) div 3;
while i<Length(S) do
begin
Nm := StrToInt(Copy(S, I, J));
if (Nm=1) and (N=1) then
begin
Nm := 0;
Sn := Sn + SmallNum(Nm) + Diger[N];
end;
if Nm<>0 then
Sn := Sn + SmallNum(Nm) + Diger[N];
I := I + J;
J := 3;
N := N - 1;
end;
end;
Result := Sn;
end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := NumStr(StrToCurr(Edit1.Text));
end;


******************************
Bir StringGrid colonu icine dgerin saga kaydirilarak yazilmasi


function sagaDaya(s: string;col: integer): string;
var
bosluk: string;
en: integer;
begin
bosluk := ' ';
en := StringGrid1.ColWidths[col] -
StringGrid1.Canvas.TextWidth(s);
while (en - 5) > SG1.Canvas.TextWidth(bosluk) do
bosluk := bosluk + ' ';
sagaDaya := bosluk + s;
end;


*******************************
DBGrid verilerini (TQUERY) Excel sayfasina aktarma


{Bu kod ornegi herhangi bir table'dan
Ad ve Soyad verilerini ceken TQuery verilerini,
Excelde yeni bir calisma sayfasi
acip icine yazar.}


{uses satirina comobj unitini ekleyin}

procedure TForm1.Button1Click(Sender: TObject);
var
v,sayfa:variant;{v excel prg, sayfa calisma sayfasi}
say,i:integer;
begin
query1.open;
say:=query1.recordcount;//query kayit sayisi
v:=createoleobject('excel.application');//exceli yarat
v.workbooks.add;//yeni calisma kitabini ekle
sayfa:=v.workbooks[1].worksheets[1];{Birinci calisma sayfasini sayfa degiskenine ata}
query1.first;
for i:=1 to say do
begin
sayfa.cells[i,1]:=query1ad.text;
sayfa.cells[i,2]:=query1soyad.text;
query1.next;
end;
v.visible:=true;//Exceli acip verileri goster
end;


***************************************
Bilinmeyen bir sql ile ne zaman Query1.Open, ne zaman Query1.ExecSql ?

{
Kullanicinin Gerek select, gerekse Update, Insert vb
komutlarini hatasiz calistirmak icin kullaniniz.
}

procedure TForm1.Button1Click(Sender: TObject);
begin
Query1.Close;
Query1.Sql.Text :=Memo1.Lines.Text;
try
Query1.Open;
except
on E: Exception do
if not (E is ENoResultSet) then // eger bunun disinda hata varsa
raise;
end;
end;


***********************
FORMLAR ICIN HOS BIR CAPTION EFEKTI

FORMUNUZA BIR TIMER NESNESI EKLEYIN. TIMER'IN INTERVAL DEGERINI 100 YA DA DAHA ASAGI BIR DEGER YAPIP ONTIMER
OLAYINI ASAGIDAKI GIBI DUZENLEYIN!
EGER BASLIGINIZA BOSLUK KARAKTERLERINI EKLERSENIZ DAHA HOS
OLUR : 'BASLIK ' GIBI}

procedure TForm1.Timer1Timer(Sender: TObject);
begin
CAPTION:=COPY(CAPTION,2,LENGTH(CAPTION)-1)+CAPTION[1];
end;

*************************
Databes'den StringGrid'e Aktarma

procedure TForm1.BitBtn1Click(Sender: TObject);
var
i,row:integer;
begin
Table1.OPEN;
Table1.First;
row := 0;
StringGrid1.RowCount:=Table1.RecordCount;
while not Table1.EOF do
begin
Kaynak: Wardom http://www.wardom.com.tr/showthread.php?t=124497
for i := 0 to Table1.FieldCount-1 do
StringGrid1.Cells[i,row] := Table1.Fields[i].AsString;

Inc (row);
Table1.Next;
end;
end;


***************************
Yuvarlak Form Olusturma

procedure TForm1.FormCreate(Sender: TObject);
var
region: HRgn;
begin
{ yuvarlak form olusturur }
region:=CreateEllipticRgn(1,1,200,200);
SetWindowRgn(handle, region, true);
end;

***************************
Key Kodlari

{ Virtual Keys, Standard Set }
VK_LBUTTON = 1;
VK_RBUTTON = 2;
VK_CANCEL = 3;
VK_MBUTTON = 4; { NOT contiguous with L & RBUTTON }
VK_BACK = 8;
VK_TAB = 9;
VK_CLEAR = 12;
VK_RETURN = 13;
VK_SHIFT = $10;
VK_CONTROL = 17;
VK_MENU = 18;
VK_PAUSE = 19;
VK_CAPITAL = 20;
VK_KANA = 21;
VK_HANGUL = 21;
VK_JUNJA = 23;
VK_FINAL = 24;
VK_HANJA = 25;
VK_KANJI = 25;
VK_CONVERT = 28;
VK_NONCONVERT = 29;
VK_ACCEPT = 30;
VK_MODECHANGE = 31;
VK_ESCAPE = 27;
VK_SPACE = $20;
VK_PRIOR = 33;
VK_NEXT = 34;
VK_END = 35;
VK_HOME = 36;
VK_LEFT = 37;
VK_UP = 38;
VK_RIGHT = 39;
VK_DOWN = 40;
VK_SELECT = 41;
VK_PRINT = 42;
VK_EXECUTE = 43;
VK_SNAPSHOT = 44;
VK_INSERT = 45;
VK_DELETE = 46;
VK_HELP = 47;
{ VK_0 thru VK_9 are the same as ASCII '0' thru '9' ($30 - $39) }
{ VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' ($41 - $5A) }
VK_LWIN = 91;
VK_RWIN = 92;
VK_APPS = 93;
VK_NUMPAD0 = 96;
VK_NUMPAD1 = 97;
VK_NUMPAD2 = 98;
VK_NUMPAD3 = 99;
VK_NUMPAD4 = 100;
VK_NUMPAD5 = 101;
VK_NUMPAD6 = 102;
VK_NUMPAD7 = 103;
VK_NUMPAD8 = 104;
VK_NUMPAD9 = 105;
VK_MULTIPLY = 106;
VK_ADD = 107;
VK_SEPARATOR = 108;
VK_SUBTRACT = 109;
VK_DECIMAL = 110;
VK_DIVIDE = 111;
VK_F1 = 112;
VK_F2 = 113;
VK_F3 = 114;
VK_F4 = 115;
VK_F5 = 116;
VK_F6 = 117;
VK_F7 = 118;
VK_F8 = 119;
VK_F9 = 120;
VK_F10 = 121;
VK_F11 = 122;
VK_F12 = 123;
VK_F13 = 124;
VK_F14 = 125;
VK_F15 = 126;
VK_F16 = 127;
VK_F17 = 128;
VK_F18 = 129;
VK_F19 = 130;
VK_F20 = 131;
VK_F21 = 132;
VK_F22 = 133;
VK_F23 = 134;
VK_F24 = 135;
VK_NUMLOCK = 144;
VK_SCROLL = 145;
{ VK_L & VK_R - left and right Alt, Ctrl and Shift virtual keys.
Used only as parameters to GetAsyncKeyState() and GetKeyState().
No other API or message will distinguish left and right keys in this way. }
VK_LSHIFT = 160;
VK_RSHIFT = 161;
VK_LCONTROL = 162;
VK_RCONTROL = 163;
VK_LMENU = 164;
VK_RMENU = 165;
VK_PROCESSKEY = 229;
VK_ATTN = 246;
VK_CRSEL = 247;
VK_EXSEL = 248;
VK_EREOF = 249;
VK_PLAY = 250;
VK_ZOOM = 251;
VK_NONAME = 252;
VK_PA1 = 253;
VK_OEM_CLEAR = 254;

*************************************
Kaynak: Wardom http://www.wardom.com.tr/showthread.php?t=124497
form üzerinde herhangi bir nesneyi tasimak


procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
sc_DragMove=$F012;

begin
ReleaseCapture;
Button1.Perform(WM_SYSCOMMAND, sc_DragMove, 0);

end;


**************************************
Verilen web sitesini Internet Explorer'da acmak

procedure TForm1.Button1Click(Sender: TObject);
begin
winexec('C:\Program Files\Internet Explorer\iexplore.exe www.delphiturk.com',SW_MAXIMIZE);
end;

*************************************
VeriTabanindan Excele Aktarim.

{Form üzerine ole serverla baglanti kurmak icin "servers" bilesenlerinden "ExcelApplication"
nesnesini eklemeniz gerekir.
IRange.AutoFormat(6,Null,Null,Null,Null,Null,Null) ;
Bu Satirdaki Rakami 1-15 arasinada Degistirerek degisik Formatlar elde edebilirsiniz}


procedure TForm1.Button1Click(Sender: TObject);
var IRange : Excel97.Range;
i,Row : integer;

begin

if not ExcelApplication1.Visible[0] then //excel acikmi
begin
excelApplication1.Visible[0]:= True; //acik degilse ac
excelApplication1.Workbooks.Add(NULL,0); //yeni calisma kitabi olustur
end
else //excel aciksa yeni calisma sayfasi ekle
excelApplication1.Sheets.Add(Null,null,null,null,1 );

// Alan Basliklarini aktar
IRange := excelApplication1.ActiveCell;
for i := 0 to Table1.Fields.count-1 do
begin
IRange.Value := Table1.Fields[i].DisplayLabel;
IRange := IRange.Next;
end;

// Kayitlari Aktar
Kaynak: Wardom http://www.wardom.com.tr/showthread.php?t=124497

Table1.DisableControls;
try
Table1.First;
Row :=2;
while not Table1.Eof do
begin
IRange := ExcelApplication1.Range['A'+IntToStr(Row),'A'+IntToStr(Row)];
for i := 0 to Table1.Fields.Count-1 do
begin
IRange.Value := Table1.Fields[i].Value;
IRange := IRange.Next;
end;
Table1.Next;
Inc(Row);
end;


finally

Table1.EnableControls;
end;
// Auto format

IRange:= ExcelApplication1.Range['A1','D'+IntToStr(Row-1)];
IRange.AutoFormat(6,Null,Null,Null,Null,Null,Null) ;
end;

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

Franticorpse

Excel dosyasindaki bir hucreye ulasmak


// uses kismina ComObj ekle
procedure TForm1.Button1Click(Sender: TObject);
var Book : Variant;
FileName : string;
Excel,Sheet : Variant;
begin
Excel := CreateOleObject('Excel.Application');
repeat
FileName := Excel.GetOpenFileName;

until FileName <> '0';
Book := Excel.WorkBooks.Open(FileName);
Excel.Visible := False;
Sheet := Book.Worksheets[1];
Showmessage(Sheet.Cells[1,1]);
end;


--------------------**********************************--------------------------
Buton üzerine birden çok satır yazmak ?

procedure TForm1.Button1Click(Sender: TObject);
var
i : integer;
begin
i:=GetWindowLong(Button1.Handle,GWL_STYLE );
SetWindowLong (Button1.Handle,GWL_STYLE , i or BS_MULTILINE);
Button1.Caption := 'satır1'#13#10'satır2';
end;

******************************
Form'u transparan yapmak ?

procedure TForm1.Button1Click(Sender: TObject);
var
i : integer;
begin
i:=GetWindowLong(Button1.Handle,GWL_STYLE );
SetWindowLong (Button1.Handle,GWL_STYLE , i or BS_MULTILINE);
Button1.Caption := 'satır1'#13#10'satır2';
end;


********************************
Screensaver oluşturmak ?


{
Screensaver oluşturmak için öncelikle şunları bilmelisiniz :

Screensaver lar iki model içerir : configuration ve running mode
.scr uzantısına sahiptirler, .exe değil !
Fakat normal program gibidirler.

Windows bu programları /c parametresi ile configurasyon modunda
/s modu ile de running (çalışma modunda) başlatır.

}


procedure TForm1.FormCreate(Sender: TObject);
begin
if ParamCount > 0 then
begin
if ParamStr(1) = '/c' then
begin
{start configuration form}
end
else
begin
if ParamStr(1) = '/s' then
begin
{start screensaver}
end;
end;
end;
end;

*******************************************
Masaüstündekipixel rengini öğrenmek ?


function DesktopColor(const x,y: integer): TColor;
var
c:TCanvas;
begin
c:=TCanvas.create;
c.handle:=GetWindowDC(GetDesktopWindow);
result:=getpixel(c.handle,x,y);
c.free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
pos: TPoint;
begin
GetCursorPos(Pos);
Panel1.Color:=DesktopColor(pos.x, pos.y);
end;


*********************************
Form'un taşınmasınıengellemek ?

type
TForm1 = class(TForm)
private
Procedure WMSysCommand( Var msg: TWMSysCommand ); message WM_SYSCOMMAND;
public
{ Public tanımlar }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand(var msg: TWMSysCommand);
begin
if (msg.CmdType and $FFF0) = SC_MOVE then begin
msg.result := 0;
exit;
end;
inherited;
end;

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

TRichedit/TMemoüzerinde get col row olayları ?

function RichRow(m:TRichedit) : LongInt;
begin
Result:=SendMessage(m.Handle,EM_LINEFROMCHAR,m.Sel Start,0);
end;

function RichCol(m:TRichedit) : LongInt;
begin
Result:=m.SelStart-SendMessage(m.handle,EM_LINEINDEX,SendMessage(m.Ha ndle,EM_LINEFROMCHAR,m.SelStart,0),0);
end;



procedure TForm1.RichEdit1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
Label1.Caption:= Format('%d : %d',[RichCol(form1.richedit1),RichRow(form1.richedit1)]);
end;

************************************
System iconlarını kullanabilir miyiz ?

{
possible constants:
Kaynak: Wardom http://www.wardom.com.tr/showthread.php?t=124497

- IDI_APPLICATION
- IDI_ASTERISK
- IDI_EXCLAMATION
- IDI_HAND
- IDI_QUESTION
}

//Icons
procedure TForm1.Button1Click(Sender: TObject);
var
icon:TIcon;
begin
icon:=TIcon.Create;
icon.Handle:=LoadIcon(0,IDI_HAND);
Canvas.Draw(30,100,icon);
end;



{
possible constants:

- OBM_BTNCORNERS
- OBM_BTSIZE
- OBM_CHECK
- OBM_CHECKBOXES
- OBM_CLOSE
- OBM_COMBO
- OBM_DNARROW
- OBM_DNARROWD
- OBM_DNARROWI
- OBM_LFARROW
- OBM_LFARROWD
- OBM_LFARROWI
- OBM_MNARROW
- OBM_REDUCE
- OBM_RESTORE
- OBM_REDUCED
- OBM_SIZE
- OBM_UPARROW
- OBM_ZOOM

}

//Bitmaps
procedure TForm1.Button2Click(Sender: TObject);
var
bitmap:TBitmap;
begin
bitmap:=TBitmap.Create;
bitmap.Handle:=LoadBitmap(0,makeintresource(OBM_RE STORE));
canvas.Draw(100,100,bitmap);
end;


*****************************
Animasyonlu program ikon'u ?


var
icon1:Boolean;


...


procedure TForm1.Timer1Timer(Sender: TObject);
Kaynak: Wardom http://www.wardom.com.tr/showthread.php?t=124497
begin
if icon1=false then
begin
Application.icon:=Image1.Picture.Icon;
icon1:=true;
end
else
begin
Application.icon:=Image2.Picture.Icon;
icon1:=false;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
icon1:=true;
end;

**************************
Memo kayıtlarıiçin UNDO fonksiyonu ?

procedure TForm1.Button1Click(Sender:TObject);
begin
memo1.perform(em_undo, 0, 0);
end;

*************************
Form Yapıştırma

procedure TForm2.FormShow(Sender: TObject);
begin
Form3.SetBounds(2,2,Panel1.Width-4,Panel1.Height-4);
Form3.Show;
end;
--
procedure TForm3.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or WS_CHILD;
Params.Style := WS_CHILD;
Params.WndParent := Form2.Panel1.Handle;
end;

************************
Locate metoduyla birden fazla alana göre arama


Dataset.Locate('aramasahasi1 ; aramasahasi2 ;aramasahasi3 ; ....',
VarArrayOf([AranacakKelime1,AranacakKelime2,AranacakKelime3,.. .]),[loPartialKey]);

locate tipi => [loCaseInsensitive]


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



Direk c/p yaptım; alıntıdır ..

montana007

paylaşım için saol

apobomfunk

paylaşım için teşekkürler iş görücek kodlar var