Kısa DeLpHi Kodları

Konu: Kısa DeLpHi Kodları Çarş. Ekim 07, 2009 3:26 pm

'Last Modified' bilgisini almak

Kullanımı: label1.Caption:=FileLastModified('c:\autoexec.bat' ) ; ~~~~~~~~~~~~~~~~~~~~~~~~~ function FileLastModified (const TheFile: string): string; var FileH : THandle; LocalFT : TFileTime; DosFT : DWORD; LastAccessedTime : TDateTime; FindData : TWin32FindData; begin Result := ''; FileH := FindFirstFile(PChar(TheFile), FindData) ; if FileH <> INVALID_HANDLE_VALUE then begin Windows.FindClose(Handle) ; if (FindData.dwFileAttributes AND FILE_ATTRIBUTE_DIRECTORY) = 0 then begin FileTimeToLocalFileTime (FindData.ftLastWriteTime,LocalFT) ; FileTimeToDosDateTime (LocalFT,LongRec(DosFT).Hi,LongRec(DosFT).Lo) ; LastAccessedTime := FileDateToDateTime(DosFT) ; Result := DateTimeToStr(LastAccessedTime) ; end; end; end; • Windows Start-Documents bölümüne dosya eklemek

procedure AddtoDocMenu(fName : String) ;
begin
SHAddToRecentDocs(SHARD_PATH, PChar(fName)) ;
end;

• Form üzerine "crosshair" eklemek

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
{ I wrote this procedure with in this block for easy access, this one draws the cross hair}
Procedure DrawCross(AX,AY:Integer);
Begin
With Form1.Canvas Do
Begin
{ By putting pen mode to Xor will help to erase the previous cross hair }
Form1.Canvas.Pen.Mode:=pmNotXor;
MoveTo(Ax,0);
LineTo(Ax,Form1.Height);
MoveTo(0,AY);
LineTo(Form1.Width,AY);
End;
End;
begin
If Not FirstMove Then
DrawCross(OldX,OldY)
Else
FirstMove:=False;
DrawCross(X,Y);
Form1.Caption:='X : '+IntToStr(X)+' Y : '+IntToStr(Y);
OldX:=X;
OldY:=Y;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FirstMove:=True;
end;

• Komut satırından parametre okumak

procedure TForm1.FormCreate(Sender: TObject);
Var
I : Integer;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('Parameters Count : '+IntToStr(ParamCount));
{ ParamCount - Returns the number of parameters passed on the command line. }
If ParamCount>0 Then
For I:=1 To ParamCount Do
{ ParamStr - Returns a specified parameter from the command-line. }
Memo1.Lines.Add('Parameter '+IntToStr(I)+' : '+ParamStr(I)) end;

• Disket sürücünün durumu

type
TDriveState = (DSNODISK, DSUNFORMATTEDDISK, DSEMPTYDISK, DSDISK_WITHFILES);

function DriveState (driveletter: Char) : TDriveState;
var
mask: String[6];
sRec: TSearchRec;
oldMode: Cardinal;
retcode: Integer;
begin
oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS);
mask:= '?:\*.*';
mask[1] := driveletter;
{$I-}
retcode := FindFirst (mask, faAnyfile, SRec);
FindClose(SRec);
{$I+}
case retcode of
0: Result := DSDISK_WITHFILES; { at least one file was found }
-18: Result := DSEMPTYDISK; { no files, but disk is ok }
-21, -3: Result := DSNODISK; { DOS ERRORNOTREADY in WinNT,
ERRORPATH_NOTFOUND in 3.1 }
else
Result := DSUNFORMATTEDDISK; { unformatted disk in drive }
end;
SetErrorMode(oldMode);
end; { DriveState }

• Geri Dönüşüm Kutusuna Dosya Göndermek

procedure RecycleFile(s : string);
var
SHFileOpStruct : TSHFileOpStruct;
begin
with SHFileOpStruct do
begin
Wnd := 0;
wFunc := FO_DELETE; // we want to delete a file...
pFrom := PChar(s+#0+#0); //... this file ...
pTo := nil;
fFlags := FOF_ALLOWUNDO; //... able to "Undo" (recycle)
hNameMappings := nil;
lpszProgressTitle := nil;
end;
SHFileOperation(SHFileOpStruct); // to the Recycle Bin
end;

• Menuleri programdan açmak

keybd_event(VK_MENU, MapVirtualkey(VK_MENU, 0 ), 0, 0);
keybd_event(Ord('F'), MapVirtualKey(Ord('F'), 0), 0, 0);
keybd_event(Ord('F'), MapVirtualKey(Ord('F'), 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_MENU, MapVirtualkey(VK_MENU, 0 ), KEYEVENTF_KEYUP, 0);

• Ip adresini bulmak

uses
WinSock; // type PHostEnt

function My_IP_Address : longint;
var
buf : array [0..255] of char;
RemoteHost : PHostEnt;
begin
Winsock.GetHostName(@buf, 255);
RemoteHost:=Winsock.GetHostByName(buf);
if RemoteHost=NIL then
My_IP_Address := winsock.htonl($07000001) { 127.0.0.1 }
else
My_IP_Address := longint(pointer(RemoteHost^.h_addr_list^)^);
Result := Winsock.ntohl(Result);
end;

Konu: Geri: Kısa DeLpHi Kodları Çarş. Ekim 07, 2009 3:26 pm

• Windows' da yüklü yazıcıların listesi ve port bilgisi

Unit listesine "printers" unitini ekleyin.
var Printer:TPrinter;
begin
Printer:=TPrinter.Create;
Memo1.Lines.Assign(Printer.Printers);

• Windowsa bir dosyanın açtırılması

Unit listesine "shellapi" unitini ekleyin.
shellexecute(0,'open', 'c:\autoexec.bat','','',SW_NORMAL);

• Ekran çözünürlüğünü öğrenmek

ShowMessage('Çözünürlük: '+IntToStr( Screen.Width ) +' x '+ IntToStr( Screen.Height ));

• Table nesnesinde Locate ile birden fazla alanda aratmak

with musteri do
Locate('isim;soyad;meslek', VarArrayOf(['Mete', 'YILMAZ', 'Programcı']), [loPartialKey]);

• WEB sayfasının açılması işlemi

ShellExecute(Handle, 'open', 'http://www.programlarim.com', nil, nil, sw_ShowMaximized);

• DOS programının çalıştırılması

WinExec('command.com /c programim.exe',sw_ShowNormal);

• Programı bekletmek

(1000milisaniye = 1 saniye)
Sleep(10000);

• Excel ile işlem yapmak

uses
OleAuto; // Delphi 3
ComObj; // Delphi 5

var
vExcel: variant;

procedure TForm1.Button1Click(Sender: TObject);
begin
vExcel := CreateOleObject('Excel.Application');
vExcel.Workbooks.Add;
vExcel.ActiveWorkbook.Worksheets(1).Range('A1').Va lue := 'Hello World';
vExcel.Visible := True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if not VarIsEmpty(vExcel) then vExcel.Quit;
end;

• Transparent formlar

type
TMyForm = class(TForm)
procedure FormCreate(Sender: TObject);
procedure CreateParams(var Params: TCreateParams); override;
end;

procedure TMyForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
// this is the important constant!
Params.ExStyle:= Params.ExStyle or WS_EX_TRANSPARENT;
end;

Procedure TMyForm.FormCreate(Sender: TObject);
begin
inherited;
Canvas.Brush.Style := bsClear;
end;

• Clibboard işlemi ( kopyala, yapıştır )

procedure CopyButtonClick(Sender: TObject);
begin
if ActiveControl is TMemo then TMemo(ActiveControl).CopyToClipboard;
if ActiveControl is TDBMemo then TDBMemo(ActiveControl).CopyToClipboard;
if ActiveControl is TEdit then TEdit(ActiveControl).CopyToClipboard;
if ActiveControl is TDBedit then TDBedit(ActiveControl).CopyToClipboard;
end;

procedure PasteButtonClick(Sender: TObject);
begin
if ActiveControl is TMemo then TMemo(ActiveControl).PasteFromClipboard;
if ActiveControl is TDBMemo then TDBMemo(ActiveControl).PasteFromClipboard;
if ActiveControl is TEdit then TEdit(ActiveControl).PasteFromClipboard;
if ActiveControl is TDBedit then TDBedit(ActiveControl).PasteFromClipboard;
end;

• Animated cursor kullanmak

const
crMyCursor = 1;
procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.Cursors[crMyCursor] := LoadCursorFromFile('c:\mystuff\mycursor.ani');
Cursor := crMyCursor;
end;

• Formun boyutlarını sınırlandırmak

type
TForm1 = class(TForm)
protected
procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
end;
procedure TForm1.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
begin
with Message.MinMaxInfo^ do
begin
ptMinTrackSize := Point(100, 100);
ptMaxTrackSize := Point(200, 200);
end;
end;

• TMemo'ya border eklemek

var
Rect : TRect;
begin
SendMessage(Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
Rect.Left := 20;
SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
Memo1.Refresh;

• Programı windows açılışına çalıştırmak

Procedure OnStartup (const PgmTitle, CmdLine: String; RunOnce: boolean);
Var
Key : String;
Reg : TRegIniFile;
Begin
If RunOnce Then
Key := 'Once' #0
Else
Key := #0;
Reg := TRegIniFile.create ('');
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.WriteString ('Software\Microsoft\Windows\CurrentVersion\Run' + Key,
ProgTitle, CmdLine);
Reg.Free
End;

• LAN ( network ) bağlantısı kontrolü

const
MAX_NEIGHBORS = 20;
Function NetAvailable : Boolean;
Var
NetRes : Array [0..MAX_NEIGHBORS] Of TNetResource;
NNError,
hEnum,
EntryCount,
NetResLen : DWORD;
loop1 : Integer;
Begin
hEnum := -1;
Result := FALSE;
Try
NNError := WNetOpenEnum (RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, Nil, hEnum);
If NNError = NO_ERROR Then
Begin
While NNError <> ERROR_NO_MORE_ITEMS Do
Begin
EntryCount := 1;
NetResLen := SizeOf (NetRes);
NNError := WNetEnumResource (hEnum, EntryCount, @NetRes, NetResLen);
If (NNError = NO_ERROR) Then
Begin
For loop1 := 1 to EntryCount Do
Begin
If Pos ('Microsoft', NetRes[0].lpProvider) = 1 Then
Begin
Result := TRUE;
Break
End
End
End
Else
Begin
Break
End
End;
WNetCloseEnum (hEnum)
// enum kapat
End
Except
On exception Do
If DEBUG Then
Begin
ShowMessage ('Network Neighborhood kontrolü hata verdi.')
End;
End
End;

» Delphi 7.0+Delphi 7.0 ile Programlama Türkçe Görsel Egitim Seti
» Delphi Kod Arşivi 1.0