Kısa Delphi Kodları

'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;





• 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;

alntı