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

[gholami146]

Scroll كردن Image با Scrollbars

var

  MyBitmap: TBitmap;

...



procedure TForm1.ScrollBar2Change(Sender: TObject);

var

  RectDest, RectSource: TRect;

begin

  RectDest:=Rect(0, 0, Image1.Width, Image1.Height);

  RectSource:=Rect(

    ScrollBar1.Position, 

    ScrollBar2.Position, 

    Scrollbar1.Position+Image1.Width, 

    ScrollBar2.Position+Image1.Height);

  Image1.Canvas.CopyRect(RectDest, MyBitmap.Canvas, RectSource);

end;



procedure TForm1.FormCreate(Sender: TObject);

begin

  MyBitmap:=TBitmap.Create;

  MyBitmap.LoadFromFile('C:\pict.bmp');

  Image1.Picture.Bitmap.Assign(MyBitmap);

  ScrollBar1.Max:=MyBitmap.Width-1-Image1.Width;

  ScrollBar2.Max:=MyBitmap.Height-1-Image1.Height;

end;     

[gholami146]

Select a random data record

procedure TForm1.Button1Click(Sender: TObject); 

begin 

  Randomize; 

  Table1.First; 

  Table1.MoveBy(Random(Table1.RecordCount)); 

end;

[gholami146]

ارسال ایمیل از طریق OutLook با ارسال پارامتر

uses 

  ComObj; 



procedure TForm1.Button16Click(Sender: TObject); 

const 

  olMailItem = 0; 

  olByValue = 1; 

var 

  OutlookApp, MailItem, MyAttachments: OLEVariant; 

begin 

  try 

    OutlookApp := GetActiveOleObject('Outlook.Application'); 

  except 

    OutlookApp := CreateOleObject('Outlook.Application'); 

  end; 

  try 

    MailItem := OutlookApp.CreateItem(olMailItem); 

    MailItem.Recipients.Add('YourMailAddress@something  .com'); 

    MailItem.Subject := 'Your Subject'; 

    MailItem.Body    := 'Your Message'; 

    myAttachments    := MailItem.Attachments; 

    myAttachments.Add('C:\text.txt', olByValue, 1, 'Name of Attachment'); 

    MailItem.Send; 

  finally 

    myAttachments := VarNull; 

    OutlookApp    := VarNull; 

  end; 

end;

[gholami146]

Simple Encryption/ Decryption for short strings

function Encrypt (const s: string; Key: Word) : string; 

var 

i : byte; 

ResultStr : string; 

begin 

Result:=s; 

{Result[0] := s[0]; } 

for i := 0 to (length (s)) do 

begin 

Result[i] := Char (byte (s[i]) xor (Key shr 8)); 

Key := (byte (Result[i]) + Key) * c1 + c2 

end 

end; 



function Decrypt (const s: string; Key: Word) : string; 

var 

i : byte; 

begin 

{Result[0] := s[0];} 

Result:=s; 

for i := 0 to (length (s)) do 

begin 

Result[i] := Char (byte (s[i]) xor (Key shr 8)); 

Key := (byte (s[i]) + Key) * c1 + c2 

end 

end; 

[gholami146]

Start كردن سرويسهاي ويندوز

uses WinSvc;



//

// start service

//

// return TRUE if successful

//

// sMachine:

//   machine name, ie: \\SERVER

//   empty = local machine

//

// sService

//   service name, ie: Alerter

//

function ServiceStart(

  sMachine,

  sService : string ) : boolean;

var

  //

  // service control

  // manager handle

  schm,

  //

  // service handle

  schs   : SC_Handle;

  //

  // service status

  ss     : TServiceStatus;

  //

  // temp char pointer

  psTemp : PChar;

  //

  // check point

  dwChkP : DWord;

begin

  ss.dwCurrentState := -1;

  

  // connect to the service

  // control manager

  schm := OpenSCManager(

    PChar(sMachine),

    Nil,

    SC_MANAGER_CONNECT);



  // if successful...

  if(schm > 0)then

  begin

    // open a handle to

    // the specified service

    schs := OpenService(

      schm,

      PChar(sService),

      // we want to

      // start the service and

      SERVICE_START or

      // query service status

      SERVICE_QUERY_STATUS);



    // if successful...

    if(schs > 0)then

    begin

      psTemp := Nil;

      if(StartService(

           schs,

           0,

           psTemp))then

      begin

        // check status

        if(QueryServiceStatus(

             schs,

             ss))then

        begin

          while(SERVICE_RUNNING

            <> ss.dwCurrentState)do

          begin

            //

            // dwCheckPoint contains a

            // value that the service

            // increments periodically

            // to report its progress

            // during a lengthy

            // operation.

            //

            // save current value

            //

            dwChkP := ss.dwCheckPoint;



            //

            // wait a bit before

            // checking status again

            //

            // dwWaitHint is the

            // estimated amount of time

            // the calling program

            // should wait before calling

            // QueryServiceStatus() again

            //

            // idle events should be

            // handled here...

            //

            Sleep(ss.dwWaitHint);



            if(not QueryServiceStatus(

                 schs,

                 ss))then

            begin

              // couldn't check status

              // break from the loop

              break;

            end;



            if(ss.dwCheckPoint <

              dwChkP)then

            begin

              // QueryServiceStatus

              // didn't increment

              // dwCheckPoint as it

              // should have.

              // avoid an infinite

              // loop by breaking

              break;

            end;

          end;

        end;

      end;



      // close service handle

      CloseServiceHandle(schs);

    end;



    // close service control

    // manager handle

    CloseServiceHandle(schm);

  end;



  // return TRUE if

  // the service status is running

  Result :=

    SERVICE_RUNNING =

      ss.dwCurrentState;

end;  



// ***************  مثال ***********

if( ServiceStart('\\ComputerName','alerter' ) )then

begin

  // "alerter" service on \

[gholami146]

Stop كردن سرويسهاي ويندوز

//

// stop service

//

// return TRUE if successful

//

// sMachine:

//   machine name, ie: \\SERVER

//   empty = local machine

//

// sService

//   service name, ie: Alerter

//

function ServiceStop(

  sMachine,

  sService : string ) : boolean;

var

  //

  // service control

  // manager handle

  schm,

  //

  // service handle

  schs   : SC_Handle;

  //

  // service status

  ss     : TServiceStatus;

  //

  // check point

  dwChkP : DWord;

begin

  // connect to the service

  // control manager

  schm := OpenSCManager(

    PChar(sMachine),

    Nil,

    SC_MANAGER_CONNECT);



  // if successful...

  if(schm > 0)then

  begin

    // open a handle to

    // the specified service

    schs := OpenService(

      schm,

      PChar(sService),

      // we want to

      // stop the service and

      SERVICE_STOP or

      // query service status

      SERVICE_QUERY_STATUS);



    // if successful...

    if(schs > 0)then

    begin

      if(ControlService(

           schs,

           SERVICE_CONTROL_STOP,

           ss))then

      begin

        // check status

        if(QueryServiceStatus(

             schs,

             ss))then

        begin

          while(SERVICE_STOPPED

            <> ss.dwCurrentState)do

          begin

            //

            // dwCheckPoint contains a

            // value that the service

            // increments periodically

            // to report its progress

            // during a lengthy

            // operation.

            //

            // save current value

            //

            dwChkP := ss.dwCheckPoint;



            //

            // wait a bit before

            // checking status again

            //

            // dwWaitHint is the

            // estimated amount of time

            // the calling program

            // should wait before calling

            // QueryServiceStatus() again

            //

            // idle events should be

            // handled here...

            //

            Sleep(ss.dwWaitHint);



            if(not QueryServiceStatus(

                 schs,

                 ss))then

            begin

              // couldn't check status

              // break from the loop

              break;

            end;



            if(ss.dwCheckPoint <

              dwChkP)then

            begin

              // QueryServiceStatus

              // didn't increment

              // dwCheckPoint as it

              // should have.

              // avoid an infinite

              // loop by breaking

              break;

            end;

          end;

        end;

      end;



      // close service handle

      CloseServiceHandle(schs);

    end;



    // close service control

    // manager handle

    CloseServiceHandle(schm);

  end;



  // return TRUE if

  // the service status is stopped

  Result :=

    SERVICE_STOPPED =

      ss.dwCurrentState;

end;

[gholami146]

از کد زير مي توانيد وجود يا عدم وجود ماوس را تشخيص دهيد

procedure TForm1.Button1Click(Sender: TObject);

begin

  if GetSystemMetrics(SM_MOUSEPRESENT)<>0 then

    Label1.Caption:='You have a mouse'

  else

    Label1.Caption:='You have not a mouse';

end;

[gholami146]

اتصال به اينترنت با کانکشن پيش فرض

uses

wininet;



procedure TForm1.DisconnectClick(Sender: TObject);

var

dwConnectionTypes:dword;

begin

dwConnectionTypes:=INTERNET_CONNECTION_MODEM+

INTERNET_CONNECTION_LAN+

INTERNET_CONNECTION_PROXY;

if InternetGetConnectedState(@dwConnectionTypes,0) then

InternetAutodialHangup(0);

end;



procedure TForm1.ConnectClick(Sender: TObject);

var

dwConnectionTypes:dword;

begin

dwConnectionTypes:=INTERNET_CONNECTION_MODEM+



INTERNET_CONNECTION_LAN+INTERNET_CONNECTION_PROXY;

if not InternetGetConnectedState(@dwConnectionTypes,0) then

if not InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE or

INTERNET_AUTODIAL_FORCE_UNATTENDED,0) then

begin

end;





end

[gholami146]

اجرا برنامه Word و باز کردن يک فايل

Var

MSWord : Variant 



procedure TTMDtlForm.ExecuteTheMacro;

var

   WHandle : HWnd;

begin

   try

       // If file selected

       If OpenDialog1.execute Then

       begin

           // Set Flag to False

           FoundWord:=False;



           try

             // If word is already running, obtain a link and set flag to true

             MsWord := GetActiveOleObject('Word.Basic');

             FoundWord := True;

           except

             try

                // Start new instance of word and set flag to True

                MsWord := CreateOleObject('Word.Basic');

                FoundWord := True;

             except

                // Display error message

                ShowMessage('Could not start word');

             end;

           end;



           // If Link established

           if FoundWord then

           begin

              try

                 MsWord.AppShow;

                 MsWord.ScreenUpdating(0);

                 MSWord.FileOpen(OpenDialog1.FileName);

                 MsWord.ScreenUpdating(1);

                 MsWord.ScreenRefresh;



                 // Maximize and bring Word to front

                 WHandle := FindWindow('OpusApp',Nil);

                 if isWindow(WHandle) then

                    ShowWindow(WHandle,SW_SHOWMAXIMIZED);

              except

                 MessageDlg('TF - Error in Word Basic',mtError,[mbOK],0);

                 MsWord.ScreenUpdating(1);

              end;

           end;

       end;

   finally

   end;

end;

[gholami146]

اجراي فايل ها با برنامه هاي خودشان

uses

  Shellapi;



function StartAssociatedExe(FileName: string; var ErrorCode:



 Cardinal): Boolean;

 



var

  Prg: string;   

  ProcessInfo: TProcessInformation;

  StartupInfo: TStartupInfo;

begin

  SetLength(Prg, MAX_PATH);

  Result := False;

  ErrorCode := FindExecutable(PChar(FileName), nil,



 PChar(Prg));

  if ErrorCode >= 32 then

  begin

    SetLength(Prg, StrLen(PChar(Prg)));

    FillChar(StartupInfo, SizeOf(TStartupInfo), 0);

    with StartupInfo do

    begin

      cb := SizeOf(TStartupInfo);

      wShowWindow := SW_SHOW;

    end;

    if CreateProcess(PChar(Prg), PChar(Format('%s %s', [Prg, FileName])),

      nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, 



StartupInfo, ProcessInfo) then





    begin

      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);

      GetExitCodeProcess(ProcessInfo.hProcess, ErrorCode);

      CloseHandle(ProcessInfo.hProcess);

      CloseHandle(ProcessInfo.hThread);

      Result := True;

    end

    else

      ErrorCode := GetLastError;

  end;

end;



--------------------------------------------------------



procedure TForm1.Button1Click(Sender: TObject);

var

  ErrorCode: Cardinal;

begin

  StartAssociatedExe('c:\delphi_learn.pdf', ErrorCode);

end;

[gholami146]

اجراي يك برنامه و منتظر شدن براي خاتمه آن

function ExecutePrg(const CmdLine: String; const Wait: boolean): boolean;

var

  LastError: Integer;

  ExitCode: Cardinal ;

  StartupInfo: TStartupInfo;

  ProcessInfo: TProcessInformation;

begin

  FillChar(StartupInfo,Sizeof(StartupInfo),#0);

  StartupInfo.cb := Sizeof(StartupInfo);

  StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;

  StartupInfo.wShowWindow := SW_SHOWNORMAL;

  Result := CreateProcess(nil,                                                // ptr to name of executable module

                          PChar(CmdLine),                                     // ptr to command line string

                          nil,                                                // ptr to process security attributes

                          nil,                                                // ptr to thread  security attributes

                          false,                                              // handle inheritance flag

                          CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,        // creation flags

                          nil,                                                // ptr to new environment block

                          nil,                                                // ptr to current directory name

                          StartupInfo,                                        // ptr to STARTUPINFO

                          ProcessInfo);                                       // ptr to PROCESS_INFORMATION

  if Result then

    begin

      if Wait then

        begin

          repeat

            Application.ProcessMessages;

            GetExitCodeProcess(ProcessInfo.hProcess, ExitCode);

          until (ExitCode <> STILL_ACTIVE);

        end;

    end

  else

    begin

      LastError := GetLastError;

      MessageDlg(SysErrorMessage(LastError) +'  (Error: ' +IntToStr(LastError) +')', mtError, [mbOK], 0);

    end;

end;



//*************************************  or *********************

Function ExecuteAndWait(sExecutableFile : String) : Boolean;

var

         siInfo  : TStartUpInfo;

         piInfo  : TProcessInformation;

begin

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



         with siInfo do begin

              cb          := SizeOf(siInfo);

              dwFlags     := STARTF_USESHOWWINDOW;

              wShowWindow := SW_SHOWNORMAL;

         end;

         Result := CreateProcess(NIL, pChar(sExecutableFile), NIL, NIL, FALSE, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, NIL, pchar(ExtractFilePath(sExecutableFile)),siInfo, piInfo);

         if Result then

            WaitForSingleObject(piInfo.hprocess,INFINITE);

end;

[gholami146]

اجراي يک برنامه تحت Dos با نمايش خروجي آن

procedure RunDosInMemo(Que:String;EnMemo:TMemo);

  const

     CUANTOBUFFER = 2000;

  var

    Seguridades         : TSecurityAttributes;

    PaLeer,PaEscribir   : THandle;

    start               : TStartUpInfo;

    ProcessInfo         : TProcessInformation;

    Buffer              : Pchar;

    BytesRead           : DWord;

    CuandoSale          : DWord;

  begin

    with Seguridades do

    begin

      nlength              := SizeOf(TSecurityAttributes);

      binherithandle       := true;

      lpsecuritydescriptor := nil;

    end;

    {Creamos el pipe...}

    if Createpipe (PaLeer, PaEscribir, @Seguridades, 0) then

    begin

      Buffer  := AllocMem(CUANTOBUFFER + 1);

      FillChar(Start,Sizeof(Start),#0);

      start.cb          := SizeOf(start);

      start.hStdOutput  := PaEscribir;

      start.hStdInput   := PaLeer;

      start.dwFlags     := STARTF_USESTDHANDLES +

                           STARTF_USESHOWWINDOW;

      start.wShowWindow := SW_HIDE;

 

      if CreateProcess(nil,

         PChar(Que),

         @Seguridades,

         @Seguridades,

         true,

         NORMAL_PRIORITY_CLASS,

         nil,

         nil,

         start,

         ProcessInfo)

      then

        begin

          {Espera a que termine la ejecucion}

          repeat

            CuandoSale := WaitForSingleObject( ProcessInfo.hProcess,100);

            Application.ProcessMessages;

          until (CuandoSale <> WAIT_TIMEOUT);

          {Leemos la Pipe}

          repeat

            BytesRead := 0;

            {Llenamos un troncho de la pipe, igual a nuestro buffer}

            ReadFile(PaLeer,Buffer[0],CUANTOBUFFER,BytesRead,nil);

            {La convertimos en una string terminada en cero}

            Buffer[BytesRead]:= #0;

            {Convertimos caracteres DOS a ANSI}

            OemToAnsi(Buffer,Buffer);

            EnMemo.Text := EnMemo.text + String(Buffer);

          until (BytesRead < CUANTOBUFFER);

        end;

      FreeMem(Buffer);

      CloseHandle(ProcessInfo.hProcess);

      CloseHandle(ProcessInfo.hThread);

      CloseHandle(PaLeer);

      CloseHandle(PaEscribir);

    end;

  end;



 



به عنوان مثال:



  RunDosInMemo('chkdsk.exe c:\',Memo1);

[gholami146]

ارسال اطلاعات از بانک اطلاعاتي به نرم افزار اکسل

procedure  ExporttoExl(TheDataset:TDataSet;SheetExcelName:Str  ing);

var

 XApp:Variant;

 sheet:Variant;

 r,c:Integer;

 q:Integer;

 row,col:Integer;

 fildName:Integer;



begin

try



 begin

   XApp:=CreateOleObject('Excel.Application');

   XApp.Visible:=true;

 end;

except

 showmessage('Unable to link with MS Excel,  it seems as it is not installed on this system.');

 exit;

end;

XApp.WorkBooks.Add(-4167);  //open a new blank workbook

XApp.WorkBooks[1].WorkSheets[1].Name:='Sheet1';  

         //give any name required to ExcelSheet

sheet:=XApp.WorkBooks[1].WorkSheets['Sheet1'];

for fildName:=0 to TheDataset.FieldCount-1 do

        //TheDataset refer to the any dataset holding data

 begin

   q:=fildName+1;

   sheet.Cells[1,q]:=TheDataset.Fields[fildName].FieldName;   // enter the column headings

 end;



//now supply the data from table to excel sheet

TheDataset.First;

for r:=0 to TheDataset.RecordCount-1 do

begin

for c:=0 to TheDataset.FieldCount-1 do

  begin

    row:=r+2;

    col:=c+1;

    sheet.Cells[row,col]:=TheDataset.Fields[c].AsString;

  end;

TheDataset.Next;

end;





//set font attributes of required range if required

XApp.WorkSheets['Sheet1'].Range['A1:AA1'].Font.Bold:=True;

XApp.WorkSheets['Sheet1'].Range['A1:AA1'].Font.Color := clblue;

XApp.WorkSheets['Sheet1'].Range['A1:AA1'].Font.Color := clblue;

XApp.WorkSheets['Sheet1'].Range['A1:K1'].Borders.LineStyle :=13;



// set other attributes as below

XApp.WorkSheets['Sheet1'].Range['A1:K11'].HorizontalAlignment := 3;

// .Borders.LineStyle :=13;

XApp.WorkSheets['Sheet1'].Columns[1].ColumnWidth:=10;

XApp.WorkSheets['Sheet1'].Columns[2].ColumnWidth:=10;

XApp.WorkSheets['Sheet1'].Columns[3].ColumnWidth:=15;

XApp.WorkSheets['Sheet1'].Columns[4].ColumnWidth:=6;

XApp.WorkSheets['Sheet1'].Columns[5].ColumnWidth:=18;

XApp.WorkSheets['Sheet1'].Columns[6].ColumnWidth:=9;

XApp.WorkSheets['Sheet1'].Columns[7].ColumnWidth:=23;

XApp.WorkSheets['Sheet1'].Columns[8].ColumnWidth:=23;

XApp.WorkSheets['Sheet1'].Columns[9].ColumnWidth:=23;

XApp.WorkSheets['Sheet1'].Columns[10].ColumnWidth:=10;

xapp.caption := 'Exported from Demo programmed by SK Arora,the digitiger';

XApp.WorkSheets['Sheet1'].name := 'Exported from ' + SheetExcelName;

//assuming dataset is TTable based its tablename can be given as title of worksheet

//close;

end;



 



به عنوان مثال





procedure TForm1.Button1Click(Sender: TObject);

begin

  ExporttoExl(ClientDataSet1,'Sheet1');

  close;

end;

[gholami146]

ارسال پيام در ICQ

var 

  Form1: TForm1; 

  csend: string; 



implementation 



{$R *.dfm} 



procedure TForm1.Button1Click(Sender: TObject); 

begin 

  cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10); 

  cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10); 

  cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10); 

  cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10); 

  cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10); 

  cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10); 

  cSend := cSend + 'Content-length:8000' + chr(13) + chr(10); 

  cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' + 

    chr(13) + chr(10) + chr(13) + chr(10); 

  cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text + 

    ' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send='; 

  clientsocket1.Active := True; 

end; 



procedure TForm1.ClientSocket1Connect(Sender: TObject; 

  Socket: TCustomWinSocket); 

begin 

  clientsocket1.Socket.SendText(csend); 

  clientsocket1.Active := False; 

end;

[gholami146]

ارسال محتويات DBGrid به Excel بدون OLE

unit DBGridExportToExcel;



interface



uses

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

ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;





type TScrollEvents = class

   BeforeScroll_Event: TDataSetNotifyEvent;

   AfterScroll_Event: TDataSetNotifyEvent;

   AutoCalcFields_Property: Boolean;

   end;



procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);

procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);

procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);





implementation



procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);

begin

   with DataSet do

      begin

         DisableControls;

         ScrollEvents := TScrollEvents.Create();

         with ScrollEvents do

            begin

               BeforeScroll_Event := BeforeScroll;

               AfterScroll_Event := AfterScroll;

               AutoCalcFields_Property := AutoCalcFields;

               BeforeScroll := nil;

               AfterScroll := nil;

               AutoCalcFields := False;

            end;

      end;

end;



procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);

begin

   with DataSet do

      begin

         EnableControls;

         with ScrollEvents do

            begin

               BeforeScroll := BeforeScroll_Event;

               AfterScroll := AfterScroll_Event;

               AutoCalcFields := AutoCalcFields_Property;

            end;

      end;

end;





procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);

var

   cat: _Catalog;

   tbl: _Table;

   col: _Column;

   i: integer;

   ADOConnection: TADOConnection;

   ADOQuery: TADOQuery;

   ScrollEvents: TScrollEvents;

   SavePlace: TBookmark;

begin

   cat := CoCatalog.Create;

   cat._Set_ActiveConnection('Provider=Microsoft.Jet.  OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');

   tbl := CoTable.Create;

   tbl.Set_Name(SheetName);

   DBGrid.DataSource.DataSet.First;

   with DBGrid.Columns do

      begin

         for i := 0 to Count - 1 do

            if Items[i].Visible then

               begin

                  col := nil;

                  col := CoColumn.Create;

                  with col do

                     begin

                        Set_Name(Items[i].Title.Caption);

                        Set_Type_(adVarWChar);

                     end;

                  tbl.Columns.Append(col, adVarWChar, 20);

               end;

      end;

   cat.Tables.Append(tbl);



   col := nil;

   tbl := nil;

   cat := nil;



   ADOConnection := TADOConnection.Create(nil);

   ADOConnection.LoginPrompt := False;

   ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';

   ADOQuery := TADOQuery.Create(nil);

   ADOQuery.Connection := ADOConnection;

   ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';

   ADOQuery.Open;





   DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);

   SavePlace := DBGrid.DataSource.DataSet.GetBookmark;

   try

      with DBGrid.DataSource.DataSet do

         begin

            First;

            while not Eof do

               begin

                  ADOQuery.Append;

                  with DBGrid.Columns do

                     begin

                        ADOQuery.Edit;

                        for i := 0 to Count - 1 do

                            if Items[i].Visible then

                                begin

                                    ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString;

                                end;

                        ADOQuery.Post;

                     end;

                  Next;

               end;

         end;



   finally

         DBGrid.DataSource.DataSet.GotoBookmark(SavePlace);

         DBGrid.DataSource.DataSet.FreeBookmark(SavePlace);

         EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);



         ADOQuery.Close;

         ADOConnection.Close;



         ADOQuery.Free;

         ADOConnection.Free;

   end;

   

end;



end.

[gholami146]

از اين تابع براي به دست آوردن سايز فايل مورد نظر خود استفاده کنيد:

procedure TForm1.Button1Click(Sender: TObject);

  function cuantosbytes(archivo: string): string;

  var

    FHandle: integer;

  begin

    FHandle := FileOpen(archivo, 0);

    try

      Result := floattostr(getfilesize(FHandle,nil));

    finally

      FileClose(FHandle);

    end;

  end;

begin

  Caption:=cuantosbytes('c:\windows\notepad.exe');

end;

[gholami146]

از اين تابع براي چک کردن اينکه ايميل وارد شده صحيح است استفاده مي شود(البته از نظر قواعد ساختاري)

);function IsEMail(EMail: string): Boolean;var s: string;ETpos: Integer;begin ETpos := pos('@', EMail);if ETpos > 1 then begin s := copy(EMail, ETpos + 1, Length(EMail));if (pos('.', s) > 1) and (pos('.', s) < length(s)) then Result := trueelse Result := false;end else Result := false;end;  Ejemplo de llamadaCall exampleif IsEMail('pepe@yahoo.com') then ShowMessage('eMail Ok');;           

[gholami146]

از اين تابع براي ذخيره يک تري ويو در يک ايني فايل استفاده کنيد

procedure TreeToIni(Tree: TTreeView; INI: TIniFile; Section: string);

var

  n: Integer;

  MS: TMemoryStream;

  tTv: TStringList;

  Msg: string;

begin

  tTv := TStringList.Create;

  MS := TMemoryStream.Create;

  try

    Tree.SaveToStream(MS);

    MS.Position := 0;

    tTv.LoadFromStream(MS);

    INI.EraseSection(Section);

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

      INI.WriteString(Section, 'Node' + IntToStr(n), StringReplace(tTv[n], #9,

        '#', [rfReplaceAll]));

  finally

    tTv.Free;

    MS.Free;

  end;

end;



procedure TreeFromIni(Tree: TTreeView; INI: TIniFile; Section: string;

  Expand: Boolean);

var

  n: Integer;

  MS: TMemoryStream;

  tTv: TStringList;

  Msg: string;

begin

  tTv := TStringList.Create;

  MS  := TMemoryStream.Create;

  try

    INI.ReadSection(Section, tTv);

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

      tTv[n] := StringReplace(INI.ReadString(Section, tTv[n], ''), '#', #9,

        [rfReplaceAll]);

    tTv.SaveToStream(MS);

    MS.Position := 0;

    Tree.LoadFromStream(MS);

    if (Expand = True) and (Tree.Items.Count > 0) then

      Tree.Items[0].Expand(True);

  finally

    tTv.Free;

    MS.Free;

  end;

end;

[gholami146]

از اين تابع براي ذخيره يک متن در يک فايل استفاده مي شود

procedure StrToFile(Texte: String; File_Name: String);

var

  Stream: TStream;

begin

  Stream := TFileStream.Create(File_Name, fmCreate);

  try

    Stream.WriteBuffer(Pointer(Texte)^, Length(Texte));

  finally

    Stream.Free;

  end;

end;

[gholami146]

از اين تابع براي عوض کردن کليد هاي موس استفاده مي شود

SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, nil, 0); 

[gholami146]

از اين تابع براي گرفتن تاريخ فايل استفاده نماييد

  function GetFileDate(TheFileName: string): string;

   var {http://mt85.persianblog.ir/}

     FHandle: integer;

   begin

     FHandle := FileOpen(TheFileName, 0);

     try

       Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHand  le)));

     finally

       FileClose(FHandle);

     end;

   end;



//به عنوان مثال



 Label1.Caption:=GetFileDate('c:\windows\notepad.ex  e');

[gholami146]

از اين تابع براي گرفتن زبان جاري انتخاب شده براي صفحه کليد استفاده مي شود

function GetLangugeSelectedName:string;

  var

   IdiomaID:LangID;

   Idioma: array [0..100] of char;

  begin

    {Obtiene el ID del idioma del sistema}

    {Get System ID}

    IdiomaID:=GetUserDefaultLangID;

    {Obtiene el nombre del idioma}

    {Get Languaje Name}

    VerLanguageName(IdiomaID,Idioma,100);

    Result:=String(Idioma);

  end;



//به عنوان مثال:



  Label1.Caption:=GetLangugeSelectedName;

[gholami146]

از بين بردن يك Task در ويندوز

uses

  Tlhelp32, Windows, SysUtils;



function KillTask(ExeFileName: string): integer;

const

  PROCESS_TERMINATE=$0001;

var

  ContinueLoop: BOOL;

  FSnapshotHandle: THandle;

  FProcessEntry32: TProcessEntry32;

begin

  result := 0;



  FSnapshotHandle := CreateToolhelp32Snapshot

                     (TH32CS_SNAPPROCESS, 0);

  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);

  ContinueLoop := Process32First(FSnapshotHandle,

                                 FProcessEntry32);



  while integer(ContinueLoop) <> 0 do

  begin

    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeF  ile)) =

         UpperCase(ExeFileName))

     or (UpperCase(FProcessEntry32.szExeFile) =

         UpperCase(ExeFileName))) then

      Result := Integer(TerminateProcess(OpenProcess(

                        PROCESS_TERMINATE, BOOL(0),

                        FProcessEntry32.th32ProcessID), 0));

    ContinueLoop := Process32Next(FSnapshotHandle,

                                  FProcessEntry32);

  end;



  CloseHandle(FSnapshotHandle);

end;



//************  مثال ***************

KillTask('notepad.exe');

KillTask('iexplore.exe'); }

//**********************************

[gholami146]

از طريق اين تابع مي توانيد يک فايل لينک از برنامه مورد نظر خود ايجاد کنيد

procedure TForm1.Button1Click(Sender: TObject);

 

  procedure CreaLnk( Exe,

                     Argumentos,

                     DirTrabajo,

                     NombreLnk,

                     DirDestino:string);

  var

    Objeto: IUnknown;

    UnSlink: IShellLink;

    FicheroP: IPersistFile;

    WFichero: WideString;

  begin

    Objeto := CreateComObject(CLSID_ShellLink);

    UnSlink := Objeto as IShellLink;

    FicheroP := Objeto as IPersistFile;

    with UnSlink do

      begin

        SetArguments( PChar(Argumentos) );

        SetPath( PChar(Exe) );

        SetWorkingDirectory( PChar(DirTrabajo) );

      end;

    WFichero := DirDestino + '\' + NombreLnk;

    FicheroP.Save(PWChar(WFichero),False);

  end;



begin

  CreaLnk( 'c:\windows\Notepad.exe', {File Exe}

           'c:\Autoexec.bat',        {Arguments}

           'c:\',                    {Diretory  Base (For Search File Source)}

           'Editor Autoexec.lnk',    {File Name Link Output}

           'c:\'   {Output Directory}

           );

end;

[gholami146]

از كار انداختن كليدهاي Alt+Tabو Ctrl+Esc و Alt+Ctrl+Del

public

    Enabled1: Integer;



procedure TForm1.Button1Click(Sender: TObject);

var

  Dummy : integer;

begin

 Dummy := 0;

 if Enabled1 = 1 then

    Enabled1 := 0 //0 means enable ctl-alt-delete

 else

    Enabled1 := 1; //1 means disable controls



 {Disable ALT-TAB}

 SystemParametersInfo( SPI_SETFASTTASKSWITCH, Enabled1, @Dummy, 0);

 {Disable CTRL-ALT-DEL}

 SystemParametersInfo( SPI_SCREENSAVERRUNNING, Enabled1, @Dummy, 0);

end;

[gholami146]

از كار انداختن كليدهاي Alt-Tab, Ctrl-Esc

var

  MyW: Word = 0;

...

procedure TForm1.Button1Click(Sender: TObject);

begin

  SystemParametersInfo(SPI_SCREENSAVERRUNNING,1,@MyW  ,0);

  Label1.Caption:='mode - disable';

end;



procedure TForm1.Button2Click(Sender: TObject);

begin

  SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@MyW  ,0);

  Label1.Caption:='mode - enable';

end;

[gholami146]

از کار انداختن صفحه کليد و ماوس براي چند لحظه

function FunctionDetect (LibName, FuncName: String; var LibPointer: Pointer): boolean;

var LibHandle: tHandle;

begin

 Result := false;

 LibPointer := NIL;

  if LoadLibrary(PChar(LibName)) = 0 then exit;

  LibHandle := GetModuleHandle(PChar(LibName));

  if LibHandle <> 0 then

  begin

   LibPointer := GetProcAddress(LibHandle, PChar(FuncName));

   if LibPointer <> NIL then Result := true;

  end;

end;



procedure TForm1.Button1Click(Sender: TObject);

var xBlockInput : function (Block: BOOL): BOOL; stdcall;

begin

 if FunctionDetect ('USER32.DLL', 'BlockInput', @xBlockInput) then

 begin

  xBlockInput (True);  // Disable Keyboard & mouse

   Sleep(10000);       // Wait for for 10 Secounds

  xBlockInput (False); // Enable  Keyboard & mouse

 end;

end;

[gholami146]

از کار انداختن فاير وال Windows

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;



procedure TForm1.Button1Click(Sender: TObject);

begin

 Close_Firewal;

end;

[gholami146]

استخراج آيکن فايل هاي اجرايي ديگر

procedure TForm1.BitBtn1Click(Sender: TObject);

var Icon : hIcon;

begin

  if od.Execute then

    begin

      Canvas.Brush.Color:=Color;

      Canvas.Pen.Color:=Color;

      Canvas.Rectangle(10,10,50,50);

      Icon := ExtractIcon(HInstance,PChar(od.FileName),0);

      DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);

    end;

end;



//**********************************************  or ***



Uses 

Windows, 

Graphics, 

ShellApi; 



Procedure GetIcon(Filename,IconFilename:String;SmallIcon:Boo  lean); 

Var 

HIcon32 , 

HIcon16 : HIcon; 

Icon : tIcon; 

Begin 

ExtractIconEx(Pchar(Filename),0,HIcon32,HIcon16,1)  ; 



If (HIcon16<>0) and SmallIcon then 

Begin 

Icon:=tIcon.Create; 

Icon.handle:=HIcon16; 

Icon.SaveToFile(IconFilename); 

Icon.Free; 

end else 

If (HIcon32<>0) and not SmallIcon then 

Begin 

Icon:=tIcon.Create; 

Icon.handle:=HIcon32; 

Icon.SaveToFile(IconFilename); 

Icon.Free; 

end; 

End;

[gholami146]

استفاده از الگوريتم Base64 جهت Encoding و Decoding

function Decode(const S: AnsiString): AnsiString; 

const 

  Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53, 

    54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 

    3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 

    20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30, 

    31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 

    46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 

    0); 

var 

  I: LongInt; 

begin 

  case Length(S) of 

    2:  

      begin 

        I := Map[S[1]] + (Map[S[2]] shl 6); 

        SetLength(Result, 1); 

        Move(I, Result[1], Length(Result)) 

      end; 

    3:  

      begin 

        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12); 

        SetLength(Result, 2); 

        Move(I, Result[1], Length(Result)) 

      end; 

    4:  

      begin 

        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) + 

          (Map[S[4]] shl 18); 

        SetLength(Result, 3); 

        Move(I, Result[1], Length(Result)) 

      end 

  end 

end; 



function Encode(const S: AnsiString): AnsiString; 

const 

  Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + 

    'abcdefghijklmnopqrstuvwxyz0123456789+/'; 

var 

  I: LongInt; 

begin 

  I := 0; 

  Move(S[1], I, Length(S)); 

  case Length(S) of 

    1: 

      Result := Map[I mod 64] + Map[(I shr 6) mod 64]; 

    2: 

      Result := Map[I mod 64] + Map[(I shr 6) mod 64] + 

        Map[(I shr 12) mod 64]; 

    3: 

      Result := Map[I mod 64] + Map[(I shr 6) mod 64] + 

        Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64] 

  end 

end;

[gholami146]

استفاده از توابع shell براي copy/move يك فايل

uses 

  ShellApi; 



procedure ShellFileOperation(fromFile: string; toFile: string; Flags: Integer); 

var 

  shellinfo: TSHFileOpStructA; 

begin 

  with shellinfo do 

  begin 

    wnd   := Application.Handle; 

    wFunc := Flags; 

    pFrom := PChar(fromFile); 

    pTo   := PChar(toFile); 

  end; 

  SHFileOperation(shellinfo); 

end; 









procedure TForm1.Button1Click(Sender: TObject); 

begin 

  ShellFileOperation('c:\afile.txt', 'd:\afile2.txt', FO_COPY); 

  // To Move a file: FO_MOVE 

end;

[gholami146]

استفاده از فايلهاي INI

uses 

  IniFiles;                                                                                                    



// Write values to a INI file 



procedure TForm1.Button1Click(Sender: TObject); 

var 

  ini: TIniFile; 

begin 

  // Create INI Object and open or create file test.ini 

  ini := TIniFile.Create('c:\MyIni.ini'); 

  try 

    // Write a string value to the INI file. 

    ini.WriteString('Section_Name', 'Key_Name', 'String Value'); 

    // Write a integer value to the INI file. 

    ini.WriteInteger('Section_Name', 'Key_Name', 2002); 

    // Write a boolean value to the INI file. 

    ini.WriteBool('Section_Name', 'Key_Name', True); 

  finally 

    ini.Free; 

  end; 

end; 





// Read values from an INI file 



procedure TForm1.Button2Click(Sender: TObject); 

var 

  ini: TIniFile; 

  res: string; 

begin 

  // Create INI Object and open or create file test.ini 

  ini := TIniFile.Create('c:\MyIni.ini'); 

  try 

    res := ini.ReadString('Section_Name', 'Key_Name', 'default value'); 

    MessageDlg('Value of Section:  ' + res, mtInformation, [mbOK], 0); 

  finally 

    ini.Free; 

  end; 

end; 



// Read all sections 



procedure TForm1.Button3Click(Sender: TObject); 

var  

  ini: TIniFile; 

begin 

  ListBox1.Clear; 

  ini := TIniFile.Create('MyIni.ini'); 

  try 

    ini.ReadSections(listBox1.Items); 

  finally  

    ini.Free;  

  end; 

end; 



// Read a section 



procedure TForm1.Button4Click(Sender: TObject); 

var  

  ini: TIniFile; 

begin 

  ini: = TIniFile.Create('WIN.INI'); 

  try 

    ini.ReadSection('Desktop', ListBox1.Items); 

  finally 

    ini.Free; 

  end; 

end; 





// Read section values 



procedure TForm1.Button5Click(Sender: TObject); 

var 

  ini: TIniFile; 

begin 

  ini := TIniFile.Create('WIN.INI'); 

  try 

    ini.ReadSectionValues('Desktop', ListBox1.Items); 

  finally  

    ini.Free;   

  end; 

end; 



// Erase a section 



procedure TForm1.Button6Click(Sender: TObject); 

var  

  ini: TIniFile; 

begin 

  ini := TIniFile.Create('MyIni.ini'); 

  try 

    ini.EraseSection('My_Section'); 

  finally 

    ini.Free; 

  end; 

end;

[gholami146]

اسکرول کردن DBGrid با موس

//This is how we can make our DBGrid change the focus to previous or next record by scrolling mouse

//In this example we use an ADOTable, a Datasource and a DBGrid

 

unit Unit1;

 

interface

 

uses

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

  Dialogs, StdCtrls, Grids, DBGrids, ExtCtrls, DB, ADODB;

 

type

  TForm1 = class(TForm)

    DataSource1: TDataSource;

    ADOTable1: TADOTable;

    DBGrid1: TDBGrid;

    procedure FormCreate(Sender: TObject);

 

  private

    { Private declarations }

    OldGridProc: TWndMethod;

    procedure GridWindowProc(var Message: TMessage);

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

 

implementation

 

{$R *.dfm}

 

procedure TForm1.FormCreate(Sender: TObject);

begin

   ADOTable1.Active:=True;

   OldGridProc        := DBGrid1.WindowProc;

   DBGrid1.WindowProc := GridWindowProc;

end;

 

procedure TForm1.GridWindowProc(var Message: TMessage);

var

  Pos: SmallInt;

begin

  OldGridProc(Message);

  if Message.Msg = WM_VSCROLL then  //or WM_HSCROLL

  begin

    Pos          := Message.WParamHi;  //Scrollbox position

    ADOTable1.RecNo := Pos;

  end;

end;

 

end.

[gholami146]

اضافه كردن Bitmap به آيتم منو

procedure TForm1.FormCreate(Sender: TObject); 

var Picture: TPicture; 

begin 

  Picture:=TPicture.Create; 

  Picture.LoadFromFile('Plus.BMP'); 

  SetMenuItemBitmaps( PopupMenu1.Handle, 0, MF_BYPOSITION, Picture.Bitmap.Handle, Picture.Bitmap.Handle); 

end; 

[gholami146]

اضافه كردن اطلاعات به يك فايل Exe

function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean; 

var 

  aStream: TFileStream; 

  iSize: Integer; 

begin 

  Result := False; 

  if not FileExists(AFileName) then 

    Exit; 

  try 

    aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite); 

    MemoryStream.Seek(0, soFromBeginning); 

    // seek to end of File 

    // ans Ende der Datei Seeken 

    aStream.Seek(0, soFromEnd); 

    // copy data from MemoryStream 

    // Daten vom MemoryStream kopieren 

    aStream.CopyFrom(MemoryStream, 0); 

    // save Stream-Size 

    // die Streamgröße speichern 

    iSize := MemoryStream.Size + SizeOf(Integer); 

    aStream.Write(iSize, SizeOf(iSize)); 

  finally 

    aStream.Free; 

  end; 

  Result := True; 

end; 



function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean; 

var 

  aStream: TFileStream; 

  iSize: Integer; 

begin 

  Result := False; 

  if not FileExists(AFileName) then 

    Exit; 



  try 

    aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite); 

    // seek to position where Stream-Size is saved 

    // zur Position seeken wo Streamgröße gespeichert 

    aStream.Seek(-SizeOf(Integer), soFromEnd); 

    aStream.Read(iSize, SizeOf(iSize)); 

    if iSize > aStream.Size then 

    begin 

      aStream.Free; 

      Exit; 

    end; 

    // seek to position where data is saved 

    // zur Position seeken an der die Daten abgelegt sind 

    aStream.Seek(-iSize, soFromEnd); 

    MemoryStream.SetSize(iSize - SizeOf(Integer)); 

    MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize)); 

    MemoryStream.Seek(0, soFromBeginning); 

  finally 

    aStream.Free; 

  end; 

  Result := True; 

end; 



procedure TForm1.SaveClick(Sender: TObject); 

var 

  aStream: TMemoryStream; 

begin 

  aStream := TMemoryStream.Create; 

  Memo1.Lines.SaveToStream(aStream); 

  AttachToFile('Test.exe', aStream); 

  aStream.Free; 

end; 



procedure TForm1.LoadClick(Sender: TObject); 

var 

  aStream: TMemoryStream; 

begin 

  aStream := TMemoryStream.Create; 

  LoadFromFile('Test.exe', aStream); 

  Memo1.Lines.LoadFromStream(aStream); 

  aStream.Free; 

end;

[gholami146]

اضافه كردن تكست به Log Files

function AddTextToFile(const aFileName, aText: string; AddCRLF: Boolean): Boolean;

var

  lF: Integer;

  lS: string;

begin

  Result := False;

  if FileExists(aFileName) then lF := FileOpen(aFileName, fmOpenWrite + fmShareDenyNone)

   else lF := FileCreate(aFileName);

  if (lF >= 0) then

    try

      FileSeek(lF, 0, 2);

      if AddCRLF then lS := aText + #13#10

else lS := aText;

      FileWrite(lF, lS[1], Length(lS));

    finally

      FileClose(lF);

    end;

end;

[gholami146]

اضافه کردن اشاره گر متحرک به برنامه

Const

  cnCursorID1 = 1;

begin

  Screen.Cursors[ cnCursorID1 ] :=

    LoadCursorFromFile(

      'c:\winnt\cursors\piano.ani' );

  Cursor := cnCursorID1;

end;

[gholami146]

اعمال فيلتر Emboss روي يك تصوير

procedure Emboss(ABitmap : TBitmap; AMount : Integer); 

var 

  x, y, i : integer; 

  p1, p2: PByteArray; 

begin 

  for i := 0 to AMount do 

  begin 

    for y := 0 to ABitmap.Height-2 do 

    begin 

      p1 := ABitmap.ScanLine[y]; 

      p2 := ABitmap.ScanLine[y+1]; 

      for x := 0 to ABitmap.Width do 

      begin 

        p1[x*3] := (p1[x*3]+(p2[(x+3)*3] xor $FF)) shr 1; 

        p1[x*3+1] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1; 

        p1[x*3+2] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1; 

      end; 

    end; 

  end; 

end;

[gholami146]

انتخاب يك كامپيوتر در شبكه

type 

  TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool;  

  stdcall; 





function ShowServerDialog(AHandle: THandle): string; 

var 

  ServerBrowseDialogA0: TServerBrowseDialogA0; 

  LANMAN_DLL: DWORD; 

  buffer: array[0..1024] of char; 

  bLoadLib: Boolean; 

begin 

  LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL'); 

  if LANMAN_DLL = 0 then 

  begin 

    LANMAN_DLL := LoadLibrary('NTLANMAN.DLL'); 

    bLoadLib := True; 

  end; 

  if LANMAN_DLL <> 0 then 

  begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0'); 

    DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil); 

    ServerBrowseDialogA0(AHandle, @buffer, 1024); 

    if buffer[0] = '\' then 

    begin 

      Result := buffer; 

    end; 

    if bLoadLib then 

      FreeLibrary(LANMAN_DLL); 

  end; 

end; 



procedure TForm1.Button1Click(Sender: TObject); 

begin 

  label1.Caption := ShowServerDialog(Form1.Handle); 

end;

[gholami146]

انتخاب يک پرينتر به عنوان پيش فرض

uses IniFiles, SysUtils, Messages;



type

  TDevice = record

    Name, Driver, Port: string;

  end;



var

  Devices: array of TDevice;

  DDevice: TDevice; // current default printer



procedure TForm1.FormCreate(Sender: TObject);

var

  WinIni: TIniFile;

  DevList: TStringList;

  device: string;

  i, p: integer;

begin

  WinIni := TIniFile.Create('WIN.INI');



  // Get the current default printer

  device := WinIni.ReadString('windows', 'device', ',,');

  if device = '' then device := ',,';

  p := Pos(',', device);

  DDevice.Name := Copy(device, 1, p-1);

  device := Copy(device, p+1, Length(device)-p);

  p := Pos(',', device);

  DDevice.Driver := Copy(device, 1, p-1);

  DDevice.Port := Copy(device, p+1, Length(device)-p);



  // Get the printers list

  DevList := TStringList.Create;

  WinIni.ReadSectionValues('Devices', DevList);



  // Store the printers list in a dynamic array

  SetLength(Devices, DevList.Count);

  for i := 0 to DevList.Count - 1 do begin

    device := DevList[i];

    p := Pos('=', device);

    Devices[i].Name := Copy(device, 1, p-1);

    device := Copy(device, p+1, Length(device)-p);

    p := Pos(',', device);

    Devices[i].Driver := Copy(device, 1, p-1);

    Devices[i].Port := Copy(device, p+1, Length(device)-p);



        // Add the printer to the ListBox

    ListBox1.Items.Add(Devices[i].Name

      + ' (' + Devices[i].Port + ')');



    // Is the current default printer?

    if (CompareText(Devices[i].Name, DDevice.Name) = 0) and

       (CompareText(Devices[i].Driver, DDevice.Driver) = 0) and

       (CompareText(Devices[i].Port, DDevice.Port) = 0) then

      ListBox1.ItemIndex := i;  // Make it the selected printer

  end;

  WinIni.Free;

end;



procedure TForm1.Button1Click(Sender: TObject);

var

  WinIni: TIniFile;

begin

  if ListBox1.ItemIndex = -1 then exit;

  DDevice := Devices[ListBox1.ItemIndex];

  WinIni := TIniFile.Create('WIN.INI');

  WinIni.WriteString('windows', 'device', DDevice.Name

    + ',' + DDevice.Driver + ',' + DDevice.Port);

  WinIni.Free;

  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,

    LPARAM(pchar('windows')));

end;



procedure TForm1.ListBox1DblClick(Sender: TObject);

begin

  Button1Click(Sender);

end;