nyuuzyou/wikis huggingface dataset:
Удаление HTML элементов из текста

Как-то раз пришлось решить задачу удаления из файла элементов HTML таких, как, например, ненужные ссылки, и в то же время преобразования возврата каретки в HTML параграфы, знаков табуляции в пробелы и т.д. В результате соответственно должен был получиться новый HTML документ.
Следующие две процедуры показывают, как это можно сделать:
procedure TMainForm.LoadFileIntoList(TextFileName: string; AWebPage: TStringList; WithFilter: Boolean);
var
 CurrentFile: TStringList;
begin
 CurrentFile := TStringList.Create;
 try
 CurrentFile.LoadFromFile(TextFileName);
 if WithFilter then
 FilterHTML(CurrentFile,AWebPage)
 else
 with AWebPage do AddStrings(CurrentFile);
 finally
 CurrentFile.Free;
 end;
end;
procedure TMainForm.FilterHTML(FilterInput, AWebPage: TStringList);
var
 i, j: LongInt;
 S: string;
begin
 FilterMemo.Lines.Clear;
 FilterMemo.Lines := FilterInput;
 with AWebPage do
 begin
 FilterMemo.SelectAll;
 j := FilterMemo.SelLength;
 if j > 0 then
 begin
 i := 0;
 repeat
 if FilterMemo.Lines.GetText[i] = Char(VK_RETURN) then // ищем cr
 S := S + sLineBreak
 else if FilterMemo.Lines.GetText[i] = '<' then
 repeat
 Inc(i);
 until (FilterMemo.Lines.GetText[i] = '>')
 else if FilterMemo.Lines.GetText[i] = Char(VK_TAB) then // ищем tab
 S := S + ' '
 else
 S := S + FilterMemo.Lines.GetText[i]; // добавляем текст
 Inc(i);
 until i = j+1;
 Add(S); // добавляем строку в WebPage
 end
 else
 Add('No data entered into field.'); // no data in text file
 end;
end;
Применение функции:
Всё, что нужно сделать - это вызвать :
LoadFileIntoList("filename.txt", Webpage, True);
Где filename - это имя файла, который вы хотите обработать.
"WebPage" - это TStringList
последний параметр в функции указывает, применять или нет HTML-фильтр.
PS: В этом примере объект TMemo (который вызывается из "FilterMemo") лежит на форме и поэтому не видим.
 WebPage := TStringList.Create;
 try
 Screen.Cursor := crHourGlass;
 AddHeader(WebPage);
 with WebPage do
 begin
 Add('Personal Details');
 LoadFileIntoList("filename.txt",Webpage, True);
 end;
 AddFooter(WebPage);
 finally
 WebPage.SaveToFile(HTMLFileName);
 WebPage.Free;
 Screen.Cursor := crDefault;
 end;
Source: Взято из http://forum.sources.ru
ID: 03531
Category:Связь
Category:Web
Удаление и добавление значений динамического массива

=== Удаление и добавление значений динамического массива ===
type 
 TArrayString = array of string; 
procedure DeleteArrayIndex(var X: TArrayString; Index: Integer); 
begin 
 if Index > High(X) then Exit; 
 if Index < Low(X) then Exit; 
 if Index = High(X) then 
 begin 
 SetLength(X, Length(X) - 1); 
 Exit; 
 end; 
 Finalize(X[Index]); 
 System.Move(X[Index +1], X[Index], 
 (Length(X) - Index -1) * SizeOf(string) + 1); 
 SetLength(X, Length(X) - 1); 
end; 
// Example : Delete the second item from array a 
// Beispiel : Losche das 2. Element vom array a 
procedure TForm1.Button2Click(Sender: TObject); 
var 
 a: TArrayString; 
begin 
 DeleteArrayIndex(a, 2); 
end; 
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 00246
----
Крутая штука динамический массив. Очень быстрая и здоровая реализация. Единственное, чего на мой взгляд не хватает, это механизма удаления элемента из середины массива и соответственно вставки в середину. Насколько я понял ( и проверил ), в памяти массив хранится по-разному в зависимости от типа его элементов. Скажм если в массиве строки(!! не shortString ) - хранятся указатели на них, а если прямоугольники (TRect) - то непосредственно сами прямоугольники. 
Ниже привожу подпрограммы удаления и добавления элемента. 
procedure delElem(var A: TRectArray; Index: integer);
var Last: integer;
begin
 Last := High(A);
 if Index < Last then
 Move(A[Index+1], A[Index], (Last-Index) * SizeOf(A[Index]));
 SetLength(A, Last);
end;
procedure addElem( var A: TRectArray; Index: integer; ANew: TRect );
var Len: integer;
begin
 Len := Length(A);
 if Index > = Len then
 Index := Len+1;
 SetLength(A, Len+1);
 Move(A[Index], A[Index+1], (Len-Index) * SizeOf(A[Index]));
 A[Index] := ANew;
end;
Подпрограмма delElem полностью универсальна, а в addElem Вам нужно поменять тип добавляемого элемента (ANew) на требуемый. 
 
Source: http://delphiworld.narod.ru
ID: 00792
Удаление из файла элементов HTML

=== Удаление из файла элементов HTML ===
Как-то раз пришлось решить задачу удаления из файла элементов HTML таких, как, например, ненужные ссылки, и в то эе время преобразования возврата каретки в HTML параграфы, знаков табуляции в пробелы и т.д. В результате соответственно должен был получиться новый HTML документ. 
Следующие две процедуры показывают, как это можно сделать: 
procedure TMainForm.LoadFileIntoList(TextFileName: string;
 AWebPage: TStringList; WithFilter: Boolean);
var
 CurrentFile: TStringList;
begin
 CurrentFile := TStringList.Create;
 CurrentFile.LoadFromFile(TextFileName);
 if WithFilter then
 FilterHTML(CurrentFile,AWebPage)
 else
 with AWebPage do
 AddStrings(CurrentFile);
 CurrentFile.Free;
end;
procedure TMainForm.FilterHTML(FilterInput, AWebPage: TStringList);
var
 i, j: LongInt;
 S: string;
begin
 FilterMemo.Lines.Clear;
 FilterMemo.Lines := FilterInput;
 with AWebPage do
 begin
 FilterMemo.SelectAll;
 j := FilterMemo.SelLength;
 if j > 0 then
 begin
 i := 0;
 repeat
 // ищем cr
 if FilterMemo.Lines.GetText[i] = Char(VK_RETURN) then
 S := S + #10#13;
 else
 if FilterMemo.Lines.GetText[i] = '<' then
 repeat
 inc(i);
 until
 FilterMemo.Lines.GetText[i] = '>'
 else
 // ищем tab
 if FilterMemo.Lines.GetText[i] = Char(VK_TAB) then
 S := S + ' '
 else
 S := S + FilterMemo.Lines.GetText[i]; // добавляем текст
 inc(i);
 until
 i = j + 1;
 Add(S); // добавляем строку в WebPage
 end
 else
 Add('No data entered into field.'); // no data in text file
 end;
end;
Применение функции: 
Всё, что нужно сделать - это вызвать: 
 LoadFileIntoList("filename.txt", Webpage, True); 
Где: 
* filename - это имя файла, который вы хотите обработать. 
* WebPage - это TStringList 
* последний параметр в функции - указывает, применять или нет HTML-фильтр. 
PS: В этом примере объект TMemo (который вызывается из "FilterMemo") лежит на форме и поэтому не видим. 
Пример: 
WebPage := TStringList.Create;
try
 Screen.Cursor := crHourGlass;
 AddHeader(WebPage);
 with WebPage do
 begin
 Add('Personal Details');
 LoadFileIntoList("filename.txt", Webpage, True);
 end;
 AddFooter(WebPage);
finally
 WebPage.SaveToFile(HTMLFileName);
 WebPage.Free;
 Screen.Cursor := crDefault;
end;
Source: http://delphiworld.narod.ru
ID: 00923
Удаление каталога с подкаталогами

Удаление каталога с подкаталогами
== Способ 1: проход по дереву каталогов ==
(Функция для удаления каталогов, взята из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..." - собственно код аналогичен написанному мной коду по рекурсивному проходу каталогов здесь)
function MyRemoveDir(sDir: string): Boolean;
var
 iIndex: Integer;
 SearchRec: TSearchRec;
 sFileName: string;
begin
 Result := False;
 sDir := sDir + '\*.*';
 iIndex := FindFirst(sDir, faAnyFile, SearchRec);
 while iIndex = 0 do
 begin
 sFileName := ExtractFileDir(sDir) + '\' + SearchRec.Name;
 if SearchRec.Attr = faDirectory then
 begin
 if (SearchRec.Name <> ) and (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
 MyRemoveDir(sFileName);
 end
 else
 begin
 if SearchRec.Attr <> faArchive then
 FileSetAttr(sFileName, faArchive);
 if not DeleteFile(sFileName) then
 ShowMessage('Could NOT delete ' + sFileName);
 end;
 iIndex := FindNext(SearchRec);
 end;
 FindClose(SearchRec);
 RemoveDir(ExtractFileDir(sDir));
 Result := True;
end;
== Способ 2: Использование ShellApi ==
uses ShellApi;
var
 sh: SHFILEOPSTRUCT;
begin
 sh.Wnd := Application.Handle;
 sh.wFunc := FO_DELETE;
 sh.pFrom := 'c:\\test\0';
 sh.pTo := nil;
 sh.fFlags := FOF_NOCONFIRMATION or FOF_SILENT;
 sh.hNameMappings := nil;
 sh.lpszProgressTitle := nil;
 SHFileOperation (sh);
end;
Надо путь писать:
 c:\\test\dfg
Чтобы вначале "\\" было...иначе не будет удалять диры из корня
Author: Baa
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 03155
Category:Файловая система
Удаление колонки в StringGrid

=== Удаление колонки в StringGrid ===
procedure GridRemoveColumn(StrGrid: TStringGrid; DelColumn: Integer); 
var
 Column: Integer; 
begin 
 if DelColumn <= StrGrid.ColCount then 
 begin 
 for Column := DelColumn To StrGrid.ColCount-1 do 
 StrGrid.Cols[Column-1].Assign(StrGrid.Cols[Column]); 
 StrGrid.ColCount := StrGrid.ColCount-1; 
 end; 
end; 
ID: 00600
----
procedure RemoveColumn(SG: TStringGrid; ColNumber: integer); 
var
 Column: integer; 
begin 
 ColNumber := abs(ColNumber); 
 if ColNumber <= SG.ColCount then
 begin 
 for Column := ColNumber to SG.ColCount - 2 do
 begin 
 SG.Cols[Column].Assign(SG.Cols[Column + 1]); 
 SG.Colwidths[Column] := SG.Colwidths[Column + 1]; 
 end; 
 SG.ColCount := SG.ColCount - 1; 
 end; 
end; 
----
procedure TForm1.Button3Click(Sender: TObject);
var
 i, j: Integer;
begin
 j := SG1.Row; // строка с выделением
 SG1.Rows[j].Clear;
 for i := j to SG1.RowCount-2 do
 SG1.Rows[i].Assign(SG1.Rows[i+1]);
 SG1.RowCount := SG1.RowCount-1;
end;
Source: http://delphiworld.narod.ru/
ID: 01047
----
type
 TStringGridHack = class(TStringGrid)
 public
 procedure DeleteCol(ACol: Longint);
 end;
var
 Form1: TForm1;
implementation
procedure TStringGridHack.DeleteCol(ACol: Longint);
begin
 if ACol = FixedCols then if ACol = (ColCount - 1) then
 begin
 Cols[ACol].Clear;
 if ColCount(FixedCols + 1) then ColCount := (ColCount - 1);
 end
 else
 begin
 Cols[ACol] := Cols[ACol + 1];
 DeleteCol(ACol + 1);
 end;
end;
Source: http://delphiworld.narod.ru/
ID: 01048
Удаление лишних пробелов в строке

=== Удаление лишних пробелов в строке ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> удаление лишних пробелов в строке
удаляет из строки лишние пробелы без использования всяких указателей и т.д.
Зависимости: стандартные модули
Автор: Артем, boss1999@mail.ru, москва
Copyright: собственное описание (Артем)
Дата: 24 сентября 2003 г.
***************************************************** }
{ процедура удаления лишних пробелов в строке }
function SpacesCompress(AStr: string): string;
var
 c, i: integer;
 s: string;
begin
 c := 0;
 Result := ;
 for i := 1 to Length(AStr) do
 begin
 s := Copy(AStr, i, 1);
 if (s = ' ') and (c >= 1) then
 begin
 c := c + 1;
 end
 else if (s = ' ') and (c = 0) then
 begin
 c := c + 1;
 Result := Result + s;
 end
 else if (s <> ' ') then
 begin
 c := 0;
 Result := Result + s;
 end;
 end;
end;
Source: http://delphibase.endimus.com
ID: 00905
----
function DeleteDoubleSpaces(s: string): string;
begin
 repeat
 Result := s;
 s := StringReplace(Result, ' ', ' ', [rfReplaceAll]); // заменяем все двойные пробелы на одинарные
 until Result = s; // повторяем до тех пор пока есть двойные пробелы 
end;
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
ID: 00906
Удаление ненужных подстрок из строки

=== Удаление ненужных подстрок из строки ===
procedure RemoveInvalid(what, where: string): string;
// what - удаляемая подстрока, where - обрабатываемая строка
var
 tstr: string;
begin
 tstr := where;
 while Pos(what, tstr) > 0 do
 tstr := Copy(tstr, 1, Pos(what, tstr)-1) +
 Copy(tstr, Pos(what, tstr) + Length(tstr), Length(tstr));
 Result := tstr;
end; 
// Применение: 
NewStr := RemoveInvalid('<брак>', 'Этот <брак> в моей строке, и я хочу
удалить из нее этот <брак>');
Source: http://delphiworld.narod.ru
ID: 00900
----
Используйте стандартную функцию Pascal DELETE...
Пользуясь тем же примером, вы можете сделать так....
Target := '<брак>';
while Pos(Target, string) > 0 do
begin
 P := Pos(Target, string);
 Delete(string, P, Length(Target));
end;
Source: http://delphiworld.narod.ru
ID: 00901
----
Всё даже проще:
Result := StringReplace(ИсходнаяСтрока, ТоЧтоНадоУдалить, , [rfReplaceAll])
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
ID: 00902
Удаление пробелов в начале строки

=== Удаление пробелов в начале строки ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Удаление пробелов в начале строки
Функция возвращает строку без пробелов в начале (если они были)
Зависимости: Windows, SysUtils
Автор: Hastlero
Copyright: HasTler0
Дата: 8 февраля 2003 г.
***************************************************** }
var
 i: Integer;
begin
 if Length(str) = 0 then
 begin
 DelSpaces := str;
 Exit;
 end;
 for i := 1 to Length(str) do
 begin
 if Pos(' ', str) = 1 then
 Delete(str, 1, 1)
 else
 begin
 DelSpaces := str;
 Break;
 end;
 end;
end;
// Пример использования: 
Str := DelSpaces(Str); 
Source: http://delphibase.endimus.com
ID: 00903
----
Изобретателям велосипеда посвящается:
TrimRight() - удаляет пробелы в начале строки, в том числе и в юникодных строках
TrimLeft() - удаляет пробелы в конце строки, в том числе и в юникодных строках
Trim() - удаляет пробелы в начале и в конце строки, в том числе и в юникодных строках
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
ID: 00904
Удаление файла в корзину

=== Удаление файла в корзину ===
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, ShellAPI;
const
 SHERB_NOCONFIRMATION = $1;
 SHERB_NOPROGRESSUI = $2;
 SHERB_NOSOUND = $4;
type
 TForm1 = class(TForm)
 btnGetRecicleBinFileCount: TButton;
 btnEmptyRecicleBin: TButton;
 btnDelToReciclebin: TButton;
 procedure btnGetRecicleBinFileCountClick(Sender: TObject);
 procedure btnEmptyRecicleBinClick(Sender: TObject);
 procedure btnDelToReciclebinClick(Sender: TObject);
 end;
type
 TSHQueryRBInfo = packed record
 cbSize : DWORD;
 i64Size,
 i64NumItems : TLargeInteger;
 end;
 PSHQueryRBInfo = ^TSHQueryRBInfo;
 function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar;
 dwFlags: DWORD): HRESULT; stdcall;
 external 'shell32.dll' name 'SHEmptyRecycleBinA';
 function SHQueryRecycleBin (pszRootPath: PChar;
 var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall;
 external 'Shell32.dll' name 'SHQueryRecycleBinA'; 
var
 Form1: TForm1;
implementation
{$R *.dfm}
// Удаление файла в корзину...
procedure TForm1.btnDelToReciclebinClick(Sender: TObject);
var
 Struct: TSHFileOpStruct;
 Err: HRESULT;
begin
 with Struct do
 begin
 Wnd := Handle;
 wFunc := FO_DELETE;
 pFrom := 'c:\1.txt';
 pTo := nil;
 fFlags := FOF_ALLOWUNDO;
 fAnyOperationsAborted := True;
 hNameMappings := nil;
 lpszProgressTitle := nil;
 end;
 Err := SHFileOperation(Struct);
 if Err <> S_OK then ShowMessage(SysErrorMessage(Err));
end;
end.
Author: Rouse_
Source: Взято из http://forum.sources.ru
ID: 01711
Удалить dbase index flag

=== Удалить dbase index flag ===
function UnCheckIndex(FileDbf: string): Boolean;
var
 Dbf: file;
 Car: Char;
begin
 Result := T;
 AssignFile(Dbf, FileDbf);
 Car := #0;
 {$I-}
 Reset(Dbf, 1);
 if not ErrorIO(FileDbf, IoResult) then
 begin
 Seek(Dbf, 28);
 { Flag's position }
 if not ErrorIO(FileDbf, IoResult) then
 BlockWrite(Dbf, Car, 1, Num_R)
 else
 Result := F;
 CloseFile(Dbf);
 if ErrorIO(FileDbf, IoResult) then
 Result := F;
 end
 else
 Result := F;
 {$I+}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 if UnCheckIndex('MyBase.dbf') then
 ShowMessage('Flag removed');
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02707
Удалить временные файлы IE

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;
// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
 DeleteIECache;
end;
Source: http://delphiworld.narod.ru
ID: 03520
Category:Связь
Category:WebBrowser
Удобная загрузка местоположения формы

=== Удобная загрузка местоположения формы ===
Если вы храните параметры местоположения(Top, Left, Width, Height) формы в реестре, то чтобы не загружать данные из нескольких ключей вы можете их записать в один, и из одного же прочитать ;)
По сути, данные записывается в виде record'а. А как это примерно может выглядеть смотрите в примере.
var
 Ini: TRegIniFile;
procedure TForm1.FormCreate(Sender: TObject);
var
 Rct: TRect;
begin
 Ini := TRegIniFile.Create('<Здесь вы пишете путь к вашим настройкам в реестре>');
 // Если есть данные --> загружаем их
 if Ini.ReadBinaryData('FormPosition', Rct, SizeOf(TRect)) > 0 then
 BoundsRect := Rct;
end;
procedure TReply.FormDestroy(Sender: TObject);
var
 Rct: TRect;
begin
 // Сохранение данных на выходе
 Rct := BoundsRect;
 Ini.WriteBinaryData('MsgPos', Rct, SizeOf(TRect));
 Ini.Free;
end;
Author: Автор: Virtualik 
Source: http://delphiworld.narod.ru/
ID: 02296
Удобная функция ifthen

=== Удобная функция ifthen ===
В Делфи 6 (модуль Math) появилась удобная функция ifthen которая соответствует оператору "?" языка С++.
пример:
procedure TForm1.Button1Click(Sender: TObject);
var 
 k, i, j: Integer;
begin
 i := 3;
 j := 2;
 k := ifthen({If}i < j, {Then}i, {Else}k);
End;
Source: http://forum.sources.ru
ID: 00084
Узнать/установить JPG resolution?

procedure GetResJpg(JPGFile: string);
const
 BufferSize = 50;
var
 Buffer: string;
 Index: Integer;
 FileStream: TFileStream;
 HorzRes, VertRes: Word;
 DP: Byte;
 Measure: string;
begin
 FileStream := TFileStream.Create(JPGFile, fmOpenReadWrite);
 try
 SetLength(Buffer, BufferSize);
 FileStream.Read(buffer[1], BufferSize);
 Index := Pos('JFIF' + #$00, buffer);
 if Index > 0 then
 begin
 FileStream.Seek(Index + 6, soFromBeginning);
 FileStream.Read(DP, 1);
 case DP of
 1: Measure := 'DPI'; // Dots Per Inch
 2: Measure := 'DPC'; // Dots Per Cm.
 end;
 FileStream.Read(HorzRes, 2); // x axis
 HorzRes := Swap(HorzRes);
 FileStream.Read(VertRes, 2); // y axis
 VertRes := Swap(VertRes);
 end
 finally
 FileStream.Free;
 end;
end;
procedure SetResJpg(name: string; dpix, dpiy: Integer);
const
 BufferSize = 50;
 DPI = 1; // inch
 DPC = 2; // cm
var
 Buffer: string;
 index: Integer;
 FileStream: TFileStream;
 xResolution: Word;
 yResolution: Word;
 _type: Byte;
begin
 FileStream := TFileStream.Create(name, fmOpenReadWrite);
 try
 SetLength(Buffer, BufferSize);
 FileStream.Read(buffer[1], BufferSize);
 index := Pos('JFIF' + #$00, buffer);
 if index > 0 then
 begin
 FileStream.Seek(index + 6, soFromBeginning);
 _type := DPI;
 FileStream.Write(_type, 1);
 xResolution:= Swap(dpix);
 FileStream.Write(xResolution, 2);
 yResolution := Swap(dpiy);
 FileStream.Write(yResolution, 2);
 end
 finally
 FileStream.Free;
 end;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03790
Category:Графика
Category:Jpeg
Узнать информацию о прокси сервере

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;
{**************************************************************************
* NAME: GetProxyServer
* DESC: Proxy-Server Einstellungen abfragen
* PARAMS: protocol => z.B. 'http' oder 'ftp'
* RESULT: [-]
* CREATED: 08-04-2004/shmia
*************************************************************************}
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;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03518
Category:Связь
Category:WebBrowser
Узнать класс формы

=== Узнать класс формы ===
type 
  PFieldClassTable = ^TFieldClassTable; 
  TFieldClassTable = packed record 
    Count: Smallint; 
    Classes: array[0..8191] of ^TPersistentClass; 
  end; 
function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler; 
asm 
        MOV     EAX,[EAX].vmtFieldTable 
        OR      EAX,EAX 
        JE      @@1 
        MOV     EAX,[EAX+2].Integer 
@@1: 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
  procedure Display(const S: string); 
  begin 
    Memo1.Lines.Add(S); 
  end; 
var 
  pFCT: PFieldClassTable; 
  aClass: TClass; 
  i: SmallInt; 
begin 
  Memo1.Clear; 
  aClass := ClassType; 
  while aClass <> TPersistent do
 begin 
    Display('Registered classes for class '+aClass.Classname ); 
    pFCT := GetFieldClasstable(aClass); 
    if not Assigned(pFCT) then 
      Display('  No classes registered') 
    else
 begin 
      Display(Format('  %d classes registered', [pFCT^.Count])); 
      for i:= 0 to pFCT^.Count -1 do 
        Display('  '+pFCT^.Classes[i]^.ClassName); 
    end; 
    aClass := aClass.ClassParent; 
  end; 
end;
ID: 00430
Узнать не запущено ли приложение под VMware?

=== Узнать не запущено ли приложение под VMware? ===
////////////////////////////////////////////////////////////////////////////////
//
// Simple VMware check on i386
//
// Note: There are plenty ways to detect VMware. This short version bases
// on the fact that VMware intercepts IN instructions to port 0x5658 with
// an magic value of 0x564D5868 in EAX. However, this is *NOT* officially
// documented (used by VMware tools to communicate with the host via VM).
//
// Because this might change in future versions - you should look out for
// additional checks (e.g. hardware device IDs, BIOS informations, etc.).
// Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS
// Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi).
//
function IsVMwarePresent(): LongBool; stdcall; // platform;
begin
 Result := False;
{$IFDEF CPU386}
 try
 asm
 mov eax, 564D5868h
 mov ebx, 00000000h
 mov ecx, 0000000Ah
 mov edx, 00005658h
 in eax, dx
 cmp ebx, 564D5868h
 jne @@exit
 mov Result, True
 @@exit:
 end;
 except
 Result := False;
 end;
{$ENDIF}
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01333
Узнать не запущено ли приложение под Virtual PC?

=== Узнать не запущено ли приложение под Virtual PC? ===
{
 This function can be used to determine whether your program is
 running from within Connectrix's Virtual PC
}
function running_inside_vpc: boolean; assembler;
asm
 push ebp
 mov ecx, offset @@exception_handler
 mov ebp, esp
 push ebx
 push ecx
 push dword ptr fs:[0]
 mov dword ptr fs:[0], esp
 mov ebx, 0 // flag
 mov eax, 1 // VPC function number
 // call VPC
 db 00Fh, 03Fh, 007h, 00Bh
 mov eax, dword ptr ss:[esp]
 mov dword ptr fs:[0], eax
 add esp, 8
 test ebx, ebx
 setz al
 lea esp, dword ptr ss:[ebp-4]
 mov ebx, dword ptr ss:[esp]
 mov ebp, dword ptr ss:[esp+4]
 add esp, 8
 jmp @@ret
 @@exception_handler:
 mov ecx, [esp+0Ch]
 mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running
 add dword ptr [ecx+0B8h], 4 // -> skip past the detection code
 xor eax, eax // exception is handled
 ret
 @@ret:
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01332