nyuuzyou/wikis huggingface dataset:
Цветной ScrollBar

=== Цветной ScrollBar ===
В Windows предусмотрено сообщение WM_CtlColorScrollBar, которое посылается окну, содержащему элементы управления ScrollBar (полосы прокрутки). В ответ на это сообщение окно должно вернуть системе кисть, которой надо закрасить полосу прокрутки. С помощью WM_CtlColorScrollBar можно получать разноцветные полосы прокрутки, что иногда бывает достаточно красиво.
В Delphi форма при получении этого сообщения посылает соответствующему компоненту типа TScrollBar сообщение CN_CtlColorScrollBar, перепоручая обработку ему. И тут мы сталкиваемся с явным глюком VCL: это сообщение передаётся в стандартную оконную процедуру, хотя сообщение само по себе нестандартное, и стандартная процедура заведомо не сможет его обработать. Из-за этого TScrollBar не может изменять свой цвет, хотя львиная доля работы, необходимой для этого, делается в VCL. Чтобы исправить это, достаточно передать обработку CN_CtlColorScrollBar в метод DefaultHandler вместо DefWndProc. Ещё надо перенести в раздел published свойство Color, чтобы получить возможность управлять цветом полосы прокрутки.
Но, несмотря на то, что в VCL здесь явная ошибка, не исправленная, кстати, даже в седьмой версии Delphi, править исходный код StdCtrls всё же не стоит. Вместо этого лучше написать свой компонент, который доделает то, что не доделано в стандартном TScrollBar'е. Код этого компонента будет выглядеть так:
type
 TColorScrollBar=class(TScrollBar)
 private
 procedure CNCtlColorScrollBar(var Msg: TMessage); message CN_CtlColorScrollBar;
 published
 property Color;
 end;
procedure TColorScrollBar.CNCtlColorScrollBar(var Msg: TMessage);
begin
 DefaultHandler(Msg)
end;
Создав и зарегистрировав такой компонент, вы получите возможность управлять цветом полосы прокрутки. К сожалению, управлять цветом стандартных полос прокрутки формы или ScrollBox'а так же легко не получится.
В принципе, реализовав обработку CN_CtlColorScrollBar не с помощью процедуры DefaultHandler, а самостоятельно, можно получить не только цветную полосу прокрутки, но и полосу, раскрашенную разными узорами. Но это я оставлю вам для самостоятельной работы.
Author: Антон Григорьев
http://www.delphikingdom.com
ID: 01230
Цветные строки для TListView

=== Цветные строки для TListView ===
procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
 Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
 with ListView1.Canvas.Brush do
 begin
 case Item.Index of
 0: Color := clYellow;
 1: Color := clGreen;
 2: Color := clRed;
 end;
 end;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01152
Цветные ячейки в StringGrid / DBGrid?

=== Цветные ячейки в StringGrid / DBGrid? ===
StringGrids / DBGrids с цветными ячейками смотрятся очень красиво, и Вы можете информировать пользователя о важных данных внутри Grid.
Совместимость: все версии Delphi
К сожалению, невозможно применить один и тот же метод к StringGrids и к DBGrids. Итак сперва рассмотрим как это сделать в StringGrid: 
==== StringGrid ====
Для раскрашивания будем использовать событие "OnDrawCell". Следующий код показывает, как сделать в Grid красный бэкраунд. Бэкграунд второй колонки будет зелёным. 
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; 
 Rect: TRect; State: TGridDrawState); 
сonst
 // здесь определяем Ваш цвет. Так же можно использовать 
 // цвета по умолчанию. 
 clPaleGreen = TColor($CCFFCC); 
 clPaleRed = TColor($CCCCFF); 
begin 
 // Если ячейка получает фокус, то нам надо закрасить её другими цветами 
 if (gdFocused in State) then
 begin 
 StringGrid1.Canvas.Brush.Color := clBlack; 
 StringGrid1.Canvas.Font.Color := clWhite; 
 end 
 else
 begin
 // Если же ячейка теряет фокус, то закрашиваем её красным и зелёным
 // Вторая колонка будет зелёной, другие - ячейки красными
 if ACol = 2 then
 StringGrid1.Canvas.Brush.color := clPaleGreen 
 else
 StringGrid1.canvas.brush.Color := clPaleRed; 
 end;
 // Теперь закрасим ячейки, но только, если ячейка не Title- Row/Column 
 // Естественно это завит от того, есть у Вас title-Row/Columns или нет. 
 if (ACol > 0) and (ARow > 0) then 
 begin 
 // Закрашиваем бэкграунд 
 StringGrid1.Canvas.FillRect(Rect); 
 // Закрашиваем текст (Text). Также здесь можно добавить выравнивание и т.д.. 
 StringGrid1.canvas.TextOut(Rect.Left,Rect.Top,StringGrid1.Cells[ACol,ARow]); 
 end; 
end; 
Если Вы захотите чтобы цвет ячеек менялся в зависимости от значения в них, то можно заменить 3 линии (if Acol = 2 ......) на что-нибуть вроде этого 
if StringGrid1.Cells[ACol, ARow] = 'highlight it' then
 StringGrid1.Canvas.Brush.color := clPalered
else
 StringGrid1.canvas.brush.Color := clwhite;
Ну а теперь давайте раскрасим DBGrids: 
==== DBGrid ====
С DBGrids это делается намного проще. Здесь мы будем использовать событие "OnDrawColumnCell". Следующий пример разукрашивает ячейки колонки "Status" когда значение НЕ равно "a". 
Если Вы хотите закрасить целую линию, то достаточно удалить условие "If..." (смотрите ниже) 
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
 DataCol: Integer; Column: TColumn;
 State: TGridDrawState);
const
 clPaleGreen = TColor($CCFFCC);
 clPaleRed = TColor($CCCCFF);
begin
 if Column.FieldName = 'Status' then // Удалите эту строку, если хотите закрасить целую строку
 if Column.Field.Dataset.FieldbyName('Status').AsString <> 'a' then
 if (gdFocused in State) then { имеет ли ячейка фокус? }
 dbgrid1.canvas.brush.color := clBlack // имеет фокус
 else
 dbgrid1.canvas.brush.color := clPaleGreen; // не имеет фокуса
 // Теперь давайте закрасим ячейку используя стандартный метод:
 dbgrid1.DefaultDrawColumnCell(rect, DataCol, Column, State)
end;
Вот и всё. Не правда ли красиво ? :)
Source: Взято из http://forum.sources.ru
ID: 00595
Центр вписанной в треугольник окружности

{**** UBPFD *********** by kladovka.net.ru ****
>> Центр вписанной в треугольник окружности
P1, P2, P3 - вершины треугольника.
Зависимости: Windows
Автор: Fenik, fenik@nm.ru, Новоуральск
Copyright: Николай Федоровских
Дата: 29 сентября 2004 г.
********************************************** }
function CenterCircleInTriang(const P1, P2, P3: TPoint): TPoint;
 function LineLength(P1, P2: TPoint): Double;
 begin
 Result := Sqrt(Sqr(P1.X - P2.X) + Sqr(P1.Y - P2.Y));
 end;
var a, b, c, Perim: Double;
begin
 a := LineLength(P1, P2);
 b := LineLength(P2, P3);
 c := LineLength(P3, P1);
 Perim := 1 / (a + b + c);
 Result := Point(Round((b * P1.x + c * P2.x + a * P3.x) * Perim),
 Round((b * P1.y + c * P2.y + a * P3.y) * Perim));
end;
// Пример использования:
function Distance(const P, P1, P2: TPoint): Integer;
{ Расстояние от точки P до прямой P1-P2 }
begin
 Result := Abs(Round(
 ((P1.Y - P2.Y) * P.X +
 (P2.X - P1.X) * P.Y +
 (P1.X * P2.Y - P2.X * P1.Y)) /
 Sqrt(Sqr(P1.X - P2.X) + Sqr(P2.Y - P1.Y))));
end;
procedure TForm1.Button1Click(Sender: TObject);
var P1, P2, P3, C: TPoint;
 L: Integer;
begin
 P1 := Point(60, 160);
 P2 := Point(250, 110);
 P3 := Point(365, 350);
 C := CenterCircleInTriang(P1, P2, P3);
 L := Distance(C, P1, P2);
 with Canvas do begin
 Brush.Color := clWhite;
 Polygon([P1, P2, P3]);
 Brush.Color := clRed;
 Ellipse(C.X - L, C.Y - L, C.X + L, C.Y + L);
 end;
end;
Author: Fenik
ID: 04127
== См. также ==
* Найти центр треугольника
Category:Алгоритмы
Category:Графика
Category:Геометрия
Частичный показ DateTime

=== Частичный показ DateTime ===
При отображении TDateTimeField в DBGrid с форматированием hh:mm (для показа только времени), любая попытка изменения времени приводит (при передаче данных) к ошибке примерно такого содержания: "'07:00 is not a valid DateTime" (07:00 - неверный DateTime). Я хотел бы посылать данные приблизительно в таком виде "Trunc(oldDateTimevalue) + StrToTime(displaytext)" 
Следующий обработчик события TDateTimeField OnSetText не слишком элегантен, но он работает! 
procedure TForm1.Table1Date1SetText(Sender: TField; const Text: String);
var
 d: TDateTime;
 t: string;
begin
 t := Text;
 with Sender as TDateTimeField do 
 begin
 if IsNull then 
 d := SysUtils.Date
 else 
 d := AsDateTime;
 AsDateTime := StrToDateTime(Copy(DateToStr(d),1,8)+' '+t);
 end;
end;
Здесь мы исходим из предположения, что у вас имеется маска редактирования, допускающая формат hh:mm или hh:mm:ss. 
Source: http://delphiworld.narod.ru
ID: 00755
Частота мигания каретки

=== Частота мигания каретки ===
procedure TForm1.Button1Click(Sender: TObject);
begin
 Label1.Caption := Format('Caret blink time is: %d ms', [GetCaretBlinkTime]);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 // Set caret blink time to 2000ms
 SetCaretBlinkTime(2000);
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02339
Чем отличаются «версионники» от «блокировочников»?

=== Чем отличаются «версионники» от «блокировочников»? ===
Классические «блокировочники» не дают возможности разным транзакциям одновременно изменять одни и те же записи, блокируя их на время транзакции. В результате, при попытке изменить заблокированную запись, другая транзакция будет простаивать, пока не завершиться первая. 
В свою очередь, «версионники» позволяют одновременно модифицировать одни и те же записи, создавая при этом разные версии одной записи. 
Source: http://delphiworld.narod.ru/
ID: 02459
Category:Базы данных
Чередование фона строк в TListView

=== Чередование фона строк в TListView ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Чередование фона строк в TListView
Да какое описание...
Вообщем можно просто copy/past сделать...
Хотя реализация не оптимальная, но общая идея - та что нужна =)))
Зависимости: нету =)
Copyright: =) не нужно
Дата: 19 февраля 2003 г.
***************************************************** }
procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
 Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
var
 i: word;
begin
 if Item = nil then
 Exit;
 i := Item.Index;
 if Trunc((i) / 2) < (i / 2) then
 Sender.Canvas.Brush.Color := cl3DLight
 else
 Sender.Canvas.Brush.Color := clwhite;
end;
Source: http://delphibase.endimus.com
ID: 01153
Через DAO/ODBC/ADO

Чтобы использовать только стандартные компоненты давайте попробуем работать с Excel через ADO. Это не самый быстрый и далеко не первый по возможностям метод (DAO работает на порядок быстрее и предоставляет куда больше возможностей), но ADO компоненты входят в стандартную поставку 5 и 6 Дельфи.
Заходим в Панель управления Windows, идем в свойства ODBC, делаем DSN используя Excel драйвер, не забываем указать в свойствах на файл Excel. Закрываем ODBC, открываем Дельфи. Ставим на форму ADOConnection. Идем в ConnectionString - строим строку подключения - надо выбрать только ODBC провайдер и на следующей вкладке указать сделанный DSN, остальные опции в большинстве случаев можно оставить как есть. Строка получена. Кстати ее можно вообще упростить до вида: "DSN=MyDsn". Теперь вам доступны листы файла как таблицы а весь файл как база данных. Подключаем ADOQuery к ADOConnection. Cоздаем таблицу, т.е. новый лист - путем запуска следующей квери:
CREATE TABLE MyTable1 (
 Field1 varchar(20),
 Field2 varchar(10) )
Снова переходим в дизайн - ставим на форму ADOTable, указываем как Connection наш компонент с ADOConnection, теперь если кликнуть на свойстве TableName - вы сможете увидеть в списке сделанную нами таблицу "MyTable1". Соедините таблицу с DBGrid - убедитесь что работа с таблицей в Excel мало отличается от работы с другими базами данных.
Author: Vit
Source: http://forum.vingrad.ru
ID: 04369
Category:COM
Category:MS Office
Через СОМ интерфейс

var
 Excel, WorkBook, Sheet: Variant;
begin
 Excel := CreateOleObject('Excel.Application');
 Excel.WorkBooks.Open(FileName,False);
 WorkBook := Excel.WorkBooks.Item[1];
 Sheet := Workbook.Sheets.Item[3];
 Sheet.Cells[1, 2] := 'ASDFG';
 Sheet.Cells[2, 2] := 230;
end;
Все объекты и методы Офиса можно посмотреть в help'е Офиса.
Author: Fantasist
Source: http://forum.vingrad.ru
ID: 04366
----
Ниже представлен пример создания новой таблице в Excel 2000:
uses
 ComObj, ActiveX;
var
 Row, Col: Integer;
 DestRange: OleVariant;
 Excel: Variant;
begin
 Excel := CreateOleObject('Excel.Application.9');
 Excel.Visible := True;
 Excel.WorkBooks.Add; // Создать новую таблицу
 // Можно помещать текст и значения в диапазон ячеек
 // Поместить слово тест в диапазон ячеек
 Excel.ActiveSheet.Range['A2', 'B3'].Value := 'Тест';
 // Или число
 Excel.ActiveSheet.Range['A4', 'B5'].Value := 42;
 // А вот так задаётся формула
 Excel.ActiveSheet.Range['A10', 'A11'].Formula := '=RAND()';
 // Можно задавать номера ячеек и столбцов
 Excel.ActiveSheet.Cells.Item[1, 1].Value := 'Первая ячейка';
 Row := 1;
 Col := 3;
 Excel.ActiveSheet.Cells.Item[Row, Col].Value := 'Другая ячейка';
 // Можно скопировать данный из одного диапазона ячеек в другой
 DestRange := Excel.Range['D6', 'F10'];
 Excel.Range['A1', 'C5'].Copy(DestRange);
 // Можно задавать параметры шрифта в определённой ячейке
 Excel.Range['A2', 'A2'].Font.Size := 20;
 Excel.Range['A2', 'A2'].Font.FontStyle := 'Bold';
 Excel.Range['A2', 'A2'].Font.Color := clFuchsia;
 Excel.Range['A2', 'A2'].Font.Name := 'Arial';
 // Можно ещё и так изменить цвет диапазона ячеек
 Excel.Range['B2', 'C6'].Interior.Color := RGB(223, 123, 123);
end;
Далее представлен пример открытия и закрытия таблицы:
uses
 ComObj, ActiveX;
var
 Excel: Variant;
 WBk : OleVariant;
 SaveChanges: OleVariant;
begin
 Excel := CreateOleObject('Excel.Application.9');
 Excel.Visible := True;
 // Открыть существующую таблицу
 WBk := Excel.WorkBooks.Open('C:\Test.xls');
 {...}
 WBk.Close(SaveChanges := True);
 Excel.Quit;
end;
Source: Взято из http://forum.sources.ru
ID: 04368
Category:COM
Category:MS Office
Числа Фибоначчи

{
 Fibonacci integers are defined as:
 fib[n+2] = fib[n+1] + fib[n];
 fib[1] = 1;
 fib[0] = 1;
 Example/Beispiel: fib[4] = fib[3] + fib[2] = fib[2] + fib[1] + fib[1] + fib[0] =
 fib[1] + fib[0] + fib[1] + fib[1] + fib[0] = 5
}
function fibit(n: Integer): Integer;
var
 a, b, i, temp: Integer;
begin
 temp := 1;
 a := 1;
 b := 1;
 for i := 1 to n - 1 do
 begin
 temp := a + b;
 a := b;
 b := temp;
 end;
 Result := temp;
end;
function fibrec(n: Integer): Integer;
var
 temp: Integer;
begin
 temp := 0;
 if (n = 0) then temp := 1;
 if (n = 1) then temp := 1;
 if (n > 1) then temp := fibrec(n - 1) + fibrec(n - 2);
 Result := temp;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
 ShowMessage(IntToStr(fibit(10)));
 ShowMessage(IntToStr(fibrec(10)));
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04237
Category:Алгоритмы
Category:Математика
Число текущей недели

=== Число текущей недели ===
function WeekOfYear(ADate: TDateTime): word;
var
 day: word;
 month: word;
 year: word;
 FirstOfYear: TDateTime;
begin
 DecodeDate(ADate, year, month, day);
 FirstOfYear := EncodeDate(year, 1, 1);
 Result := Trunc(ADate - FirstOfYear) div 7 + 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 ShowMessage(IntToStr(WeekOfYear(Date)));
end;
Source: http://delphiworld.narod.ru
ID: 00740
----
function WeekNum(const ADate: TDateTime): word;
var
 Year: word;
 Month: word;
 Day: word;
begin
 DecodeDate(ADate + 4 - DayOfWeek(ADate + 6), Year, Month, Day);
 result := 1 + trunc((ADate - EncodeDate(Year, 1, 5) +
 DayOfWeek(EncodeDate(Year, 1, 3))) / 7);
end;
Source: http://delphiworld.narod.ru
ID: 00741
----
function WeekOfYear(Dat: TDateTime): Word;
// Интерпретация номеров дней:
// ISO: 1 = Понедельник, 7 = Воскресенье
// Delphi SysUtils: 1 = Воскресенье, 7 = Суббота
var
 Day, Month, Year: Word;
 FirstDate: TDateTime;
 DateDiff: Integer;
begin
 day := SysUtils.DayOfWeek(Dat) - 1;
 Dat := Dat + 3 - ((6 + day) mod 7);
 DecodeDate(Dat, Year, Month, Day);
 FirstDate := EncodeDate(Year, 1, 1);
 DateDiff := Trunc(Dat - FirstDate);
 Result := 1 + (DateDiff div 7);
end;
Source: http://delphiworld.narod.ru
ID: 00742
Число цветов (цветовая палитра) у данного компьютера

Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 - 256 цветов, 4 - 16 цветов ...
function GetDisplayColors: Integer;
var
 aHDC: hdc;
begin
 aHDC := GetDC(0);
 Result := GetDeviceCaps(aHDC, 12)* GetDeviceCaps(aHDC, 14);
 ReleaseDC(0, aHDC);
end;
Author: Зайцев О.В.
Author: Владимиров А.М.
Source: http://forum.sources.ru
ID: 03687
----
Result := 1 shl GetDeviceCaps(Canvas.Handle, BITSPIXEL);
Source: http://delphiworld.narod.ru
ID: 03688
== См. также ==
* Как можно узнать количество цветов текущего режима
Category:Графика
Category:Цвета и палитры
Читаем CSV текстовый файл в StringGrid

=== Читаем CSV текстовый файл в StringGrid ===
procedure ReadTabFile(FN: TFileName; FieldSeparator: Char; SG: TStringGrid);
var
 i: Integer;
 S: string;
 T: string;
 Colonne, ligne: Integer;
 Les_Strings: TStringList;
 CountCols: Integer;
 CountLines: Integer;
 TabPos: Integer;
 StartPos: Integer;
 InitialCol: Integer;
begin
 Les_Strings := TStringList.Create;
 try
 Les_Strings.LoadFromFile(FN);
 CountLines := Les_Strings.Count + SG.FixedRows;
 T := Les_Strings[0];
 for i := 0 to Length(T) - 1 do Inc(CountCols,
 Ord(IsDelimiter(FieldSeparator, T, i)));
 Inc(CountCols, 1 + SG.FixedCols);
 if CountLines > SG.RowCount then SG.RowCount := CountLines;
 if CountCols > SG.ColCount then SG.ColCount := CountCols;
 InitialCol := SG.FixedCols - 1;
 Ligne := SG.FixedRows - 1;
 for i := 0 to Les_Strings.Count - 1 do
 begin
 Colonne := InitialCol;
 Inc(Ligne);
 StartPos := 1;
 S := Les_Strings[i];
 TabPos := Pos(FieldSeparator, S);
 repeat
 Inc(Colonne);
 SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1);
 S := Copy(S, TabPos + 1, 999);
 TabPos := Pos(FieldSeparator, S);
 until TabPos = 0;
 end;
 finally
 Les_Strings.Free;
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 Screen.Cursor := crHourGlass;
 ReadTabFile('C:\TEST.TXT', #9, StringGrid1);
 Screen.Cursor := crDefault;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 02973
Category:Базы данных
Category:CSV
Category:StringGrid
Читать значения переменных из JavaScript?

// Just add a Webbrowser and two Buttons to the form and insert the following code
procedure TForm1.Button1Click(Sender: TObject);
begin
 webbrowser1.Navigate('http://www.dasbinich.info/myred/delphi/index.html');
end;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
 const pDisp: IDispatch; var URL: OleVariant);
begin
 if (url = 'http://www.dasbinich.info/myred/delphi/index.html') then
 ShowMessage('Value lautet: ' + webBrowser1.OleObject.Document.Forms.item('test').Elements.item('testen').Value);
 // read the Javascript value testen of the form test
end;
//this is an example how to use it when there are no names
procedure TForm1.Button2Click(Sender: TObject);
begin
 ShowMessage('Value lautet: ' + webBrowser1.OleObject.Document.Forms.item(0).Elements.item(0).Value);
end;
// to read the javascript value from a site with a frame use the following
webBrowser1.OleObject.Document.Frames.item('top').Document.Forms.item('Countdown').Elements.item('Countdown').Value;
// top is the framename in this example
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03467
Category:Связь
Category:WebBrowser
Чтение OLE из Blob поля Paradox

=== Чтение OLE из Blob поля Paradox ===
...после моих дискуссий с людьми из службы технической поддержки Borland вывод один - это невозможно!
Попробуйте так:
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
 b: TBlobStream;
begin
 try
 b := TBlobStream.Create((Table1.FieldByName('OLE') as TBlobField), bmRead);
 OLEContainer1.LoadFromStream(b);
 finally
 b.free;
 end;
end;
...и:
procedure TForm1.SpeedButton2Click(Sender: TObject);
var
 b: TBlobStream;
begin
 try
 Table1.Insert;
 b := TBlobstream.Create((Table1.FieldByName('OLE') as TBlobField), bmReadWrite);
 OLEContainer1.SaveToStream(b);
 Table1.Post;
 finally
 b.free;
 end;
end;
Я, кажется, припоминаю несколько ошибок GPFs с этим кодом, но это, вероятно, связано с тем, что я использую WinNT с другим распределением памяти... тем не менее, основные функции работали как положено (т.е. данные сохранялись и загружались). Основная специфика проявилась в том, что PdoxWIN не смог прочесть данные TOLEContainer. Но это результаты моих экспериментов и предположений, исходя из которых PdoxWIN ожидает 8-байтовый заголовок BLOB-поля, который ему просто не дает TOLEContainer... если это так, то это легко обойти.
Source: Взято с http://delphiworld.narod.ru
ID: 02475
Чтение email адресов из Outlook .dbx файлов

unit ExtractEmailsFunc;
interface
uses
 Windows, SysUtils;
procedure CheckEMail(FilePath: string);
implementation
var
 BufferSize: Integer;
function VerifyFile(strFileName: string): Integer;
var
 intErro: Integer;
 tsrFile: TSearchRec;
begin
 intErro := FindFirst(strFileName, FaAnyFile, tsrFile);
 if intErro = 0 then
 Result := tsrFile.Size
 else
 Result := -1;
 FindClose(tsrFile);
end;
procedure CheckEMail(FilePath: string);
var
 I: Integer;
 hFile: Integer;
 Buffer: PChar;
 StrEmail: string;
begin
 hFile := FileOpen(FilePath, fmOpenRead);
 try
 if hFile = 0 then Exit;
 GetMem(Buffer, bufferSize + 1);
 ZeroMemory(Buffer, BufferSize + 1);
 try
 FileRead(hFile, Buffer^, BufferSize);
 I := 0;
 while I <= BufferSize - 1 do
 begin
 StrEmail := ;
 if Buffer[I] = '<' then
 begin
 Inc(I);
 while (Buffer[I] <> '@') and (I <= BufferSize) do
 begin
 if (Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
 (Buffer[I] = CHR(90)) or ((Buffer[I] > CHR(49)) and (Buffer[I] <= CHR(57)))
 or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
 ((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then
 begin
 StrEmail := StrEmail + Buffer[I];
 end
 else
 begin
 StrEmail := ;
 Break;
 end;
 Inc(I);
 end;
 if StrEmail <> then
 begin
 StrEmail := StrEmail + '@';
 Inc(I);
 while (Buffer[I] <> '.') and (I <= BufferSize) do
 begin
 if (Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
 (Buffer[I] = CHR(90)) or ((Buffer[I] >= CHR(49)) and (Buffer[I] <= CHR(57)))
 or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
 ((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then
 begin
 StrEmail := StrEmail + Buffer[I];
 end
 else
 begin
 StrEmail := ;
 Break;
 end;
 Inc(I);
 end;
 if StrEmail <> then
 begin
 StrEmail := StrEmail + '.';
 Inc(i);
 while (Buffer[I] <> '>') and (I <= BufferSize) do
 begin
 if (Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
 (Buffer[I] = CHR(90)) or ((Buffer[I] >= CHR(49)) and (Buffer[I] <= CHR(57)))
 or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
 ((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then
 begin
 StrEmail := StrEmail + Buffer[I];
 end
 else
 begin
 StrEmail := ;
 Break;
 end;
 Inc(I);
 end;
 if StrEmail <> then
 begin
 WriteLn(StrEmail);
 Inc(I);
 end;
 end;
 end;
 end
 else
 Inc(I);
 end;
 finally
 FreeMem(Buffer);
 end;
 finally
 FileClose(hFile);
 end;
end;
begin
 BufferSize := VerifyFile(ParamStr(1));
 if BufferSize <= 0 then Exit;
 CheckEMail(ParamStr(1));
end.
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04446
Category:COM
Category:MS Office