دوستان فقط در این تاپیک کدهای مفیدی رو در ذهن دارند به عنوان مرجع در این قسمت قرار دهند . و دوستان لطف کنن در این تاپیک هیچ سوالی مطرح نکنن
ویرایش توسط TAHA : 10-01-2009 در ساعت 05:48 PM
تبديل تاريخ ميلادي به شمسيکد:function shamsi(tt:tdatetime):string; var str,y,m,d:string; yi,mi,di:integer; begin str:=datetostr(tt); y:=copy(str,1,4); m:=copy(str,6,2); d:=copy(str,9,2); yi:=strtoint(y); mi:=strtoint(m); di:=strtoint(d); if (yi mod 4=0) then if mi>2 then begin tt:=tt+1; str:=datetostr(tt); y:=copy(str,1,4); m:=copy(str,6,2); d:=copy(str,9,2); yi:=strtoint(y); mi:=strtoint(m); di:=strtoint(d); end; if ((mi<3) or ((mi=3) and (di<21))) then begin yi:=yi-622; end else begin yi:=yi-621; end; case mi of 1: if di<21 then begin mi:=10; di:=di+10; end else begin mi:=11; di:=di+10; end; 2: if di<20 then begin mi:=11; di:=di+11; end else begin mi:=12; di:=di-19; end; 3: if di<21 then begin mi:=12; di:=di+9; end else begin mi:=1; di:=di-20; end; 4: if di<21 then begin mi:=1; di:=di+11; end else begin mi:=2; di:=di-20; end; 5: if di<22 then begin mi:=mi-3; di:=di+10; end else begin mi:=mi-2; di:=di-21; end; 6: if di<22 then begin mi:=mi-3; di:=di+10; end else begin mi:=mi-2; di:=di-21; end; 7: if di<23 then begin mi:=mi-3; di:=di+9; end else begin mi:=mi-2; di:=di-22; end; 8: if di<23 then begin mi:=mi-3; di:=di+9; end else begin mi:=mi-2; di:=di-22; end; 9: if di<23 then begin mi:=mi-3; di:=di+9; end else begin mi:=mi-2; di:=di-22; end; 10: if di<23 then begin mi:=7; di:=di+8; end else begin mi:=8; di:=di-22; end; 11: if di<22 then begin mi:=mi-3; di:=di+9; end else begin mi:=mi-2; di:=di-21; end; 12: if di<22 then begin mi:=mi-3; di:=di+9; end else begin mi:=mi-2; di:=di-21; end; end; y:=inttostr(yi); m:=inttostr(mi); if (length(m)=1) then m:='0'+m; d:=inttostr(di); if length(d)=1 then d:='0'+d; shamsi:=y+'/'+m+'/'+d end;
تغيير فرم hint
*****************************
کد:begin inherited Create(AOwner); with Canvas.Font do begin Name := 'arial'; Size := Size + 10; Style := [fsBold]; end; end; procedure TForm1.FormCreate(Sender: TObject); var Picture: TPicture; begin HintWindowClass := TMyHintWindow; Application.ShowHint := False; Application.ShowHint := True end;
غير فعال کردن کليد close در گوشه فرم
**************************
کد:procedure TForm1.Button1Click(Sender: TObject); var Flag :UINT; AppSysMenu :THandle; begin AppSysMenu:=GetSystemMenu(Handle,False); Flag:=MF_GRAYED; EnableMenuItem(AppSysMenu,SC_CLOSE,MF_BYCOMMAND or Flag); End;
فشرده سازی
************************
کد:Uses ZLib; function CompressStream (aSource, aTarget: TStream): Single; var comprStream: TCompressionStream; begin comprStream := TCompressionStream.Create( clFastest, aTarget); try comprStream.CopyFrom(aSource, aSource.Size); Result := comprStream.CompressionRate;finally comprStream.Free; end; end;************************** procedure DecompressStream (aSource, aTarget: TStream) ; var decompStream: TDecompressionStream; nRead: Integer; Buffer: array [0..1023] of Char; begin decompStream := TDecompressionStream.Create(aSource); try repeat nRead := decompStream.Read(Buffer, 1024); aTarget.Write (Buffer, nRead); until nRead = 0; finally decompStream.Free; end; end;
ايجاد يكaliases جهت بانك اطلاعاتي در زمان اجراي برنامه دلفي
**************************
کد:uses DBIProcs, DBITypes; procedure AddBDEAlias(sAliasName, sAliasPath, sDBDriver: string); var h: hDBISes; begin DBIInit(nil); DBIStartSession('dummy',h,''); DBIAddAlias(nil, PChar(sAliasName), PChar(sDBDriver), PChar('PATH:' + sAliasPath), True); DBICloseSession(h); DBIExit; end;
صفحه کليد فارسي در هنگام اجرا
************************************
application.bidikeyboard:='00000401';
غير فعال کردن رجيستري اديتور
******************************
کد:var Reg: TRegistry; Reg.RootKey:=HKEY_CURRENT_USER; reg.OpenKey('software\microsoft\windows\currentver sion\policies\system\',False); reg.WriteInteger('disableregistrytools',1);
محدود کردن حرکت موس براي جلوگيري از خروج از فرم
***************************************
کد:procedure TForm1.FormActivate(Sender: TObject); var Po :TPoint; a:TRect; begin a := ClientRect; with a do begin po := ClientToScreen(Point(Left,Top)) ; Left := Po.X; Top := Po.Y ; Po := ClientToScreen(Point(Right,Bottom)) ; Right := Po.X; Bottom := Po.Y; end; ClipCursor(@a); end;
اضافه کردن رديف در DBGRID
********************************
کد:procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin if DataSource1.DataSet.RecNo > 0 then begin if Column.Title.Caption = 'No:' then DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo)); end; end;
خالي کردن همه Edit ها با هم
*****************************
end;کد:procedure clear_Edits; var cnt : integer; begin for cnt := 0 to ComponentCount - 1 do begin if Components[cnt].ClassName = 'TEdit' then TEdit(Components[cnt]).Clear end;
اختلاف دو تاريخ به روز
****************************
کد:IntToStr( round(date-DataModule2.Ta_rent.FieldByName('date_out').AsDate Time))
كليد CTRL+SPACE در OnkeyDown
************************************
کد:if (Shift = [ssCtrl]) and (Key = VK_SPACE) then ...
در مورد مرتب کردن(sort) ستون هاي يه DBGrid
***********************************
کد:procedure Tmain_frm.DBGrid1TitleClick(Column: TColumn); var i: integer; begin if (Column.Title.Font.Style = [fsbold]) and (Column.Title.Font.Color = clWindowText)then begin TADOQuery(Column.Grid.DataSource.DataSet).Sort:='['+Column.FieldName+']'+' DESC' ; for i:=0 to TDBGrid(Column.Grid).Columns.Count-1 do begin TDBGrid(Column.Grid).Columns[i].Title.Font.Style:=[]; TDBGrid(Column.Grid).Columns[i].Title.Font.Color:= clWindowText; end; Column.Title.Font.Style:=[fsbold]; Column.Title.Font.Color:= clred; end else begin TADOQuery(Column.Grid.DataSource.DataSet).Sort:='['+Column.FieldName+']' ; for i:=0 to TDBGrid(Column.Grid).Columns.Count-1 do begin TDBGrid(Column.Grid).Columns[i].Title.Font.Style:=[]; TDBGrid(Column.Grid).Columns[i].Title.Font.Color:= clWindowText; end; Column.Title.Font.Style:=[fsbold]; end; end;
بوک مارک ها