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

**Esmail Solhkhah** · شنبه 22 مرداد 1390, 04:11 صبح

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;

**Esmail Solhkhah** · شنبه 22 مرداد 1390, 04:21 صبح

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

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

**Esmail Solhkhah** · شنبه 22 مرداد 1390, 04:24 صبح

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

**Esmail Solhkhah** · یک شنبه 23 مرداد 1390, 02:30 صبح

Gradient-Panel with 6 Main-Propertys

**hector2000** · دوشنبه 02 آبان 1390, 09:37 صبح

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

**تجلی** · پنج شنبه 08 دی 1390, 14:11 عصر

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

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

**lord_viper** · دوشنبه 12 دی 1390, 09:18 صبح

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



 {$IFDEF DEBUG}

    ShowMessage('Debuger Found');

{$ENDIF}

**یوسف زالی** · دوشنبه 12 دی 1390, 09:31 صبح

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

**BORHAN TEC** · دوشنبه 12 دی 1390, 10:40 صبح

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

**lord_viper** · دوشنبه 12 دی 1390, 13:07 عصر

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

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

**mbshareat** · دوشنبه 04 اردیبهشت 1391, 18:14 عصر

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

Var

  S:String;

begin

  S:=Memo1.Text;

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

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

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

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

  S:=StringReplace(S,'&#93;',']',[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;

ValidCode.rar

**AliReza Vafakhah** · یک شنبه 11 تیر 1391, 02:02 صبح

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

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

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

**BORHAN TEC** · جمعه 19 آبان 1391, 20:15 عصر

سلام
همه شما با دستور 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

**Felony** · جمعه 19 آبان 1391, 21:17 عصر

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

سلام
همه شما با دستور 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 حاوی هیچ آیتمی نیست و اصلا وارد حلقه نمیشه .

موفق باشید .

**BORHAN TEC** · چهارشنبه 24 آبان 1391, 02:13 صبح

از قابلیتهایی که در دلفی 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

**Felony** · چهارشنبه 24 آبان 1391, 05:21 صبح

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

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

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

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

**Mask** · چهارشنبه 01 آذر 1391, 20:55 عصر

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

)

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;

**بهروز عباسی** · چهارشنبه 15 آذر 1391, 10:48 صبح

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

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

موفق باشید.

**gholami146** · سه شنبه 24 بهمن 1391, 12:42 عصر

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

**gholami146** · سه شنبه 24 بهمن 1391, 12:43 عصر

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

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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:44 عصر

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

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

**gholami146** · سه شنبه 24 بهمن 1391, 12:45 عصر

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

  

  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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:45 عصر

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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:46 عصر

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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:47 عصر

[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

**gholami146** · سه شنبه 24 بهمن 1391, 12:47 عصر

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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:48 عصر

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



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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:48 عصر

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.

**gholami146** · سه شنبه 24 بهمن 1391, 12:49 عصر

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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:50 عصر

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;

**gholami146** · سه شنبه 24 بهمن 1391, 12:50 عصر

Encrypt / decrypt passwords



const 

  Codes64 = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklm  nopqrstuvwxyz+/'; 



function GeneratePWDSecutityString: string; 

var 

  i, x: integer; 

  s1, s2: string; 

begin 

  s1 := Codes64; 

  s2 := ''; 

  for i := 0 to 15 do 

  begin 

    x  := Random(Length(s1)); 

    x  := Length(s1) - x; 

    s2 := s2 + s1[x]; 

    s1 := Copy(s1, 1,x - 1) + Copy(s1, x + 1,Length(s1)); 

  end; 

  Result := s2; 

end; 



function MakeRNDString(Chars: string; Count: Integer): string; 

var 

  i, x: integer; 

begin 

  Result := ''; 

  for i := 0 to Count - 1 do 

  begin 

    x := Length(chars) - Random(Length(chars)); 

    Result := Result + chars[x]; 

    chars := Copy(chars, 1,x - 1) + Copy(chars, x + 1,Length(chars)); 

  end; 

end; 



function EncodePWDEx(Data, SecurityString: string; MinV: Integer = 0; 

  MaxV: Integer = 5): string; 

var 

  i, x: integer; 

  s1, s2, ss: string; 

begin 

  if minV > MaxV then 

  begin 

    i := minv; 

    minv := maxv; 

    maxv := i; 

  end; 

  if MinV < 0 then MinV := 0; 

  if MaxV > 100 then MaxV := 100; 

  Result := ''; 

  if Length(SecurityString) < 16 then Exit; 

  for i := 1 to Length(SecurityString) do 

  begin 

    s1 := Copy(SecurityString, i + 1,Length(securitystring)); 

    if Pos(SecurityString[i], s1) > 0 then Exit; 

    if Pos(SecurityString[i], Codes64) <= 0 then Exit; 

  end; 

  s1 := Codes64; 

  s2 := ''; 

  for i := 1 to Length(SecurityString) do 

  begin 

    x := Pos(SecurityString[i], s1); 

    if x > 0 then s1 := Copy(s1, 1,x - 1) + Copy(s1, x + 1,Length(s1)); 

  end; 

  ss := securitystring; 

  for i := 1 to Length(Data) do 

  begin 

    s2 := s2 + ss[Ord(Data[i]) mod 16 + 1]; 

    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1); 

    s2 := s2 + ss[Ord(Data[i]) div 16 + 1]; 

    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1); 

  end; 

  Result := MakeRNDString(s1, Random(MaxV - MinV) + minV + 1); 

  for i := 1 to Length(s2) do Result := Result + s2[i] + MakeRNDString(s1, 

      Random(MaxV - MinV) + minV); 

end; 



function DecodePWDEx(Data, SecurityString: string): string; 

var 

  i, x, x2: integer; 

  s1, s2, ss: string; 

begin 

  Result := #1; 

  if Length(SecurityString) < 16 then Exit; 

  for i := 1 to Length(SecurityString) do 

  begin 

    s1 := Copy(SecurityString, i + 1,Length(securitystring)); 

    if Pos(SecurityString[i], s1) > 0 then Exit; 

    if Pos(SecurityString[i], Codes64) <= 0 then Exit; 

  end; 

  s1 := Codes64; 

  s2 := ''; 

  ss := securitystring; 

  for i := 1 to Length(Data) do if Pos(Data[i], ss) > 0 then s2 := s2 + Data[i]; 

  Data := s2; 

  s2   := ''; 

  if Length(Data) mod 2 <> 0 then Exit; 

  for i := 0 to Length(Data) div 2 - 1 do 

  begin 

    x := Pos(Data[i * 2 + 1], ss) - 1; 

    if x < 0 then Exit; 

    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1); 

    x2 := Pos(Data[i * 2 + 2], ss) - 1; 

    if x2 < 0 then Exit; 

    x  := x + x2 * 16; 

    s2 := s2 + chr(x); 

    ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1); 

  end; 

  Result := s2; 

end;

**gholami146** · سه شنبه 24 بهمن 1391, 12:51 عصر

highlight كردن متن درون Twebbrowser



{....} 



private 

  procedure SearchAndHighlightText(aText: string); 

     

{....}                                                                                                                      



uses mshtml; 



{ .... } 





procedure TForm1.SearchAndHighlightText(aText: string); 

var 

  tr: IHTMLTxtRange; //TextRange Object 

begin 

  if not WebBrowser1.Busy then 

  begin 

    tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange; 

    //Get a body with IHTMLDocument2 Interface and then a TextRang obj. with IHTMLBodyElement Intf. 



    while tr.findText(aText, 1, 0) do //while we have result 

    begin 

      tr.pasteHTML('&lt;span style="background-color: Lime; font-weight: bolder;">' + 

        tr.htmlText + '&lt;/span>'); 

      //Set the highlight, now background color will be Lime 

      tr.scrollIntoView(True); 

      //When IE find a match, we ask to scroll the window... you dont need this... 

    end; 

  end; 

end; 



// Example: 

procedure TForm1.Button1Click(Sender: TObject); 

begin 

  SearchAndHighlightText('delphi'); 

end;

**gholami146** · سه شنبه 24 بهمن 1391, 12:52 عصر

Hook كردن ماوس



...

type

  TMessageList = class(TList);



var

  Form1: TForm1;

  MessageList: TMessageList = nil;

  MessageBuffer: TEventMsg;

  HookHandle: hHook = 0;

  MessageCount: Word = 0;

  Go: Boolean = False;

  Pan: array[0..5] of TPanel;



implementation



{$R *.DFM}



procedure Stop;

begin

  if Go then UnHookWindowsHookEx(HookHandle);

  MessageList.Free;

  Go:=False;

end;



function FBack(Code: Integer; wParam, lParam: LongInt): LongInt; stdcall;

begin

  Inc(MessageCount);

  Randomize;

  if MessageCount>=MessageList.Count then Stop

  else MessageBuffer:=TEventMsg(MessageList.Items[MessageCount]^);

  Result:=CallNextHookEx(HookHandle, Code, wParam, lParam);

  Pan[MessageCount].Color:=RGB(Random(255), Random(255), Random(255))

end;



procedure SetHook;

begin

  MessageBuffer:=TEventMsg(MessageList.Items[0]^);

  MessageCount:=0;

  HookHandle:=SetWindowsHookEx(WH_MOUSE, FBack, hInstance, 0);

  Go:=True;

end;



procedure MakeMessage(Mes: Cardinal);

var

  MyEvent: PEventMsg;

begin

  New(MyEvent);

  with MyEvent^ do

  begin

    message:=Mes;

    ParamL:=50;

    ParamH:=50;

    Time:=GetTickCount;

    hWnd:=Form1.Handle;

  end;

  MessageList.Add(MyEvent);

end;



function SendMouse: Integer;

begin

  try

    MessageList:=TMessageList.Create;

    MakeMessage(WM_RBUTTONDOWN);

    MakeMessage(WM_RBUTTONUP);

    SetHook;      // set hook

  except

  end;

  Result:=0;

end;



procedure TForm1.Button1Click(Sender: TObject);

begin

  Pan[1]:=Panel1;

  Pan[2]:=Panel2;

  SendMouse;

end;

**gholami146** · سه شنبه 24 بهمن 1391, 12:53 عصر

Map كردن درايوهاي شبكه



WNetConnectionDialog(0,RESOURCETYPE_DISK );

**gholami146** · سه شنبه 24 بهمن 1391, 12:53 عصر

MD5 in Delphi



function md5(const Input: String): String;

var

  hCryptProvider: HCRYPTPROV;

  hHash: HCRYPTHASH;

  bHash: array[0..$7f] of Byte;

  dwHashBytes: Cardinal;

  pbContent: PByte;

  i: Integer;



begin

  dwHashBytes := 16;

  pbContent := Pointer(PChar(Input));



  Result := '';



  if CryptAcquireContext(@hCryptProvider, nil, nil, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT or CRYPT_MACHINE_KEYSET) then

  begin

    if CryptCreateHash(hCryptProvider, CALG_MD5, 0, 0, @hHash) then

    begin

      if CryptHashData(hHash, pbContent, Length(Input) * sizeof(Char), 0) then

      begin

        if CryptGetHashParam(hHash, HP_HASHVAL, @bHash[0], @dwHashBytes, 0) then

        begin

          for i := 0 to dwHashBytes - 1 do

          begin

            Result := Result + Format('%.2x', [bHash[i]]);

          end;

        end;

      end;

      CryptDestroyHash(hHash);

    end;



    CryptReleaseContext(hCryptProvider, 0);

  end;



  Result := AnsiLowerCase(Result);

end;

**gholami146** · سه شنبه 24 بهمن 1391, 12:54 عصر

minimize كردن كليه پنجره ها



unit Unit1;

interface

uses

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

  Dialogs, StdCtrls;

type

  TForm1 = class(TForm)

    Button1: TButton;

    procedure Button1Click(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

 function EnumWinProc(Wnd : HWND) : Boolean; Export; StdCall;

 var

   WinText : Array[0..255] of Char;

 begin

   GetWindowText(Wnd, WinText, 255);

   Result := True;

   if (StrPas(WinText) <> '') and

      IsWindowVisible(Wnd) and

      (Wnd<>Application.Handle) and

      (Wnd<>Form1.Handle)

      then

        CloseWindow(Wnd);

 end;



procedure TForm1.Button1Click(Sender: TObject);

begin

  EnumWindows(@EnumWinProc, LongInt(Self));

end;

end.

**gholami146** · سه شنبه 24 بهمن 1391, 12:55 عصر

MultiSelect كردن در DBGrid



procedure TForm1.Button1Click(Sender: TObject);

var

  X: Word;

  TempBookmark: TBookMark;

begin

  with DBGrid1.DataSource.DataSet do

  begin

    DisableControls;

    with DBGrid1.SelectedRows do

      if Count<>0 then

      begin

        TempBookmark:=GetBookmark;

        for X:=0 to Count-1 do

        begin

          if IndexOf(Items[X])>-1 then

          begin

            Bookmark:=Items[X];

            ShowMessage(Fields[1].AsString);

          end;

        end;

      end;

    GotoBookmark(TempBookmark);

    FreeBookmark(TempBookmark);

    EnableControls;

  end;

end;

**gholami146** · سه شنبه 24 بهمن 1391, 12:55 عصر

print گرفتن فايل Word از داخل برنامه



var

  oWord : TWordApplication;

  varFileName : OleVariant;

begin

  oWord := TWordApplication.Create (Nil);

  Try

    oWord.Connect;

    varFileName := 'c:\temp\test.doc';

    oWord.Documents.Open (varFileName,EmptyParam,EmptyParam,

                          EmptyParam,EmptyParam,EmptyParam,

                          EmptyParam,EmptyParam,EmptyParam,

                          EmptyParam);

    oWord.ActiveDocument.PrintOut (EmptyParam,EmptyParam,EmptyParam,

                                   EmptyParam,EmptyParam,EmptyParam,

                                   EmptyParam,EmptyParam,EmptyParam,

                                   EmptyParam,EmptyParam,EmptyParam,

                                   EmptyParam,EmptyParam);

    oWord.Disconnect;                      

  Finally

    oWord.Free;

  End;

end;

**gholami146** · سه شنبه 24 بهمن 1391, 12:56 عصر

Register a OCX File



uses 

  OLECtl; 

var 

  OCXHandle: THandle; 

  RegFunc: TDllRegisterServer; 

begin 

  OCXHandle := LoadLibrary ('C:\Windows\System\custom.ocx'); 

  RegFunc := GetProcAddress (OCXHandle, 'DllRegisterServer'); 

  if RegFunc <> 0 then 

    ShowMessage('Error!'); 

  FreeLibrary (OCXHandle); 

end;

**gholami146** · سه شنبه 24 بهمن 1391, 12:56 عصر

ScreenShot عکس گرفتن از صفحه نمايش



procedure ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);

var

  dc: HDC; lpPal : PLOGPALETTE;

begin

{test width and height}

  if ((Width = 0) OR (Height = 0)) then exit;

  bm.Width := Width;

  bm.Height := Height;

{get the screen dc}

  dc := GetDc(0);

  if (dc = 0) then exit;

{do we have a palette device?}

  if (GetDeviceCaps(dc, RASTERCAPS) AND RC_PALETTE = RC_PALETTE) then

  begin

    {allocate memory for a logical palette}

    GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));

    {zero it out to be neat}

    FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);

    {fill in the palette version}

    lpPal^.palVersion := $300;

    {grab the system palette entries}

    lpPal^.palNumEntries :=GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEn  try);

    if (lpPal^.PalNumEntries <> 0) then

    begin

      {create the palette}

      bm.Palette := CreatePalette(lpPal^);

    end;

    FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));

  end;

  {copy from the screen to the bitmap}

  BitBlt(bm.Canvas.Handle,0,0,Width,Height,Dc,x,y,SR  CCOPY);

  {release the screen dc}

  ReleaseDc(0, dc);

end;

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

ابزار های تاپیک

نمایش

فرستادن فایل به سطل آشغال

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

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

Gradient-Panel with 6 Main-Propertys

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

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

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

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

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

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

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

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

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

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

نمایش Memory Leak در Delphi 2006 به بعد

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

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

بیش از 6000 نکته و سورس کد برای دلفی

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

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

نقل قول: دریافت کد های برنامه نویسی از پیش نوشته شده برای دلفی

برچسب های این تاپیک

قوانین ایجاد تاپیک در تالار