نکات برنامه نویسی در دلفی

نقل قول:

---

نوشته شده توسط مجتبی تاجیک

آدرس لینک ها اشتباه هست ، خودتون تو تاپیک بگردید و پست مورد نظرتون رو پیدا کنید .

---

آخه جستجوي تالار هم درست جواب نميدهد كه بتوانيم دقيقا روي تاپيك مورد نظر برويم مگر اينكه يكي يكي تاپيكهارا بگرديم كه فكر ميكنم راحتتر باشه توكل اينترنت بگرديم تا اينجارا!!!!!!

نقل قول:

---

نوشته شده توسط shpegah

آخه جستجوي تالار هم درست جواب نميدهد كه بتوانيم دقيقا روي تاپيك مورد نظر برويم مگر اينكه يكي يكي تاپيكهارا بگرديم كه فكر ميكنم راحتتر باشه توكل اينترنت بگرديم تا اينجارا!!!!!!

---

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

ایجاد یک Edit که فقط عدد دریافت کند

SetWindowLong(Edit1.Handle, GWL_STYLE, ES_NUMBER);

استفاده از ریسورس استرینگ به صورت مستقیم در بر نامه

implementation



{$R *.dfm}

resourcestring

  msgcaption='ResSample';

  msgText='this is a resource string sample';



procedure TForm1.Button1Click(Sender: TObject);

begin

MessageBox(0,PChar(msgtext),PChar(msgcaption),0);

end;

نقل قول:

---

نوشته شده توسط cayberfox

ایجاد یک Edit که فقط عدد دریافت کند

SetWindowLong(Edit1.Handle, GWL_STYLE, ES_NUMBER);

---

ممنون. چرا این کد جواب نمیده؟

با اجازه منم چند تا کار می ذارم.
به دست آوردن مختصات هر سلول از DBGrid:
1- در قسمت Type:

  TDBGrid_PublishProtectedItems = class(TDBGrid)

    property Row;

    property Col;

    function GetCellRect(ACol, ARow: Longint): TRect;

  end;

2-پیاده سازی متد بالا:

function TDBGrid_PublishProtectedItems.GetCellRect(ACol,

  ARow: Integer): TRect;

var

  rect: TRect;

  a, b: integer;

begin

  a := Self.Left + (Self.Width - Self.ClientWidth) -2;

  b := Self.Top + (Self.Height - Self.ClientHeight) -2;

  rect := CellRect(ACol, ARow);

  rect.Left := rect.Left + a;

  rect.Top := rect.Top + b;

  rect.Right := rect.Right + a;

  rect.Bottom := rect.Bottom + b;

  result := rect;

end;

3- هنگام استفاده:

procedure TForm1.Button2Click(Sender: TObject);

var

  r: trect;

begin

  r := TDBGrid_PublishProtectedItems(DBGrid1).GetCellRect  (4, 7);

  Edit1.Top := r.Top;

  Edit1.Left := r.Left;

  Edit1.Width := r.Right- r.Left;

  Edit1.Height := r.Bottom- r.Top;

end;

وقتی مثلا تو ClacField یه SP به ازای هر ردیفش یه عکس بخواهیم بسازیم.
(کاربرد : ما متن بارکد رو ذخیره می کنیم اما عکسش رو چاپ می گیریم).
تعریف:

procedure SaveImageToCalculatedField(Field: TField; Img: TImage);

var

  DS: TCustomADODataSet;

  i: integer;

begin

  DS := Field.DataSet as TCustomADODataSet;

  Field.Value := DS.Recordset.AbsolutePosition -1;

  Img.Tag := Field.Value;

  for i := 0 to Field.ComponentCount -1 do

    if Field.Components[i] is TImage then

      if (Field.Components[i] as TImage).Tag = Field.Value then

        begin

        Field.Components[i].Destroy;

        break;

        end;

  Field.InsertComponent(Img);

end;

function GetImageFromCalculatedField(Field: TField): TImage;

var

  i: integer;

begin

  result := nil;

  for i := 0 to Field.ComponentCount -1 do

    if Field.Components[i] is TImage then

      if (Field.Components[i] as TImage).Tag = Field.Value then

        begin

        result := Field.Components[i] as TImage;

        break;

        end;

end;

 

استفاده:
یه ClacField از نوع عددی می سازیم.

OnCalcField:

var

  Img: TImage;

begin

  Img := TImage.Create(nil);

  GetBarCode(SPFetchGoodsBarCode.Value, Img);

  SaveImageToCalculatedField(SPFetchGoodsclBarCodeIm  age, Img);

end;

 

جایی که می خواهیمش:
Image1.Picture := GetImageFromCalculatedField(ADO.FieldByName(fieldn ame)).Picture

خیلی ممنون ولی میخواستم بپرسم این پذوسجرهایی که اینجا نوشتید رو چچجوری من باید وارد برنامه کنم
آخه همش توی یک خطه و یکسری علامتهایی داره که مفهوم نیست

این به خاطر سایت هست نه کد.
با firefox ببینید.

فشرده سازی و بازگشایی فایل فشرده

uses

  Zlib;



procedure CompressFiles(Files : TStrings; const Filename : String);

var

  infile, outfile, tmpFile : TFileStream;

  compr : TCompressionStream;

  i,l : Integer;

  s : String;



begin

  if Files.Count > 0 then

  begin

    outFile := TFileStream.Create(Filename,fmCreate);

    try

      { the number of files }

      l := Files.Count;

      outfile.Write(l,SizeOf(l));

      for i := 0 to Files.Count-1 do

      begin

        infile := TFileStream.Create(Files[i],fmOpenRead);

        try

          { the original filename }

          s := ExtractFilename(Files[i]);

          l := Length(s);

          outfile.Write(l,SizeOf(l));

          outfile.Write(s[1],l);

          { the original filesize }

          l := infile.Size;

          outfile.Write(l,SizeOf(l));

          { compress and store the file temporary}

          tmpFile := TFileStream.Create('tmp',fmCreate);

          compr := TCompressionStream.Create(clMax,tmpfile);

          try

            compr.CopyFrom(infile,l);

          finally

            compr.Free;

            tmpFile.Free;

          end;

          { append the compressed file to the destination file }

          tmpFile := TFileStream.Create('tmp',fmOpenRead);

          try

            outfile.CopyFrom(tmpFile,0);

          finally

            tmpFile.Free;

          end;

        finally

          infile.Free;

        end;

      end;

    finally

      outfile.Free;

    end;

    DeleteFile('tmp');

  end;

end;



procedure DecompressFiles(const Filename, DestDirectory : String);

var

  dest,s : String;

  decompr : TDecompressionStream;

  infile, outfile : TFilestream;

  i,l,c : Integer;

begin

  // IncludeTrailingPathDelimiter (D6/D7 only)

  dest := IncludeTrailingPathDelimiter(DestDirectory);



  infile := TFileStream.Create(Filename,fmOpenRead);

  try

    { number of files }

    infile.Read(c,SizeOf(c));

    for i := 1 to c do

    begin

      { read filename }

      infile.Read(l,SizeOf(l));

      SetLength(s,l);

      infile.Read(s[1],l);

      { read filesize }

      infile.Read(l,SizeOf(l));

      { decompress the files and store it }

      s := dest+s; //include the path

      outfile := TFileStream.Create(s,fmCreate);

      decompr := TDecompressionStream.Create(infile);

      try

        outfile.CopyFrom(decompr,l);

      finally

        outfile.Free;

        decompr.Free;

      end;

    end;

  finally

    infile.Free;

  end;

end;

بررسی NTFS بودن درایو

uses

  ComObj;



function IsNTFS(AFileName: string): Boolean;

var

  fso, drv: OleVariant;

begin

  IsNTFS := False;

  fso := CreateOleObject('Scripting.FileSystemObject');

  drv := fso.GetDrive(fso.GetDriveName(AFileName));

  IsNTFS := drv.FileSystem = 'NTFS'

end;



procedure TForm1.Button1Click(Sender: TObject);

begin

  if IsNTFS('X:\Temp\File.doc') then

    ShowMessage('File is on NTFS File System')

  else

    ShowMessage('File is not on NTFS File System')

end;

function SplitFile(FileName : TFileName; SizeofFiles : Integer; ProgressBar : TProgressBar) : Boolean;

var

  i : Word;

  fs, sStream: TFileStream;

  SplitFileName: String;

begin

  ProgressBar.Position := 0;

  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

  try

    for i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do

    begin

      SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));

      sStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive);

      try

        if fs.Size - fs.Position < SizeofFiles then

          SizeofFiles := fs.Size - fs.Position;

        sStream.CopyFrom(fs, SizeofFiles);

        ProgressBar.Position := Round((fs.Position / fs.Size) * 100);

      finally

        sStream.Free;

      end;

    end;

  finally

    fs.Free;

  end;



end;





function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean;

var

  i: integer;

  fs, sStream: TFileStream;

  filenameOrg: String;

begin

  i := 1;

  fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive);

  try

    while FileExists(FileName) do

    begin

      sStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

      try

        fs.CopyFrom(sStream, 0);

      finally

        sStream.Free;

      end;

      Inc(i);

      FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));

    end;

  finally

    fs.Free;

  end;

end;





procedure TForm1.Button1Click(Sender: TObject);

begin

  SplitFile('C:\temp\FileToSplit.chm',1000000, ProgressBar1);

end;



procedure TForm1.Button2Click(Sender: TObject);

begin

  CombineFiles('C:\temp\FileToSplit.001','H:\temp\Fi  leToSplit.chm');

end;

function IsWrongIP(Ip: string): Boolean;

const

  Z = ['0'..'9', '.'];

var

  I, J, P: Integer;

  W: string;

begin

  Result := False;

  if (Length(Ip) > 15) or (Ip[1] = '.') then Exit;

  I := 1; 

  J := 0; 

  P := 0; 

  W := '';

  repeat

    if (Ip[I] in Z) and (J < 4) then

    begin

      if Ip[I] = '.' then

      begin

        Inc(P);

        J := 0;

        try

          StrToInt(Ip[I + 1]);

        except

          Exit;

        end;

        W := '';

      end 

      else 

      begin

        W := W + Ip[I];

        if (StrToInt(W) > 255) or (Length(W) > 3) then Exit;

        Inc(J);

      end;

    end

    else 

      Exit;

    Inc(I);

  until I > Length(Ip);

  if P < 3 then Exit;

  Result := True;

end;

type

  PNetResourceArray = ^TNetResourceArray;

  TNetResourceArray = array[0..100] of TNetResource;



function CreateNetResourceList(ResourceType: DWord;

                              NetResource: PNetResource;

                              out Entries: DWord;

                              out List: PNetResourceArray): Boolean;

var

  EnumHandle: THandle;

  BufSize: DWord;

  Res: DWord;

begin

  Result := False;

  List := Nil;

  Entries := 0;

  if WNetOpenEnum(RESOURCE_GLOBALNET,

                  ResourceType,

                  0,

                  NetResource,

                  EnumHandle) = NO_ERROR then begin

    try

      BufSize := $4000;  // 16 kByte

      GetMem(List, BufSize);

      try

        repeat

          Entries := DWord(-1);

          FillChar(List^, BufSize, 0);

          Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);

          if Res = ERROR_MORE_DATA then

          begin

            ReAllocMem(List, BufSize);

          end;

        until Res <> ERROR_MORE_DATA;



        Result := Res = NO_ERROR;

        if not Result then

        begin

          FreeMem(List);

          List := Nil;

          Entries := 0;

        end;

      except

        FreeMem(List);

        raise;

      end;

    finally

      WNetCloseEnum(EnumHandle);

    end;

  end;

end;



procedure ScanNetworkResources(ResourceType, DisplayType: DWord; List: TStrings);



procedure ScanLevel(NetResource: PNetResource);

var

  Entries: DWord;

  NetResourceList: PNetResourceArray;

  i: Integer;

begin

  if CreateNetResourceList(ResourceType, NetResource, Entries, NetResourceList) then try

    for i := 0 to Integer(Entries) - 1 do

    begin

      if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or

        (NetResourceList[i].dwDisplayType = DisplayType) then begin

        List.AddObject(NetResourceList[i].lpRemoteName,

                      Pointer(NetResourceList[i].dwDisplayType));

      end;

      if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER) <> 0 then

        ScanLevel(@NetResourceList[i]);

    end;

  finally

    FreeMem(NetResourceList);

  end;

end;



begin

  ScanLevel(Nil);

end;



procedure TForm1.Button1Click(Sender: TObject);

begin

  ScanNetworkResources(RESOURCETYPE_DISK, RESOURCEDISPLAYTYPE_SERVER, ListBox1.Items);

end;

uses

  Winsock;



function IAddrToHostName(const IP: string): string;

var

  i: Integer;

  p: PHostEnt;

begin

  Result := '';

  i      := inet_addr(PChar(IP));

  if i <> u_long(INADDR_NONE) then

  begin

    p := GetHostByAddr(@i, SizeOf(Integer), PF_INET);

    if p <> nil then Result := p^.h_name;

  end

  else

    Result := 'Invalid IP address';

end;

uses

  WinInet;



function GetProxyInformation: string;

var

  ProxyInfo: PInternetProxyInfo;

  Len: LongWord;

begin

  Result := '';

  Len := 4096;

  GetMem(ProxyInfo, Len);

  try

    if InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len) then

      if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then

      begin

        Result := ProxyInfo^.lpszProxy

      end;

  finally

    FreeMem(ProxyInfo);

  end;

end;





procedure GetProxyServer(protocol: string; var ProxyServer: string;

  var ProxyPort: Integer);

var

  i: Integer;

  proxyinfo, ps: string;

begin

  ProxyServer := '';

  ProxyPort := 0;



  proxyinfo := GetProxyInformation;

  if proxyinfo = '' then

    Exit;



  protocol := protocol + '=';



  i := Pos(protocol, proxyinfo);

  if i > 0 then

  begin

    Delete(proxyinfo, 1, i + Length(protocol));

    i := Pos(';', ProxyServer);

    if i > 0 then

      proxyinfo := Copy(proxyinfo, 1, i - 1);

  end;



  i := Pos(':', proxyinfo);

  if i > 0 then

  begin

    ProxyPort := StrToIntDef(Copy(proxyinfo, i + 1, Length(proxyinfo) - i), 0);

    ProxyServer := Copy(proxyinfo, 1, i - 1)

  end

end;



procedure TForm1.Button1Click(Sender: TObject);

var

  ProxyServer: string;

  ProxyPort: Integer;

begin

  GetProxyServer('http', ProxyServer, ProxyPort);

  Label1.Caption := ProxyServer;

  label2.Caption := IntToStr(ProxyPort);

end;

uses registry;



procedure ShowTypedUrls(Urls: TStrings);

var

  Reg: TRegistry;

  S: TStringList;

  i: Integer;

begin

  Reg := TRegistry.Create;

  try

    Reg.RootKey := HKEY_CURRENT_USER;

    if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then

    begin

      S := TStringList.Create;

      try

        reg.GetValueNames(S);

        for i := 0 to S.Count - 1 do

        begin

          Urls.Add(reg.ReadString(S.Strings[i]));

        end;

      finally

        S.Free;

      end;

      Reg.CloseKey;

    end;

  finally

    Reg.Free;

  end;

end;



procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowTypedUrls(ListBox1.Items);

end;

uses

  Registry;



function GetIEVersion(Key: string): string;

var

  Reg: TRegistry;

begin

  Reg := TRegistry.Create;

  try

    Reg.RootKey := HKEY_LOCAL_MACHINE;

    Reg.OpenKey('Software\Microsoft\Internet Explorer', False);

    try

      Result := Reg.ReadString(Key);

    except

      Result := '';

    end;

    Reg.CloseKey;

  finally

    Reg.Free;

  end;

end;





procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowMessage('IE-Version: ' + GetIEVersion('Version')[1] + '.' + GetIEVersion('Version')[3]);

  ShowMessage('IE-Version: ' + GetIEVersion('Version'));

  // <major version>.<minor version>.<build number>.<sub-build number>

end;

uses

  WinInet;



procedure DeleteIECache;

var

  lpEntryInfo: PInternetCacheEntryInfo;

  hCacheDir: LongWord;

  dwEntrySize: LongWord;

begin

  dwEntrySize := 0;

  FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);

  GetMem(lpEntryInfo, dwEntrySize);

  if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;

  hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);

  if hCacheDir <> 0 then 

  begin

    repeat

      DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName  );

      FreeMem(lpEntryInfo, dwEntrySize);

      dwEntrySize := 0;

      FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);

      GetMem(lpEntryInfo, dwEntrySize);

      if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;

    until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);

  end;

  FreeMem(lpEntryInfo, dwEntrySize);

  FindCloseUrlCache(hCacheDir);

end;







procedure TForm1.Button1Click(Sender: TObject);

begin

  DeleteIECache;

end;

function ConnectDrive(_drvLetter: string; _netPath: string; _showError: Boolean;

  _reconnect: Boolean): DWORD;

var

  nRes: TNetResource;

  errCode: DWORD;

  dwFlags: DWORD;

begin

  { Fill NetRessource with #0 to provide uninitialized values }

  { NetRessource mit #0 füllen => Keine unitialisierte Werte }

  FillChar(NRes, SizeOf(NRes), #0);

  nRes.dwType := RESOURCETYPE_DISK;

  { Set Driveletter and Networkpath }

  { Laufwerkbuchstabe und Netzwerkpfad setzen }

  nRes.lpLocalName  := PChar(_drvLetter);

  nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\C }

  { Check if it should be saved for use after restart and set flags }

  { Uberprüfung, ob gespeichert werden soll }

  if _reconnect then

    dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE

  else

    dwFlags := CONNECT_INTERACTIVE;



  errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags);

  { Show Errormessage, if flag is set }

  { Fehlernachricht aneigen }

  if (errCode <> NO_ERROR) and (_showError) then

  begin

    Application.MessageBox(PChar('An error occured while connecting:' + #13#10 +

      SysErrorMessage(GetLastError)),

      'Error while connecting!',

      MB_OK);

  end;

  Result := errCode; { NO_ERROR }

end;



function ConnectPrinterDevice(_lptPort: string; _netPath: string; _showError: Boolean;

  _reconnect: Boolean): DWORD;

var

  nRes: TNetResource;

  errCode: DWORD;

  dwFlags: DWORD;

begin

  { Fill NetRessource with #0 to provide uninitialized values }

  { NetRessource mit #0 füllen => Keine unitialisierte Werte }

  FillChar(NRes, SizeOf(NRes), #0);

  nRes.dwType := RESOURCETYPE_PRINT;

  { Set Printername and Networkpath }

  { Druckername und Netzwerkpfad setzen }

  nRes.lpLocalName  := PChar(_lptPort);

  nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\Printer1 }

  { Check if it should be saved for use after restart and set flags }

  { Uberprüfung, ob gespeichert werden soll }

  if _reconnect then

    dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE

  else

    dwFlags := CONNECT_INTERACTIVE;



  errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags);

  { Show Errormessage, if flag is set }

  { Fehlernachricht aneigen }

  if (errCode <> NO_ERROR) and (_showError) then

  begin

    Application.MessageBox(PChar('An error occured while connecting:' + #13#10 +

      SysErrorMessage(GetLastError)),

      'Error while connecting!',

      MB_OK);

  end;

  Result := errCode; { NO_ERROR }

end;



function DisconnectNetDrive(_locDrive: string; _showError: Boolean; _force: Boolean;

  _save: Boolean): DWORD;

var

  dwFlags: DWORD;

  errCode: DWORD;

begin

  { Set dwFlags, if necessary }

  { Setze dwFlags auf gewünschten Wert }

  if _save then

    dwFlags := CONNECT_UPDATE_PROFILE

  else

    dwFlags := 0;

  { Cancel the connection see also at http://www.swissdelphicenter.ch/en/showcode.php?id=391 }

  { Siehe auch oben genannten Link (Netzlaufwerke anzeigen) }

  errCode := WNetCancelConnection2(PChar(_locDrive), dwFlags, _force);

  { Show Errormessage, if flag is set }

  { Fehlernachricht anzeigen }

  if (errCode <> NO_ERROR) and (_showError) then 

  begin

    Application.MessageBox(PChar('An error occured while disconnecting:' + #13#10 +

      SysErrorMessage(GetLastError)),

      'Error while disconnecting',

      MB_OK);

  end;

  Result := errCode; { NO_ERROR }

end;

uses ShellAPI; 



function DeleteFileWithUndo(sFileName: string): Boolean;

var 

  fos: TSHFileOpStruct; 

begin 

  FillChar(fos, SizeOf(fos), 0); 

  with fos do 

  begin 

    wFunc  := FO_DELETE; 

    pFrom  := PChar(sFileName); 

    fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT; 

  end; 

  Result := (0 = ShFileOperation(fos)); 

end; 

دریافت شماره سریال هارد - cpu و ...

مناسب برای ساخت قفل نرم افزاری

جابجایی کنترلهای روی فرم در ران تیم

Gradient-Panel with 6 Main-Propertys

با سلام و تشكر
لطفا مثال در زمينه كار با سوكت ها را هم قرار دهيد

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

موضوع در رابطه با تبدیل یک مقدار از نوع string به Pwidechar هست( تبدیل به Pwidechar هست نه Widechar ) که در برخی توابع از جمله تابع SetFileAttributes استفاده میشه که برای تبدیل باید از تابع StringToOleStr استفاده کرد .

روشی ساده برای شناسایی دیباگر

 {$IFDEF DEBUG}

    ShowMessage('Debuger Found');

{$ENDIF}

دوست عزیز این کدها مگه راهنمای کامپایلر نیستند؟
اگر در اگزه تست بشه اون پیغام یا هست یا نیست.
فکر نکنم به درد ضد دیباگ در مثلا olly بخوره.
ممکنه توضیح بدید؟

این کد مربوط به ضد دیباگ نیست و یک راهنمای کامپایلر است که با آن می توانید تشخیص دهید که برنامه توسط دیباگر اجرا شده یا نه؟
از این تکنیک در بسیاری از جاها استفاده میشه و شاید شما هم نظیر آن را در بعضی کامپوننت های Trial دیده باشید که برنامه ساخته شده با آنها فقط در حالت دیباگ می تواند اجرا شود و یا مثلاً می خواهید کاری کنید که اگر برنامه در حالت دیباگ اجرا شد یک Log File تولید کنید و یا ... .

نقل قول:

---

دوست عزیز این کدها مگه راهنمای کامپایلر نیستند؟
اگر در اگزه تست بشه اون پیغام یا هست یا نیست.
فکر نکنم به درد ضد دیباگ در مثلا olly بخوره.
ممکنه توضیح بدید؟

---

بله هست
در exe هم اون پیغام خواهد بود
اتفاقا روی Olly هم تست کردم و جواب داد

تصحیح کدهای خراب سایت:

Var

  S:String;

begin

  S:=Memo1.Text;

  S:=StringReplace(S,'(','(',[rfReplaceAll]);

  S:=StringReplace(S,')',')',[rfReplaceAll]);

  S:=StringReplace(S,':',':',[rfReplaceAll]);

  S:=StringReplace(S,'[','[',[rfReplaceAll]);

  S:=StringReplace(S,']',']',[rfReplaceAll]);

  S:=StringReplace(S,'&lt;','<',[rfReplaceAll]);

  S:=StringReplace(S,'&#123;','{/',[rfReplaceAll]);

  S:=StringReplace(S,'&#125;','/}',[rfReplaceAll]);

  Memo1.Text:=S;

  Memo1.SelectAll;

  Memo1.CopyToClipboard;

  Memo1.SelLength:=0;

end;

ضمیمه 86190

تو این لینک که مربوط به سایت نرم افزار قوی Help & Manual هست نحوه ارتباط با فایل راهنما کامل توضیح داده شده. جهت توسعه هرچه بهتر نرم افزارتون حتما به کار میاد.
راستی نرم افزار Help & Manual رو فراموش نکنید و اینکه با دلفی بزرگوار تولید شده.

صفحه ارتباط با راهنما:
http://www.helpsmith.com/how-to-conn...chm-delphi.php

صفحه اصلی نرم افزار:
http://www.helpsmith.com/

سلام
همه شما با دستور With آشنایی دارید.
به کد زیر توجه کنید:

  with Memo1 do

  begin



    With Lines do

    begin

      Add('Line 1');

      Add('Line 2');

    end;



  end;

کد بالا یک معادل جالب هم دارد که شاید افراد بسیاری کمی از آن اطلاع داشته باشند. جالب است بدانید که کد زیر دقیقاً معادل کد بالا است:

  with Memo1, Lines do

  begin

    Add('Line 1');

    Add('Line 2');

  end;

منبع:
http://www.nickhodges.com/post/How-N...tatements.aspx

نقل قول:

---

نوشته شده توسط شاهین عشایری

سلام
همه شما با دستور With آشنایی دارید.
به کد زیر توجه کنید:

  with Memo1 do

  begin



    With Lines do

    begin

      Add('Line 1');

      Add('Line 2');

    end;



  end;

کد بالا یک معادل جالب هم دارد که شاید افراد بسیاری کمی از آن اطلاع داشته باشند. جالب است بدانید که کد زیر دقیقاً معادل کد بالا است:

  with Memo1, Lines do

  begin

    Add('Line 1');

    Add('Line 2');

  end;

منبع:
http://www.nickhodges.com/post/How-N...tatements.aspx

---

مثالی که ذکر کردید جالب نیست ، خوب به جای اون کد :

with Memo1.Lines do

begin

  Add('Line 1');

  Add('Line 2');

end;

اون نوع استفاده از with برای اشیاء مختلف کاربردی هست ، مثلا :

var

  StrList: TStringList;

  I: Integer;

begin

  StrList := TStringList.Create;

  try

    with ListBox1, StrList do

    begin

      Add('Item 1 in string list');

      Add('Item 2 in string list');

      Add('Item 3 in string list');

      for I := 0 to Count - 1 do

        Items.Add(Strings[I]);

    end;

  finally

    StrList.Free;

  end;

end;

البته به عنوان مثال و گرنه با Assign میشه راحت این مورد رو پیاده کرد .

از این شیوه در پروژه های بزرگ استفاده نکنید ، کد رو خیلی پیچیده میکنه و به نوشتن کدهای کثیف کمک شایانی میکنه و کار دیباگ کد رو بسیار پیچیده میکنه .

در ضمن اگر اشیاء انتخاب شده دارای متدهای یکسانی باشند متد شئ آخر در لیست With در نظر گرفته میشه ، مثلا تو همون کد بالا هم کلاس TStringList دارای متد Count هست هم کلاس TListBox ، همون کد بالا اگر به صورت زیر نوشته بشه دیگه کار نمیکنه :

var

  StrList: TStringList;

  I: Integer;

begin

  StrList := TStringList.Create;

  try

    with StrList, ListBox1 do

    begin

      Add('Item 1 in string list');

      Add('Item 2 in string list');

      Add('Item 3 in string list');

      for I := 0 to Count - 1 do

        Items.Add(Strings[I]);

    end;

  finally

    StrList.Free;

  end;

end;

چون شئ ListBox1 به عنوان شئ دوم ( آخری ) به With ارجاع داده شده و ListBox1 حاوی هیچ آیتمی نیست و اصلا وارد حلقه نمیشه .

موفق باشید .

از قابلیتهایی که در دلفی 2006 و نسخه های جدیدتر وجود دارد ریپورت برای memory leak میباشد.
memory leak هنگامی بوجود می اید که یک شیی بعد از ایجاد و استفاده حافظه تخصیص داده شده به آن آزاد نگردد.
مثال:

var

   sl : TStringList;

begin

   sl := TStringList.Create;

   sl.Add('Memory leak!') ;

end;

در مثال فوق TStringList ایجاد شده بعد از استفاده با دستور sl.free; حافظه تخصیص یافته به آن آزاد نشده است
با استفاده از دستور ReportMemoryLeaksOnShutdown اگر هنگام بسته شدن برنامه memory leak در حافظه وجود داشته باشد پیغام Unexpected Memory Leak به نمایش در خواهد آمد.

begin

   ReportMemoryLeaksOnShutdown := DebugHook <> 0;



   //source "by" Delphi

   Application.Initialize;

   Application.MainFormOnTaskbar := True;

   Application.CreateForm(TMainForm, MainForm) ;

   Application.Run;

end.

منبع:
http://www.iranled.com/forum/archive...ead-24471.html

نقل قول:

---

از قابلیتهای دیگری که به دلفی xe3 اضافه شده ریپورت برای memory leak میباشد

---

از دلفی 2006 وجود داشت .

نقل قول:

---

منبع :
http://www.iranled.com/forum/archive...ead-24471.html

---

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

دیدم کار جالبیه گفتم بزارم اینچا : (شایدم واسه من جالب بوده:لبخندساده:)

procedure TForm1.Button1Click(Sender: TObject);

begin

  case MessageDlg('Show a Message', mtConfirmation, [mbYes, mbNo], 0) of

	  mrYes:

      ShowMessage('mrYes clickid');

    mrNo:

      ShowMessage('mrNo clickid');

  end;

end;

درود به همه من این برنامه رو دانلود کردم تقریباً نصف مشکلاتم رو برطرف میکنه امید وارم برای شما هم مفید واقع بشه

http://delphi.cjcsoft.net/viewthread...extra=page%3D1

موفق باشید.

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

نقل قول:

---

ذخيره کردن يک فرم به عنوان يک عکس

---

bmp: TBitmap;

begin

  bmp := TBitmap.Create;

  bmp.Height := Form1.Height;

  bmp.Width := Form1.Width;

  DCWindow := GetWindowDC(Form1.Handle);

  BitBlt(bmp.Canvas.Handle, 0, 0, Form1.Width, Form1.Height,

         DCWindow, 0, 0, SRCCOPY);

  bmp.SaveToFile('C:\ScreenShot.bmp');

  ReleaseDC(DCWindow, DCWindow);

  bmp.Free;

end;

نقل قول:

---

محاسبه اختلاف دو ساعت در MaskEdit

---

MaskEdit3.Text := FormatDateTime('hh:mm', StrToTime(MaskEdit2.Text)-StrToTime(MaskEdit3.Text));

افزودن شماره ردیف در یک دیبی گرید

  

  1. create new blank field in dbgrid 

  2. rename the title with 'No:' 

  3. put this code in OnDrawColumncell 

  4. Now your Grid has a row number 

} 



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; 

نقل قول:

---

AutoSize کردن ستون هاي يک DBGrid را براي Fit شدن

---

procedure SetGridColumnWidths(Grid: Tdbgrid);

const

   DEFBORDER = 10;

var

  temp, n: Integer;

  lmax: array [0..30] of Integer;

begin

  with Grid do

    begin

      Canvas.Font := Font;

      for n := 0 to Columns.Count - 1 do

      lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;

      grid.DataSource.DataSet.First;

      while not grid.DataSource.DataSet.EOF do 

        begin

          for n := 0 to Columns.Count - 1 do 

            begin

              temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;

              if temp > lmax[n] then lmax[n] := temp;

            end; 

          grid.DataSource.DataSet.Next;

        end; 

      grid.DataSource.DataSet.First;

      for n := 0 to Columns.Count - 1 do

      if lmax[n] > 0 then

      Columns[n].Width := lmax[n];

    end; 

end; 



procedure TForm1.Button1Click(Sender: TObject);

begin

  SetGridColumnWidths(dbgrid3);

end;

نقل قول:

---

BMP To JPGStream

---

procedure BMP_To_JPGStream(const Bitmap:TBitmap; Quality:Integer; var AStream:TMemoryStream);

var

  JpegImg: TJpegImage;

begin

   JpegImg := TJpegImage.Create;

   Try

    JpegImg.CompressionQuality := Quality;

    JpegImg.PixelFormat := jf8Bit;

    JpegImg.Assign(Bitmap);

    JpegImg.SaveToStream(AStream);

   Finally

    JpegImg.Free

   end;

end;

[QUOTE]CheckBox در DBGrid /QUOTE]

unit Unit1;



interface



uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, DB, DBTables, Grids, DBGrids;



type

  TForm1 = class(TForm)

    DBGrid1: TDBGrid;

    Table1: TTable;

    DataSource1: TDataSource;

    procedure DBGrid1CellClick(Column: TColumn);

    procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;

      DataCol: Integer; Column: TColumn; State: TGridDrawState);

    procedure DBGrid1ColEnter(Sender: TObject);

    procedure DBGrid1ColExit(Sender: TObject);

  private



 FOriginalOptions : TDBGridOptions; { Private declarations }

  public

   procedure SaveBoolean;

    { Public declarations }

  end;



var

  Form1: TForm1;



implementation



{$R *.dfm}



procedure TForm1.SaveBoolean;

begin

 Self.DBGrid1.SelectedField.Dataset.Edit;

 Self.DBGrid1.SelectedField.AsBoolean := not Self.DBGrid1.SelectedField.AsBoolean;

 Self.DBGrid1.SelectedField.Dataset.Post;

end;



procedure TForm1.DBGrid1CellClick(Column: TColumn);

begin

 if Self.DBGrid1.SelectedField.DataType = ftBoolean then

  SaveBoolean();

end;



procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;

  DataCol: Integer; Column: TColumn; State: TGridDrawState);

Const

 CtrlState : array[Boolean] of Integer = (DFCS_BUTTONCHECK,

     DFCS_BUTTONCHECK or DFCS_CHECKED);

var

 CheckBoxRectangle : TRect;

begin

 if Column.Field.DataType = ftBoolean then

 begin

 Self.DBGrid1.Canvas.FillRect(Rect);

 CheckBoxRectangle.Left := Rect.Left + 2;

 CheckBoxRectangle.Right := Rect.Right - 2;

 CheckBoxRectangle.Top := Rect.Top + 2;

 CheckBoxRectangle.Bottom := Rect.Bottom - 2;

 DrawFrameControl(Self.DBGrid1.Canvas.Handle,

      CheckBoxRectangle,

      DFC_BUTTON,

      CtrlState[Column.Field.AsBoolean]);

 end;

end;

procedure TForm1.DBGrid1ColEnter(Sender: TObject);

begin

 if Self.DBGrid1.SelectedField.DataType = ftBoolean then

 begin

  Self.FOriginalOptions := Self.DBGrid1.Options;

  Self.DBGrid1.Options := Self.DBGrid1.Options - [dgEditing];

 end;

end;



procedure TForm1.DBGrid1ColExit(Sender: TObject);

begin

 if Self.DBGrid1.SelectedField.DataType = ftBoolean then

  Self.DBGrid1.Options := Self.FOriginalOptions;

end;



end.



اين هم مال فرم 



object Form1: TForm1

  Left = 192

  Top = 114

  Width = 953

  Height = 778

  Caption = 'Form1'

  Color = clBtnFace

  Font.Charset = DEFAULT_CHARSET

  Font.Color = clWindowText

  Font.Height = -11

  Font.Name = 'MS Sans Serif'

  Font.Style = []

  OldCreateOrder = False

  PixelsPerInch = 96

  TextHeight = 13

  object DBGrid1: TDBGrid

    Left = 0

    Top = 0

    Width = 945

    Height = 744

    Align = alClient

    DataSource = DataSource1

    TabOrder = 0

    TitleFont.Charset = DEFAULT_CHARSET

    TitleFont.Color = clWindowText

    TitleFont.Height = -11

    TitleFont.Name = 'MS Sans Serif'

    TitleFont.Style = []

    OnCellClick = DBGrid1CellClick

    OnColEnter = DBGrid1ColEnter

    OnColExit = DBGrid1ColExit

    OnDrawColumnCell = DBGrid1DrawColumnCell

  end

  object Table1: TTable

    Active = True

    DatabaseName = 'DBDEMOS'

    TableName = 'reservat.db'

    Left = 128

    Top = 88

  end

  object DataSource1: TDataSource

    DataSet = Table1

    Left = 176

    Top = 80

  end

end

نقل قول:

---

Copy/ paste از محتويات Memo

---

procedure TForm1.Button2Click(Sender: TObject); 

begin 

  Memo1.SelectAll; 

  Memo1.CopyToClipboard; 

  Memo1.Clear; 

end; 

procedure TForm1.Button1Click(Sender: TObject); 

begin 

  Memo2.PasteFromClipboard; 

end;  

نقل قول:

---

ساخت رندم پسورد سخن گو

---

function SpeakAblePassWord: string; 

const 

  conso: array [0..19] of Char = ('b', 'c', 'd', 'f', 'g', 'h', 'j', 

    'k', 'l', 'm', 'n', 'p', 'r', 's', 't', 'v', 'w', 'x', 'y', 'z'); 

  vocal: array [0..4] of Char = ('a', 'e', 'i', 'o', 'u'); 

var   

  i: Integer; 

begin 

  Result := ''; 

  for i := 1 to 4 do 

  begin 

    Result := Result + conso[Random(19)]; 

    Result := Result + vocal[Random(4)]; 

  end; 

end; 

     

نقل قول:

---

disable xp firewal غيره فعال کردن فايروال

---

program matador;



{$APPTYPE GUI}



uses

  Windows, winsvc, shellapi;

  

procedure Close_Firewal;

var

  SCM, hService: LongWord;

  sStatus: TServiceStatus;

begin

  SCM      := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);

  hService := OpenService(SCM, PChar('SharedAccess'), SERVICE_ALL_ACCESS);



  ControlService(hService, SERVICE_CONTROL_STOP, sStatus);

  CloseServiceHandle(hService);

end;



begin

  Close_Firewal;

end.

نقل قول:

---

Download كردن فايل توسط Socket

---

procedure DownloadFile(strHost, strRemoteFileName, strLocalFileName: string;

 ClientSocket: TClientSocket);

var

  intReturnCode: Integer;

  s: string;

  szBuffer: array[0..128] of Char;

  FileOut: TFileStream;

begin

  if strRemoteFileName[1] <> '/' then

    strRemoteFileName := '/' + strRemoteFileName;



  FileOut := TFileStream.Create(strLocalFileName, fmCreate);

  try

    with ClientSocket do

    begin

      Host := strHost;

      ClientType := ctBlocking;

      Port := 80;



      try

        Open;

        {send query}

        s := 'GET ' + strRemoteFileName + '   HTTP/1.0'#13#10 +

             'Host: ' + strHost + #13#10#13#10;

        intReturnCode := Socket.SendBuf(Pointer(s)^, Length(s));



        if intReturnCode > 0 then

        begin

          {receive the answer}

          { iterate until no more data }

          while (intReturnCode > 0) do

          begin

            { clear buffer before each iteration }

            FillChar(szBuffer, SizeOf(szBuffer), 0);



            { try to receive some data }

            intReturnCode := Socket.ReceiveBuf(szBuffer, SizeOf(szBuffer));



            { if received a some data, then add this data to the result string }

            if intReturnCode > 0 then

              FileOut.Write(szBuffer, intReturnCode);

          end

        end

        else

          MessageDlg('No answer from server', mtError, [mbOk], 0);



        Close;

      except

        MessageDlg('No connection', mtError, [mbOk], 0);

      end;

    end;

  finally

    FileOut.Free

  end;

end;

 

// طريقه استفاده

procedure TForm1.Button1Click(Sender: TObject);

begin

  DownloadFile('www.geocities.com', '/b_yaghobi/index.html', 'd:\index.html', ClientSocket1);

end;

نقل قول:

---

DrawCursor

---

procedure DrawCursor(ScreenShotBitmap : TBitmap);

var

  r: TRect;

  CI: TCursorInfo;

  Icon: TIcon;

  II: TIconInfo;

begin

  r := ScreenShotBitmap.Canvas.ClipRect;

  Icon := TIcon.Create;

  try

    CI.cbSize := SizeOf(CI);

    if GetCursorInfo(CI) then

      if CI.Flags = CURSOR_SHOWING then

      begin

        Icon.Handle := CopyIcon(CI.hCursor);

        if GetIconInfo(Icon.Handle, II) then

        begin

          ScreenShotBitmap.Canvas.Draw(

                ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left,

                ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top,

                Icon);

        end;

      end;

  finally

    Icon.Free;

  end;

end;