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

در دلفي مي توان با استفاده از متد Show يك فرم را نمايش داد.
در اين قسمت مي خواهيم كه در صورت صحيح بودن يك شرط از نمايش فرم جلوگيري شود.
براي اين كار، با توجه به اينكه با فراخواني متد Show در فرم اول ، رويداد Onshow از فرم دوم اجرا مي شود. بايد از كد زير در اين رويداد(يعني رويداد onShow فرم دوم) استفاده كنيم :

 if Form1.Edit1.Text=IntToStr(1) then  

  PostMessage(form2.Handle,WM_CLOSE,0,0);

دستور PostMessage با پارامتر WM_CLOSE باعث عدم نمايش فرم مي شود. در كد بالا در صورتي كه مقدار Edit1 برابر با 1 شود، Form2 نمايش داده نمي شود.

آقاي mzjahromi مطلب پست 127 روي عبارات IsPublishedProp و GetOrdProp و SetOrdProp خطا ميده و ناشناس تشخيص داده مي شوند لطفا رسيدگي كنيد

با تشكر

با این کد می توانید عنوان دکمه برنامه خودتون رو در Taskbar متحرک کنید :

procedure TForm1.Timer1Timer(Sender: TObject);
const
{$J+}
animatedTitle : string = 'www.mojtabaie.persianblog.ir';
{$J-}
var
cnt: Integer;

begin
Application.Title := animatedTitle;
for cnt := 1 to (Length(animatedTitle) - 1) do
begin
animatedTitle[cnt] := Application.Title[cnt + 1];
animatedTitle[Length(animatedTitle)] := Application.Title[1];
end;
end;

منبع : http://delphi.about.com
www.mojtabaie.persianblog.ir

بدست آوردن Event های یکComponent :

uses
   

TypInfo;



...

procedure TForm1.Button1Click(Sender: TObject);

var

  ListProp: PPropList;

  TD: PTypeData;

  Num, i: Integer;

begin

  GetMem(ListProp, SizeOf(PPropInfo)*TD.PropCount);

  Num:=GetPropList(

    Sender.ClassInfo,

    [tkMethod],

    ListProp);

  for i:=0 to Num-1 do

    Memo1.Lines.Add(ListProp[i]^.Name);

end;

شما می توانید بجای Sender که با رنگ قرمز مشخص شده نام کامپوننت مورد نظر را بنویسید

سلام دوستان.

دستور زیر به شما نشون میده که چطور تو رجیستری یه مقدار Multi-String درست کنید و چندخط توش بنویسید.

procedure TForm1.FormCreate(Sender: TObject);

Var

  Reg : TRegistry;

begin

  With Reg do

      Begin

        RootKey:= HKEY_LOCAL_MACHINE;

         OpenKey('SYSTEM\CurrentControlSet\Services\Naruto'  , False);

          RegSetValueEx(CurrentKey,'ValueName',0,REG_MULTI_S  Z,

           PWideChar('YouString1'+#0+'YourString2'+#0),

            Length('YourSting1'+#0+'YourString2'+#0)*2);

      End;

End;

یک لیست از توابع WINDOWS API

· Determine the last access time of a given file
· Using the Shell API function SHBrowseForFolder()
· Detecting if the system time has been changed
· Trapping for when a user is done resizing a window
· Using the WIN API high resolution performance counter
· Getting modem status under Win32
· adding system menu items to a form
· Clearing the recent Documents from the Start Menu
· Copying files using the Standard Windows Copy file dialog box
· Creating a custom word break procedure
· How can I get serial number of my drive
· Determining Drive Type
· Using FindFirst to search for files.
· Getting an handle to a window in another application.
· Checking drive ready status.
· External function failure when passing boolean parms

.
و....

نقل قول:

---

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

سلام

برنامه اتصال به اینترنت به صورت خودکار در ساعت مشخص.
ویژگی ها و تنظیمات:

1-تنظیم زمان اتصال.
2-تنظیم زمان قطع ارتباط .
3-خاموش شدن سیستم پس از قطع اتباط .
4-اجرای نرم افزار مدیریت دانلود .
5-خاموش شدن سیستم پس از سه بار خطا در برقراری ارتباط .
6-قرارگرفتن در startup .

چون از کامپوننت هایی استفاده کردم که به صورت پیش فرض روی دلفی نصب نیست و ممکنه دوستانی فقط به فایل اجرایی این برنامه احتیاج داشته باشن اون رو هم به صورت جداگانه آپ کردم.

امید وارم مفید واقع بشه...

[جناب کشاورز اگه دو دقیقه صبر میکردید محتواش هم میومد. بلا نسبت ... نیستم که ساعت 2 نصفه شب بشینم الکی تایپ کنم:عصبانی:]

---

:گریه:جای این مطلب به نظرت تو بخش پروژه های متن باز یا حداقل تاپیک جداگانه نبود ؟

اگر شما هم مثل من حالتون از http://contest2004.thinkquest.jp/tqj...rHandPoint.png(crHandPoint) به هم می خوره و می خواهید از شکل استاندارد ویندوز (http://telcontar.net/Misc/screeniecu...nd%20white.png) استفاده کنید، کافیه در رویداد FormCreate خط زیر رو اضافه کنید تا crHandPoint به شکل استاندارد ویندوز تغییر کنه:

Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);

نقل قول:

---

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

اگر شما هم مثل من حالتون از http://contest2004.thinkquest.jp/tqj...rHandPoint.png(crHandPoint) به هم می خوره و می خواهید از شکل استاندارد ویندوز (http://telcontar.net/Misc/screeniecu...nd%20white.png) استفاده کنید، کافیه در رویداد FormCreate خط زیر رو اضافه کنید تا crHandPoint به شکل استاندارد ویندوز تغییر کنه:

Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);

---

سلام
آقا این کد کار نکرد میشه راهنمایی کنید؟؟
ممنون

نقل قول:

---

سلام
آقا این کد کار نکرد میشه راهنمایی کنید؟؟
ممنون

---

بعد از اینکه اون خط رو در رویداد FormCreate نوشتید باید خاصیت Cursor کنترل مورد نظرتون رو به crHandPoint تغییر بدید .

نقل قول:

---

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

بعد از اینکه اون خط رو در رویداد FormCreate نوشتید باید خاصیت Cursor کنترل مورد نظرتون رو به crHandPoint تغییر بدید .

---

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

نقل قول:

---

نوشته شده توسط Majid.Ebru

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

---

به این صورت عمل کنید . دیگه نباید مشکلی باشه .

procedure TForm1.FormCreate(Sender: TObject);

begin

  Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);

  Label1.Cursor := crHandPoint;

end;

با سلام :لبخندساده:

نقل قول:

---

نوشته شده توسط Majid.Ebru

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

---

کد درست کار میکنه !
شما بایستی از پنجره Object Inspector دنبال خصوصیت Cursor فرم بگردید و crHandPoint را مقداردهی نمائید !
و اگر این کد را در فرم اصلی برنامه تان انجام دهید سایر فرم ها از فرم اصلی ارث بری کرده ( چون به فرم اصلی Use شدند ) و دیگر نیازی به استفاده این کد برای هر فرم نیست !!!
موفق باشید ...

سلام . آقا رو هركدوم كه كليك ميكنم فقط صفحه تغيير ولوم ويندوز باز ميشه ؟؟!!!!!

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

من در دلفی 2005 امتحان کردم مشکلی نداشته.

نقل قول:

---

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

سلام . آقا رو هركدوم كه كليك ميكنم فقط صفحه تغيير ولوم ويندوز باز ميشه ؟؟!!!!!

---

مثل اينكه كسي اينجانيست .هيچ كس جوابي نميدهد!!!!!!!!!!!!!!!:عصبانی::افسر ده::گریه:

كانتر آدرس اضافه ميشود
https://barnamenevis.org/showpo...0&postcount=20
ولي روي تاپيك مورد نظر نمي رود.

نقل قول:

---

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

مثل اينكه كسي اينجانيست .هيچ كس جوابي نميدهد!!!!!!!!!!!!!!!:عصبانی::افسر ده::گریه:

كانتر آدرس اضافه ميشود
https://barnamenevis.org/showpo...0&postcount=20
ولي روي تاپيك مورد نظر نمي رود.

---

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

نقل قول:

---

نوشته شده توسط Mr.Keramati

تغییر Volume ویندوز

یک TrackBar در فرم خود قرار دهید و Max value را به 15 تغییر دهید و در رویداد OnChange آن کد زیر را قرار دهید:

procedure TForm1.TrackBar1Change(Sender: TObject);

var

Count, i: integer;

begin

  Count := waveOutGetNumDevs;

  for i := 0 to Count do

  begin

   waveOutSetVolume(i,longint(TrackBar1.Position*4369  )*65536+longint(TrackBar1.Position*4369));

end;

end;

و با TrackBar بازی کنید ...

---

برای waveOutSetVolume ایراد میگیره

نقل قول:

---

برای waveOutSetVolume ایراد میگیره

---

تابع WaveOutSetVolume در یونیت MMSystem قرار داره ، باید یونیت MMSystem رو به قسمت Uses اضافه کنید

نقل قول:

---

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

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

---

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

نقل قول:

---

نوشته شده توسط 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;