سورس دلفی

سلام
امروز چند تا سورس جدید براتون میزارم.امیدوارم خوشتون بیاد!!!!
۱-گذاشتن پسورد روی جدول Paradox

uses
  Bde, SysUtils, dbtables, windows;


function StrToOem(const AnsiStr: string): string;
begin
  SetLength(Result, Length(AnsiStr));
  if Length(Result)  0 then
    CharToOem(PChar(AnsiStr), PChar(Result));
end;

function TablePasswort(var Table: TTable; password: string): Boolean;
var
  pTblDesc: pCRTblDesc;
  hDb: hDBIDb;
begin
  Result := False;
  with Table do
  begin
    if Active and (not Exclusive) then Close;
    if (not Exclusive) then Exclusive := True;
    if (not Active) then Open;
    hDB := DBHandle;
    Close;
  end;
  GetMem(pTblDesc, SizeOf(CRTblDesc));
  FillChar(pTblDesc^, SizeOf(CRTblDesc), 0);
  with pTblDesc^ do
  begin
    StrPCopy(szTblName, StrToOem(Table.TableName));
    szTblType := szParadox;
    StrPCopy(szPassword, StrToOem(Password));
    bPack      := True;
    bProtected := True;
  end;
  if DbiDoRestructure(hDb, 1, pTblDesc, nil, nil, nil, False) DBIERR_NONE then Exit;
  if pTblDesc  nil then FreeMem(pTblDesc, SizeOf(CRTblDesc));
  Result := True;
end;

---

۲-قراردادن نوار پیشرفت در Progressbar

type
  THackControl = class(TControl);

procedure TfrmWebsite.FormCreate(Sender: TObject);
var
  PanelRect: TRect;
begin
  THackControl(ProgressBar1).SetParent(StatusBar1);
  SendMessage(StatusBar1.Handle, SB_GETRECT, 1, Integer(@PanelRect));
  with PanelRect do
    ProgressBar1.SetBounds(Left, Top, Right - Left, Bottom - Top);
end;

---

۳-ارتباط با SQL در دلفی

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOConnection1.ConnectionString := 'Server=Hostname;DataBase=DatabaseName';
  ADOConnection1.Open('UserName', 'Password');
  ADOConnection1.Connected := True;
end;

---

۴-کپی کردن یک فایل و نمایش پیشرفت در یک Progressbar

 
procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
var
  FromF, ToF: file of byte;
  Buffer: array[0..4096] of char;
  NumRead: integer;
  FileLength: longint;
begin
  AssignFile(FromF, Source);
  reset(FromF);
  AssignFile(ToF, Destination);
  rewrite(ToF);
  FileLength := FileSize(FromF);
  with Progressbar1 do
  begin
    Min := 0;
    Max := FileLength;
    while FileLength > 0 do
    begin
      BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
      FileLength := FileLength - NumRead;
      BlockWrite(ToF, Buffer[0], NumRead);
      Position := Position + NumRead;
    end;
    CloseFile(FromF);
    CloseFile(ToF);
  end;

---

۵-رنگی کردن سطرهای یک DBGrid

procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
var 
  iValue: LongInt;
begin
 
  if (DataCol = 0) then
  begin
    
    iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
    case iValue of
      1: dbgIn.Canvas.Brush.Color := clGreen;
      2: dbgIn.Canvas.Brush.Color := clLime;
      3: dbgIn.Canvas.Brush.Color := clYellow;
      4: dbgIn.Canvas.Brush.Color := clRed;
    end;
       dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;

 امیدوارم که استفاده کنید.اگه نظری داشتید یا سوس برنامه ای خواستید به من بگید.من کمکتون می کنم.

بابک

---

سر آغاز

با سلام
امیدوارم که بتونم این وبلاگ رو هر روز پربار تر از روز قبل کنم.شما میتونید   بر نامه نویسی دلفی رو یاد بگیرید.من سعی می کنم جدید ترین کامپوننت ها و برنامه ها رو در اینجا قرار بدم تا شما بتونین استفاده کنین.