سورس دلفی

سلام
امروز چند تا سورس جدید براتون میزارم.امیدوارم خوشتون بیاد!!!!
۱-گذاشتن پسورد روی جدول 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;

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

بابک

---