Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 сентября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Поменять местами пункты ListView

Армянсое радио спрашивают:
- Почему Билл Гейтс такой удачливый и богатый?
- Потому, что каждый его МАТЕРИТ!


 void __fastcall TForm1::SwapLVItems(int a, int b)
 {
    int New;
    ListView1->Items->BeginUpdate();
    {
       ListView1->Items->Add();
       New = ListView1->Items->Count - 1;
       ListView1->Items->Item[New] = ListView1->Items->Item[a];
       ListView1->Items->Item[a] =  ListView1->Items->Item[b];
       ListView1->Items->Item[b] = ListView1->Items->Item[New];
       ListView1->Items->Delete(New);
    }
    ListView1->Items->EndUpdate();
 }
 




Перехват изменения размера колонки в TListView

Разговоp двух новых pусских:
- Я пентиум купил 400 герц!!!
- А что такое 400 геpц?
- ???... скоpость вpащения вентилятоpа!!!


 {
   Question:
   How do I capture a column resize event in TListView, the OnResize
   only works when the ListView is changed?
 
   Answer:
   The event can be added with a bit of work. See the custom TListview derivative
   below. It has 3 new events:
   OnColumnResize, OnBeginColumnResize, OnEndColumnResize
 }
 
 unit PBExListview;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, ComCtrls;
 
 type
   TLVColumnResizeEvent = procedure(Sender: TCustomListview;
     columnindex: Integer;
     columnwidth: Integer) of object;
   TPBExListview = class(TListview)
   private
     FBeginColumnResizeEvent: TLVColumnResizeEvent;
     FEndColumnResizeEvent: TLVColumnResizeEvent;
     FColumnResizeEvent: TLVColumnResizeEvent;
 
   protected
     procedure DoBeginColumnResize(columnindex, columnwidth: Integer);
       virtual;
     procedure DoEndColumnResize(columnindex, columnwidth: Integer);
       virtual;
     procedure DoColumnResize(columnindex, columnwidth: Integer);
       virtual;
     procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
     function FindColumnIndex(pHeader: pNMHdr): Integer;
     function FindColumnWidth(pHeader: pNMHdr): Integer;
     procedure CreateWnd; override;
   published
     property OnBeginColumnResize: TLVColumnResizeEvent
       read FBeginColumnResizeEvent write FBeginColumnResizeEvent;
     property OnEndColumnResize: TLVColumnResizeEvent
       read FEndColumnResizeEvent write FEndColumnResizeEvent;
     property OnColumnResize: TLVColumnResizeEvent
       read FColumnResizeEvent write FColumnResizeEvent;
   end;
 
 procedure Register;
 
 implementation
 
 uses CommCtrl;
 
 procedure Register;
 begin
   RegisterComponents('PBGoodies', [TPBExListview]);
 end;
 
 procedure TPBExListview.DoBeginColumnResize(columnindex, columnwidth: Integer);
 begin
   if Assigned(FBeginColumnResizeEvent) then
     FBeginColumnResizeEvent(Self, columnindex, columnwidth);
 end;
 
 procedure TPBExListview.DoEndColumnResize(columnindex, columnwidth: Integer);
 begin
   if Assigned(FEndColumnResizeEvent) then
     FEndColumnResizeEvent(Self, columnindex, columnwidth);
 end;
 
 procedure TPBExListview.DoColumnResize(columnindex, columnwidth: Integer);
 begin
   if Assigned(FColumnResizeEvent) then
     FColumnResizeEvent(Self, columnindex, columnwidth);
 end;
 
 function TPBExListview.FindColumnIndex(pHeader: pNMHdr): Integer;
 var
   hwndHeader: HWND;
   iteminfo: THdItem;
   ItemIndex: Integer;
   buf: array [0..128] of Char;
 begin
   Result := -1;
   hwndHeader := pHeader^.hwndFrom;
   ItemIndex := pHDNotify(pHeader)^.Item;
   FillChar(iteminfo, SizeOf(iteminfo), 0);
   iteminfo.Mask := HDI_TEXT;
   iteminfo.pszText := buf;
   iteminfo.cchTextMax := SizeOf(buf) - 1;
   Header_GetItem(hwndHeader, ItemIndex, iteminfo);
   if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then
     Result := ItemIndex
   else
   begin
     for ItemIndex := 0 to Columns.Count - 1 do
       if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then
       begin
         Result := ItemIndex;
         Break;
       end;
   end;
 end;
 
 procedure TPBExListview.WMNotify(var Msg: TWMNotify);
 begin
   inherited;
   case Msg.NMHdr^.code of
     HDN_ENDTRACK:
       DoEndColumnResize(FindColumnIndex(Msg.NMHdr),
         FindColumnWidth(Msg.NMHdr));
     HDN_BEGINTRACK:
       DoBeginColumnResize(FindColumnIndex(Msg.NMHdr),
         FindColumnWidth(Msg.NMHdr));
     HDN_TRACK:
       DoColumnResize(FindColumnIndex(Msg.NMHdr),
         FindColumnWidth(Msg.NMHdr));
   end;
 end;
 
 procedure TPBExListview.CreateWnd;
 var
   wnd: HWND;
 begin
   inherited;
   wnd := GetWindow(Handle, GW_CHILD);
   SetWindowLong(wnd, GWL_STYLE,
     GetWindowLong(wnd, GWL_STYLE) and not HDS_FULLDRAG);
 end;
 
 function TPBExListview.FindColumnWidth(pHeader: pNMHdr): Integer;
 begin
   Result := -1;
   if Assigned(PHDNotify(pHeader)^.pItem) and
     ((PHDNotify(pHeader)^.pItem^.mask and HDI_WIDTH) <> 0) then
     Result := PHDNotify(pHeader)^.pItem^.cxy;
 end;
 
 end.
 




Сортировка ListView в режиме vsReport при нажатии на заголовок колонки

Автор: MBo

На выходных с подругой в постели интимничаю, а перед глазами - ник(!!!!) девчушки одной с обаятельной лексикой и дефектной мыльницей (поэтому фотки её у меня нет).... Ну, думаю, это уже из разряда "пора остановиться"...


 function CustomDateSortProc(Item1, Item2: TListItem; ParamSort: integer):
   integer; stdcall;
 begin
   result := 0;
   if strtodatetime(item1.SubItems[0]) > strtodatetime(item2.SubItems[0]) then
     Result := 1
   else if strtodatetime(item1.SubItems[0]) < strtodatetime(item2.SubItems[0])
     then
     Result := -1;
 end;
 
 function CustomNameSortProc(Item1, Item2: TListItem; ParamSort: integer): integer
   item.Caption := sr.name;
   Item.SubItems.Add(datetimetostr(filedatetodatetime(sr.time)));
 end;
 until FindNext(sr) < > 0;
 FindClose(sr);
 end;
 
 procedure TForm1.lv1ColumnClick(Sender: TObject; Column: TListColumn);
 begin
   if column = lv1.columns[0] then
     LV1.CustomSort(@CustomNameSortProc, 0)
   else
     LV1.CustomSort(@CustomDateSortProc, 0)
 end;
 




Прокрутка для TListView или TTreeView

Один квакеp говоpит дpугому:
- Hу что, пошли на pыбалку?
- Сейчас, только Thunderbolt возьму!


 // KEYWORDS:  SendMessage, WM_HSCROLL, WM_VSCROLL
 
 // scroll a ListView vertically down
 SendMessage(ListView1->Handle, WM_VSCROLL, SB_LINEDOWN, 0);
 
 // scroll a TreeView vertically up
 SendMessage(TreeView1->Handle, WM_VSCROLL, SB_LINEUP, 0);
 
 // Here are some other scroll parameters that can be sent...
 
 {
 SB_BOTTOM      Scrolls to the lower right.
 SB_ENDSCROLL   Ends scroll.
 SB_LINEDOWN    Scrolls one line down.
 SB_LINEUP      Scrolls one line up.
 SB_PAGEDOWN    Scrolls one page down.
 SB_PAGEUP      Scrolls one page up.
 SB_TOP         Scrolls to the upper left.
 }
 




Получить список событий и их описание



 unit MethForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, TypInfo, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Listbox1: TListBox;
     ListBox2: TListBox;
     Splitter1: TSplitter;
     procedure Listbox1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   public
     procedure AddType (pti: PTypeInfo);
   end;
 
   procedure ShowMethod (pti: PTypeInfo; sList: TStrings);
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Listbox1Click(Sender: TObject);
 var
   pti: PTypeInfo;
 begin
   pti := PTypeInfo (ListBox1.Items.Objects [
     Listbox1.ItemIndex]);
   ListBox2.Items.Clear;
   ShowMethod (pti, ListBox2.Items);
 end;
 
 type
   TParamData = record
     Flags: TParamFlags;
     ParamName: ShortString;
     TypeName: ShortString;
     // beware: string length varies!!!
   end;
   PParamData = ^TParamData;
 
 // show RTTI information for method pointers
 procedure ShowMethod (pti: PTypeInfo; sList: TStrings);
 var
   ptd: PTypeData;
   pParam: PParamData;
   nParam: Integer;
   Line: string;
   pTypeString, pReturnString: ^ShortString;
 begin
   // protect against misuse
   if pti^.Kind <> tkMethod then
     raise Exception.Create ('Invalid type information');
 
   // get a pointer to the TTypeData structure
   ptd := GetTypeData (pti);
 
   // 1: access the TTypeInfo structure
   sList.Add ('Type Name: ' + pti^.Name);
   sList.Add ('Type Kind: ' + GetEnumName (
     TypeInfo (TTypeKind),
     Integer (pti^.Kind)));
 
   // 2: access the TTypeData structure
   sList.Add ('Method Kind: ' + GetEnumName (
     TypeInfo (TMethodKind),
     Integer (ptd^.MethodKind)));
   sList.Add ('Number of parameters: ' +
     IntToStr (ptd^.ParamCount));
 
   // 3: access to the ParamList
   // get the initial pointer and
   // reset the parameters counter
   pParam := PParamData (@(ptd^.ParamList));
   nParam := 1;
   // loop until all parameters are done
   while nParam <= ptd^.ParamCount do
   begin
     // read the information
     Line := 'Param ' + IntToStr (nParam) + ' > ';
     // add type of parameter
     if pfVar in pParam^.Flags then
       Line := Line + 'var ';
     if pfConst in pParam^.Flags then
       Line := Line + 'const ';
     if pfOut in pParam^.Flags then
       Line := Line + 'out ';
     // get the parameter name
     Line := Line + pParam^.ParamName + ': ';
     // one more type of parameter
     if pfArray in pParam^.Flags then
       Line := Line + ' array of ';
     // the type name string must be located...
     // moving a pointer past the params and
     // the string (including its size byte)
     pTypeString := Pointer (Integer (pParam) +
       sizeof (TParamFlags) +
       Length (pParam^.ParamName) + 1);
     // add the type name
     Line := Line + pTypeString^;
     // finally, output the string
     sList.Add (Line);
     // move the pointer to the next structure,
     // past the two strings (including size byte)
     pParam := PParamData (Integer (pParam) +
       sizeof (TParamFlags) +
       Length (pParam^.ParamName) + 1 +
       Length (pTypeString^) + 1);
     // increase the parameters counter
     Inc (nParam);
   end;
   // show the return type if a function
   if ptd^.MethodKind = mkFunction then
   begin
     // at the end, instead of a param data,
     // there is the return string
     pReturnString := Pointer (pParam);
     sList.Add ('Returns > ' + pReturnString^);
   end;
 end;
 
 procedure TForm1.AddType (pti: PTypeInfo);
 begin
   ListBox1.Items.AddObject(pti^.Name, TObject (pti))
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   AddType (TypeInfo (TNotifyEvent));
   AddType (TypeInfo (TFindMethodEvent));
   AddType (TypeInfo (THelpEvent));
   AddType (TypeInfo (TSetNameEvent));
   AddType (TypeInfo (TDragDropEvent));
   AddType (TypeInfo (TDrawItemEvent));
   AddType (TypeInfo (TMeasureItemEvent));
   AddType (TypeInfo (TScrollEvent));
   AddType (TypeInfo (TDragOverEvent));
   AddType (TypeInfo (TEndDragEvent));
   AddType (TypeInfo (TKeyEvent));
   AddType (TypeInfo (TKeyPressEvent));
   AddType (TypeInfo (TMouseEvent));
   AddType (TypeInfo (TMouseMoveEvent));
   AddType (TypeInfo (TStartDragEvent));
   AddType (TypeInfo (TCloseEvent));
   AddType (TypeInfo (TCloseQueryEvent));
   AddType (TypeInfo (TExceptionEvent));
   AddType (TypeInfo (TIdleEvent));
   AddType (TypeInfo (TMessageEvent));
   AddType (TypeInfo (TShowHintEvent));
 end;
 
 end.

Загрузить весь проект




Создание списка списков (TStringList)

Как мне создать TStringList, содержащий в строке имя объекта, и сам объект TStringList?

TStringList имеет возможность хранить для каждой строки свой указатель: см. свойство Objects. Чтобы понять принцип работы с указателями, смотри в электронной справке описание метода TStringList AddObject. Вот пример работы с методом:


 StringList1.AddObject('Имя списка', TStringList.Create);
 

ПРЕДУПРЕЖДЕНИЕ: Delphi не удаляет эти объекты. Вы должны позаботиться об этом сами.

Вы можете получить доступ к связанному stringlist, назначая его переменной TStringList:


 TempStringList := TStringList(StringList1.Objects[index]);
 

Приведенный ниже код правильно компилируется, правильно выполняется и правильно демонстрирует все вышесказанное. Form1 имеет только один компонент Label.


 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, Grids, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Label1: TLabel;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     StringList1, TempStringList: TStringList;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   StringList1 := TStringList.Create;
   StringList1.AddObject('имя', TSTringList.Create);
   TempStringList := TStringList(StringList1.Objects[0]);
   TempStringList.Add('Привет');
   Label1.Caption := TempStringList[0];
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 var
   i: Longint;
 begin
   for i := 0 to StringList1.Count - 1 do
   begin
     TempStringList := TStringList(StringList1.Objects[i]);
     TempStringList.Free;
   end;
 end;
 
 end.
 




Список структуры полей таблицы

В данном проекте создается список структуры полей соответствующей таблицы, с использованием массивов Fields и IndexDefs, который затем отображается в компоненте ListBox. Демонстрационный проект (dbbrowsr.dpr) решает эту задачу несколько иначе. Вы можете сравнить две версии этого кода.

Примечание: Данный код работает только в 16-битной среде.


 procedure TForm1.Button1Click(Sender: TObject);
 const
   MyFielddefs: array[ftUnknown..ftGraphic] of string[8] =
   ('Unknown', 'String', 'Smallint', 'Integer', 'Word',
     'Boolean', 'Float', 'Currency', 'BCD', 'Date',
     'Time', 'DateTime', 'Bytes', 'VarBytes', 'Blob',
     'Memo', 'Graphic');
 var
   i, Indx: integer;
   Definition: string;
 begin
   for i := 0 to Table1.FieldCount - 1 do
   begin
     Definition := Table1.Fields[i].DisplayLabel;
     Definition := Definition + ' ' +
       MyFieldDefs[Table1.Fields[i].DataType];
     Table1.IndexDefs.Update;
     if Table1.Fields[i].IsIndexField then
     begin
       Indx := Table1.IndexDefs.Indexof(Table1.Fields[i].Name);
       if Indx > -1 then
         if ixPrimary in Table1.IndexDefs[Indx].Options then
           Definition := Definition + ' (Первичный)';
     end;
     Listbox1.Items.Add(Definition);
   end;
 end;
 

Приведенная выше версия не работает в 32-битной среде, поскольку в ней присутствуют дополнительные типы полей. Вот версия, которая работает в 32-битной среде:


 procedure TForm1.Button1Click(Sender: TObject);
 const
   MyFielddefs: array[ftUnknown..ftTypedBinary] of string[11] =
   ('Unknown', 'String', 'Smallint', 'Integer',
     'Word', 'Boolean', 'Float', 'Currency', 'BCD',
     'Date', 'Time', 'DateTime', 'Bytes', 'VarBytes',
     'AutoInc', 'Blob', 'Memo', 'Graphic', 'FmtMemo',
     'ParadoxOle', 'DBaseOle', 'TypedBinary');
 var
   i, Indx: integer;
   Definition: string;
 begin
   for i := 0 to Table1.FieldCount - 1 do
   begin
     Definition := Table1.Fields[i].DisplayLabel;
     Definition := Definition + ' ' +
       MyFieldDefs[Table1.Fields[i].DataType];
     Table1.IndexDefs.Update;
     if Table1.Fields[i].IsIndexField then
     begin
       Indx := Table1.IndexDefs.Indexof(Table1.Fields[i].Name);
       if Indx > -1 then
         if ixPrimary in Table1.IndexDefs[Indx].Options then
           Definition := Definition + ' (Первичный)';
     end;
     Listbox1.Items.Add(Definition);
   end;
 end;
 




Маааленькое PING-приложеньице


Два интеpнетчика:
- Попингуй!
- От попингуя слышу.

Протокол Ping предназначен для тестирования компьютерных соединений в Интернете путём посылки через протокол Internet Protocol (IP) по обределённому адресу сообщения и ожидания от него ответа.

ICMP - Internet Control Message Protocol. ICMP служит для передачи сообщений об ошибках а так же управляющих сообщений . ICMP-тест может показать насколько быстро проходит информация между двумя узлами в Интернете.

  1. Запускаем Delphi;
  2. В Новом проекте добавляем в форму Tbutton, Tedit и Tmemo;
  3. Вставляем “winsock”;
  4. объявляем структурку для IP-заголовка:

 type
   IPINFO = record
   Ttl: char;
   Tos:har;
   IPFlags: char;
   OptSize: char;
   Options: ^char;
 end;
 

  1. объявляем структурку для хранения ICMP пакета:

 type
   ICMPECHO = record
   Source: longint;
   Status: longint;
   RTTime: longint;
   DataSize: Shortint;
   Reserved: Shortint;
   pData: ^variant;
   i_ipinfo: IPINFO;
 end;
 

  1. Объявляем функции и процедуры, которые мы будем вызывать из ICMP.DLL

 TIcmpCreateFile = function():integer;
 {$IFDEF WIN32} stdcall; {$ENDIF}
 
 TIcmpCloseHandle = procedure(var handle: integer);
 {$IFDEF WIN32} stdcall; {$ENDIF}
 
 TIcmpSendEcho = function(var handle: integer; endereco: DWORD;
 buffer: variant; tam: WORD; IP: IPINFO; ICMP: ICMPECHO;
 tamicmp: DWORD; tempo: DWORD): DWORD;
 {$IFDEF WIN32} stdcall; {$ENDIF}
 

  1. В TButton в событие Onclick вставляем следующий код:

 procedure TForm1.Button1Click(Sender: TObject);
 var
   wsadt : wsadata;
   icmp :icmpecho;
   HNDicmp : integer;
   hndFile :integer;
   Host :PHostEnt;
   Destino :in_addr;
   Endereco :^DWORD;
   IP : ipinfo;
   Retorno :integer;
   dwRetorno :DWORD;
   x :integer;
 
   IcmpCreateFile : TIcmpCreateFile;
   IcmpCloseHandle : TIcmpCloseHandle;
   IcmpSendEcho : TIcmpSendEcho;
 
 begin
   if (edit1.Text = '') then
   begin
     Application.MessageBox('Enter a HostName ro a IP Adress', 'Error', MB_OK);
     exit;
   end;
   HNDicmp := LoadLibrary('ICMP.DLL');
   if (HNDicmp <> 0) then
   begin
     @IcmpCreateFile := GetProcAddress(HNDicmp,'IcmpCreateFile');
     @IcmpCloseHandle := GetProcAddress(HNDicmp,'IcmpCloseHandle');
     @IcmpSendEcho := GetProcAddress(HNDicmp,'IcmpSendEcho');
     if (@IcmpCreateFile=nil) or (@IcmpCloseHandle=nil) or (@IcmpSendEcho=nil) then
     begin
       Application.MessageBox('Error getting ICMP Adress’,'Error', MB_OK);
       FreeLibrary(HNDicmp);
     end;
   end;
   Retorno := WSAStartup($0101,wsadt);
 
   if (Retorno <> 0) then
   begin
     Application.MessageBox('Canґt Load WinSockets','WSAStartup', MB_OK);
     WSACleanup();
     FreeLibrary(HNDicmp);
   end;
 
   Destino.S_addr := inet_addr(Pchar(Edit1.text));
   if (Destino.S_addr = 0) then
     Host := GetHostbyName(PChar(Edit1.text))
   else
     Host := GetHostbyAddr(@Destino,sizeof(in_addr), AF_INET);
 
   if (host = nil) then
   begin
     Application.MessageBox('Host not found','Error', MB_OK);
     WSACleanup();
     FreeLibrary(HNDicmp);
     exit;
   end;
   memo1.Lines.Add('Pinging ' + Edit1.text);
 
   Endereco := @Host.h_addr_list;
 
   HNDFile := IcmpCreateFile();
   for x:= 0 to 4 do
   begin
     Ip.Ttl := char(255);
     Ip.Tos := char(0);
     Ip.IPFlags := char(0);
     Ip.OptSize := char(0);
     Ip.Options := nil;
 
     dwRetorno := IcmpSendEcho(
     HNDFile,
     Endereco^,
     null,
     0,
     Ip,
     Icmp,
     sizeof(Icmp),
     DWORD(5000));
     Destino.S_addr := icmp.source;
     Memo1.Lines.Add('Ping ' + Edit1.text);
   end;
 
   IcmpCLoseHandle(HNDFile);
   FreeLibrary(HNDicmp);
   WSACleanup();
 end;
 

У данного примера есть один недостаток - программа не воспримет доменное имя, только IP-адресс. Для пользователей NT не используйте функцию IcmpCloseHandle.

Это всё…..

Ну и в конце полный исходный код примера можно взять здесь.




Загрузка и анализ документа XML

Обмен информацией в формате XML - это чрезвычайно удобный механизм, позволяющий свести к минимуму проблемы внутрифирменных форматов данных. Эти проблемы сводятся к сложностям при обмене информацией с контрагентами фирмы. Зачастую проблема стоит не только в невозможности других воспринимать предлагаемый вами формат (DBF, ASCII и т.п.), сколько в нежелании приспосабливаться к ним. Эти форматы не очень удобны. К тому же у вашего партнера наверняка уже есть наработки в этой области. Так почему бы вам не приспособится к его формату обмена данными?

Язык XML позволяет разрабатывать форматы описания данных, которые могут стать тем мостиком, котрый свяжет всех контрагентов и устранит технические и психологические барьеры, неизбежно возникающие при приспособлении к чужим технологиям.

Технология XML тоже не назовешь родной, однако ее возможности и универсальность при описании текстовых данных перекрывают все сложности, связанные с ее освоением.

Формировать документы в формате XML достаточно просто. Следует лишь познакомится с конкретным DTD и образцами корректных документов. А вот загрузка может быть достаточно трудна, если не прибегать к помощи готовых решений в виде XML парсеров. Их довольно много для разных платформ и при желании можно найти их описания в WWW. Одним из наиболее распространенным на платформе Windows является Microsoft XML Parser. Дело в том, что он входит в состав Microsoft Explorer 5.0 и более позние версии. Он доступен в виде объекта ActiveX. Данный парсер является верифицирующим, то есть проверяет не только синтаксическую проверку документа, но и семантическую корректность в соответствии с заданным DTD.

Для загрузки и анализа документа в Delphi рассмотрим следующий код.


 {Вспомогательная функция. Формирует текст сообщения об ошибке
 Вход : Error: TXMLDOMParseError
 Выход : Отчет об ошибке }
 function getParseError(Error: Variant): string;
 begin
   Result := 'Ошибка при загрузке документа ["' + Error.url + ' ]'#13#10
   + Error.reason + #13#10#13#10;
 
   if (Error.line > 0) then
     Result := Result + 'строка ' + Error.line + ', символ ' + error.linepos + #13#10
     + Error.srcText;
 end;
 
 
 
 {Загружает файл в Microsoft.XMLDOM. Строит дерево DOM в TreeView
 Вход : Имя файла XML}
 procedure TfImport.LoadOnixDoc(const FileName: string);
 var
   XML, parseError: variant;
   Node, mainNode, childNodes: variant;
   i: integer;
   TreeNode: TTreeNode;
 
   { рекурсивно обходит дерево элементов и заполняет TreeView }
   procedure LoadItems(TreeNode: TTreeNode; Node: variant);
   var
     i: integer;
   begin
     TreeNode := TV.Items.AddChild(TreeNode, Node.nodeName);
     TreeNode.ImageIndex := TreeNode.Level;
     TreeNode.SelectedIndex := TreeNode.ImageIndex;
     if Node.nodeName = '#text' then
     begin
       TreeNode.Text := Node.nodeValue;
       TV.SetNodeBoldState(TreeNode, true);
     end;
     for i:=0 to Node.childNodes.length-1 do
       LoadItems(TreeNode, Node.childNodes.item[i]);
   end;
 
 begin
   XML := CreateOleObject('Microsoft.XMLDOM');
 
   // async
   // Свойство, доступное для записи и чтения,
   // идентифицирующее текущий режим обработки (синхронный или асинхронный)
   XML.Async := false;
 
   // load(url)
   // Загружает документ, адрес которого задан параметром url.
   // В случае успеха возвращает логическое значение true. Необходимо иметь в виду,
   // что вызов этого метода сразу же обнуляет содержимое текущего документа
   XML.load(FileName);
 
   // Можно загружать из строки:
   // loadXML(xmlString)
   // Загружает XML - фрагмент, определенный в передаваемой строке
 
   // parseError
   // Возвращает ссылку на объект XMLDOMParseError, при помощи которого
   // можно получить всю необходимую информацию о последней ошибке анализатора. 
   // Только для чтения.
   if XML.parseError.errorCode <> 0 then
   begin
     ShowMessage( getParseError(XML.parseError) );
   end
   else
   begin
     mainNode := XML.documentElement;
 
     { Загрузка DOM в TreeView }
     LoadItems(nil, mainNode);
     // дерево DOM построено в TreeView
 
 
     TreeNode := TV.Items[1];
     while Assigned(TreeNode) do
     begin
       TreeNode.Expand(false);
       TreeNode := TreeNode.GetNextSibling;
     end;
     if Assigned(TV.Items[0]) then
       TV.Items[0].Expand(false);
 
   end;
 end;
 

Пример документа XML Onix:


<?xml version="1.0" encoding="windows-1251"?>
<!DOCTYPE ONIXMessage SYSTEM "onix-international.dtd">

<ONIXMessage release="1.1">

<FromCompany>ТД Библио-Глобус</FromCompany>
<FromPerson>Kirillov Alexey kirillov@biblio-globus.u</FromPerson>
<ToCompany>EDItEUR</ToCompany>
<ToPerson>EDItEUR chief manager</ToPerson>
<MessageNumber>1</MessageNumber>
<SentDate>23.12.00</SentDate>
<DefaultLanguageOfText>rus</DefaultLanguageOfText>
<Product>
<RecordReference>247825</RecordReference>
<NotificationType>3</NotificationType>
<ISBN>966-7393-05-4</ISBN>
<ProductForm>BB</ProductForm>
<DistinctiveTitle>SQL энциклопедия пользователя</DistinctiveTitle>
<Contributor>
<ContributorSequenceNumber>0</ContributorSequenceNumber>
<ContributorRole>A01</ContributorRole>
<PersonName>Х. Ладани</PersonName>
<PersonNameInverted>Ладани, Х.</PersonNameInverted>
<BiographicalNote>Книга раскрывает темы, которые часто
не описываются или достаточно кратко представлены в
руководствах пользователя
- подзапросы, структуры данных, представления, 
производительность, целостность и защита данных.
</BiographicalNote>
</Contributor>
<NumberOfPages>624</NumberOfPages>
<ImprintName>ДиаСофт</ImprintName>
<MediaFile>
<MediaFileTypeCode>04</MediaFileTypeCode>
<MediaFileFormatCode>03</MediaFileFormatCode>
<MediaFileLinkTypeCode>06</MediaFileLinkTypeCode>
<MediaFileLink>
http://shop.biblio-globus.ru/photos1/05/58983.jpg
</MediaFileLink>
</MediaFile>
<SupplyDetail>
<SupplierName></SupplierName>
<AvailabilityCode></AvailabilityCode>
<Price>
<PriceTypeCode>01</PriceTypeCode>
<PriceAmount>425</PriceAmount>
<CurrencyCode>RUB</CurrencyCode>
</Price>
</SupplyDetail>
</Product>
</ONIXMessage>




Как загрузить адресную книгу

Автор: Севостьянов Игорь

Возвращается домой в хлам пьяный программист. По пути заглядывает в почтовый ящик и обнаруживает там письмо. Прочитав его, на обороте пишет ответ, и запечатав письмо кладет обратно в свой ящик. Утром, идя на работу в том же состоянии, опять заглядывает в почтовый ящик и обнаруживает вчерашнее письмо.
- Блин, я же ставил не сохранять отправленные письма.


 uses Mapi;
 ...
 
 procedure TfrmMain.btnOpenAddressBookClick(Sender: TObject);
 var
   lhSession, rc: Cardinal;
   lpnNewRecips: PULONG;
   lppNewRecips: PMapiRecipDesc;
   lpRecips: MapiRecipDesc;
 begin
   lpnNewRecips := nil;
   rc := MAPILogon(0, 'Севостьянов Игорь', '', MAPI_LOGON_UI, 0, @lhSession);
   if (rc < > SUCCESS_SUCCESS) then
     SysErrorMessage(rc);
   rc := MAPIAddress(lhSession, 0, 'Адресная книга', 0, '', 0, lpRecips, 0, 0,
     lpnNewRecips, lppNewRecips);
   if (rc < > SUCCESS_SUCCESS) then
     SysErrorMessage(rc)
   else
     rc := MAPIFreeBuffer(lppNewRecips); // free the memory used by MAPIAddress
   if (rc < > SUCCESS_SUCCESS) then
     SysErrorMessage(rc);
   rc := MAPILogoff(lhSession, 0, 0, 0);
   if (rc < > SUCCESS_SUCCESS) then
     SysErrorMessage(rc);
 end;
 

Есть еще и в Deplhi Help C:\Program Files\Common Files\Borland Shared\MSHelp\mapi.hlp




Заставить приложение загружать и проигрывать звуковой файл

Священник, врач и программист играли вместе в гольф. Переходя от лунки к лунке, они вскорости догнали трех игроков, которые двигались страшно медленно. Возмущенные, они вызвали управляющего и спросили его, в чем дело?... Управляющий:
- Видите ли, несколько лет тому назад в нашем клубе был пожар. А эти трое ребят спасли нас от полного уничтожения. К сожалению, в результате ожогов они потеряли зрение. А мы в знак благодарности разрешили им играть у нас в гольф совершенно бесплатно.
Священник (сконфуженно):
- О!!! Я буду горячо молиться, чтобы Бог вернул им зрение!!
Bрач (виновато):
- Я знаком с одним из лучших офтальмологов мира. Может, он сможет...
Программист (небрежно):
- А че они ночью не играют!

  1. Для проигрывания звукового файла используйте непосредственно функцию sndPlaySound().
  2. Считывайте звуковой файл в память, затем для его проигрывания используйте sndPlaySound()
  3. Используйте sndPlaySound для непосредственного проигрывания звуковых файлов, расположенных в файлах ресурсов, прилинкованных к вашему приложению.
  4. Считывайте звуковой файл, располагаемый в файле ресурса, прилинкованному к вашему приложению, в память, и затем для его проигрывания используйте sndPlaySound().
Для построения проекта вам понадобиться:
  1. Создайте звуковой файл с именем 'hello.wav' в каталоге проекта.
  2. Создайте текстовый файл с именем 'snddata.rc' в каталоге проекта.
  3. Добавьте следующую строку к файлу 'snddata.rc': HELLO WAVE hello.wav
  4. В dos-сессии перейдите в ваш каталог приложения и скомпилируйте .rc-файл, используя компилятор ресурсов Borland (brcc32.exe): введите путь к brcc32.exe и передайте 'snddata.rc' в качестве параметра.
Пример:

bin\brcc32 snddata.rc

Это создаст файл 'snddata.res', который Delphi слинкует с EXE-файлом вашего приложения.

Далее приведен необходимый вам код:


 unit PlaySnd1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     PlaySndFromFile: TButton;
     PlaySndFromMemory: TButton;
     PlaySndbyLoadRes: TButton;
     PlaySndFromRes: TButton;
     procedure PlaySndFromFileClick(Sender: TObject);
     procedure PlaySndFromMemoryClick(Sender: TObject);
     procedure PlaySndFromResClick(Sender: TObject);
     procedure PlaySndbyLoadResClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 {$R snddata.res}
 
 uses MMSystem;
 
 procedure TForm1.PlaySndFromFileClick(Sender: TObject);
 begin
   sndPlaySound('hello.wav', SND_FILENAME or SND_SYNC);
 end;
 
 procedure TForm1.PlaySndFromMemoryClick(Sender: TObject);
 var
   f: file;
   p: pointer;
   fs: integer;
 begin
   AssignFile(f, 'hello.wav');
   Reset(f, 1);
   fs := FileSize(f);
   GetMem(p, fs);
   BlockRead(f, p^, fs);
   CloseFile(f);
   sndPlaySound(p, SND_MEMORY or SND_SYNC);
   FreeMem(p, fs);
 end;
 
 procedure TForm1.PlaySndFromResClick(Sender: TObject);
 begin
   PlaySound('HELLO', hInstance, SND_RESOURCE or SND_SYNC);
 end;
 
 procedure TForm1.PlaySndbyLoadResClick(Sender: TObject);
 var
   h: THandle;
   p: pointer;
 begin
   h := FindResource(hInstance, 'HELLO', 'WAVE');
   h := LoadResource(hInstance, h);
   p := LockResource(h);
   sndPlaySound(p, SND_MEMORY or SND_SYNC);
   UnLockResource(h);
   FreeResource(h);
 end;
 
 end.
 




Как загрузить и отмасштабировать JPEGImage в TImage


 try
   Image1.Picture.Graphic := nil;
   Image1.Picture.LoadFromFile(jpegfile);
 except
   on EInvalidGraphic do
     Image1.Picture.Graphic := nil;
 end;
 if Image1.Picture.Graphic is TJPEGImage then
 begin
   TJPEGImage(Image1.Picture.Graphic).Scale := Self.Scale;
   TJPEGImage(Image1.Picture.Graphic).Performance := jpBestSpeed;
 end;
 




Загрузка Bitmap из .res без потери палитры


 procedure loadgraphic(naam:string);
 var
   HResInfo: THandle;
   BMF: TBitmapFileHeader;
   MemHandle: THandle;
   Stream: TMemoryStream;
   ResPtr: PByte;
   ResSize: Longint;
   null:array [0..8] of char;
 begin
   strpcopy (null, naam);
   HResInfo := FindResource(HInstance, null, RT_Bitmap);
   ResSize := SizeofResource(HInstance, HResInfo);
   MemHandle := LoadResource(HInstance, HResInfo);
   ResPtr := LockResource(MemHandle);
   Stream := TMemoryStream.Create;
   try
     Stream.SetSize(ResSize + SizeOf(BMF));
     BMF.bfType := $4D42;
     Stream.write(BMF, SizeOf(BMF));
     Stream.write(ResPtr^, ResSize);
     Stream.Seek(0, 0);
     Bitmap:=tbitmap.create;
     Bitmap.LoadFromStream(Stream);
   finally
     Stream.Free;
   end;
   FreeResource(MemHandle);
 end;
 




Загрузка иконки

Автор: Neil

А по утрам я плохо загружаюсь...

Если ваша иконка хранится в компоненте Image (видимым или иным способом), вы можете написать:


 Application.Icon := Image1.Picture.Icon;
 

Если в файле ресурса:


 Application.Icon.Handle := LoadIcon(hInstance, 'ICONNAME');
 

В любом случае для форсирования показа иконки необходимо вызвать следующую функцию:


 InvalidateRect(Application.Handle, NIL, True);
 

.. и новая иконка предстанет свету.

Иконка, расположенная в .RES-файле, должна быть видима в .EXE-файле, к примеру, при просмотре файла посредством Program Manager. Иконка, расположенная в компоненте Image, в этом случае не видна.




Загрузка изображения или курсора из RES-файла

Загрузка изображений и курсоров из RES-файлов

Изображения и курсоры могут храниться в файлах ресурсов (RES) и прилинковываться (связаваться) к EXE-файлу вашего приложения. RES-файлы могут создаваться с помощью Delphi утилит Image Editor и Borland Resource Workshop, входящие в поставку Delphi RAD Pack. Изображения и курсоры, хранимые в RES-файлах (после упаковки их в EXE или DLL) могут быть извлечены с помощью API функций LoadBitmap и LoadCursor соответственно.

Загрузка изображений

Функция API LoadBitmap определена следующим образом:


 function LoadBitmap(Instance: THandle; BitmapName: PChar): HBitmap;
 

Первый параметр должен содержать дескриптор модуля (EXE или DLL), содержащего файл RES, из которого вы хотите получить ресурс. Delphi хранит дескриптор запущенного EXE-файла в глобальной переменной с именем Hinstance. В приведенном ниже примере мы предполагаем, что модуль, из которого мы пытаемся загрузить изображение, - ваше приложение. Тем не менее, модуль мог бы быть другим EXE- или DLL-файлом. Следующий пример загружает изображение с именем BITMAP_1 из RES-файла, прилинкованного к EXE-файлу приложения:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Bmp: TBitmap;
 begin
   Bmp := TBitmap.Create;
   Bmp.Handle := LoadBitmap(HInstance,'BITMAP_1');
   Canvas.Draw(0, 0, Bmp);
   Bmp.Free;
 end;
 

Имеется один недостаток использования API вызова LoadBitmap: LoadBitmap все же является API вызовом Windows 3.0, и грузит изображение только как DDB (Device Dependent Bitmaps). Это может вызвать проблемы с цветовой палитрой при загрузке DIB (Device Independent Bitmaps) из RES-файла. Приведенный ниже код может использоваться для извлечения DIB-ов из RES-файлов. Данный код загружает изображение как общий ресурс, передает его в поток, после чего делает Delphi вызов LoadFromStream, реализующий палитру автоматически.


 procedure TForm1.Button1Click(Sender: TObject);
 const
   BM = $4D42; {Идентификатор типа изображения}
 var
   Bmp: TBitmap;
   BMF: TBitmapFileHeader;
   HResInfo: THandle;
   MemHandle: THandle;
   Stream: TMemoryStream;
   ResPtr: PByte;
   ResSize: Longint;
 begin
   BMF.bfType := BM;
   {Ищем, загружаем и блокируем ресурс, содержащий BITMAP_1}
   HResInfo := FindResource(HInstance, 'BITMAP_1', RT_Bitmap);
   MemHandle := LoadResource(HInstance, HResInfo);
   ResPtr := LockResource(MemHandle);
 
   {Создаем Memory-поток, устанавливаем его размер, записываем
   туда заголовок изображения и, наконец, само изображение }
   Stream := TMemoryStream.Create;
   ResSize := SizeofResource(HInstance, HResInfo);
   Stream.SetSize(ResSize + SizeOf(BMF));
   Stream.Write(BMF, SizeOf(BMF));
   Stream.Write(ResPtr^, ResSize);
 
   {Освобождаем поток и сбрасываем его позицию в 0}
   FreeResource(MemHandle);
   Stream.Seek(0, 0);
 
   {Создаем TBitmap и загружаем изображение из MemoryStream}
   Bmp := TBitmap.Create;
   Bmp.LoadFromStream(Stream);
   Canvas.Draw(0, 0, Bmp);
   Bmp.Free;
   Stream.Free;
 end;
 

Загрузка курсоров

Функция API LoadCursor определена следующим образом:


 function LoadCursor(Instance: THandle; CursorName: PChar): HCursor;
 

Первый параметр Instance должен содержать дескриптор модуля, содержащего файл RES. Как и пример, приведенный выше, данный пример предполагает, что модуль, из которого мы пытаемся загрузить курсор, - ваше приложение. Второй параметр - имя курсора. В секции interface сделайте следующее объявление:


 const
   crMyCursor = 5; {Другие модули могут также использовать эту константу}
 

Затем добавьте следующие две строчки к обработчику события формы OnCreate:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Screen.Cursors[crMyCursor] := LoadCursor(HInstance, 'CURSOR_1');
   Cursor := crMyCursor;
 end;
 

или же вы можете изменить один из стандартных курсоров Delphi как показано ниже (константы Cursor описаны в электронной справке в статье Cursors Property):


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   {Данный пример изменяет курсор SQL Hourglass}
   Screen.Cursors[crSQLWait] := LoadCursor(HInstance, 'CURSOR_1');
 end;
 

Примечание: в нормальной ситуации необходимо удалить любые ресурсы курсоров с помощью DeleteCursor, тем не менее, в Delphi в этом нет необходимости, поскольку Delphi сама удаляет все курсоры из массива Cursors.




О загрузке дочерней формы (MDIChild) из DLL

Данную статью меня заставило написать огромное количество вопросов в Круглом Столе (а теперь еще и в Подводных Камнях) насчет размещения дочерней формы в библиотеке DLL. Честно говоря, у меня никогда не возникало такой необходимости и я обходился простым приложением. Но масса вопросов без ответа посадило меня за кнопки вечерком. Говорят, что те ответы, которые, тем не менее, присутствуют, не работающие. И проверять мне их совсем не хотелось. Я решил начать решать проблему с нуля.

Поначалу я решил досконально разобраться в работе TForm и TApplication дабы точно представлять себе, как эти оболочки взаимодействуют с Windows, но потом понял, что ковыряться в сотнях строк исходников мне совсем неохота. Я просто посмотрел и увидел, что кроме, собственно handl-ов эти компоненты оперируют со своими всяческими внутренними служебными списками (обычно TList) и передачей хэндла тут не обойдешься. Для работы форм необходимы оба глобальных (для программы) объекта: и TApplication и TScreen. Подг ружаемая DLL, если использует разного рода формы и контролы их тоже создает. Но они другие! В смысле другие instances, которые и знать не знают о таких-же объектах в главном приложении. Но они есть и убивать их тоже не хочется (мало-ли чего случится, если убить объект TApplication, даже в DLL). Поэтому решение пришло следующее. Создаем в нашей DLL две служебные функции, функцию вызова нашей дочерней формы и две переменные (пишу StdCall потому что всегда DLL-ки так оформляю, это удобно):


 var
   DLLApp: TApplication;
   DLLScr: TScreen;
 
 procedure InitPlugin(App, Scr: integer); StdCall;
 begin
   DLLScr := Screen;
   Screen := TScreen(Scr);
   DLLApp := Application;
   Application := TApplication(App);
 end;
 
 procedure DonePlugin; StdCall;
 begin
   Screen := DLLScr;
   Application := DLLApp;
 end;
 
 function CreateMDI: integer; StdCall;
 begin
   Result := integer(TfrmMyChildForm.Create(Application));
 end;
 
 exports
   InitPlugin,
   DonePlugin,
   CreateMDI;
 
 

Итак, в начале программы я открываю библиотеку (LoadLibrary), пролучаю функции (GetProcAddress) и инициализируюплагин (InitPlugin(integer(Application), integer(Screen))), передавая ему ссылки на объекты Application и Screen и они сохраняются в переменных внутри DLL. По окончании работы я его деинициализирую (DonePlugin), восстанавливая для dll-ки его объекты (для корректной деинициализации этих самых внутренних TApplication и TScreen), потом выгружаю библотеку (FreeLibrary). Функция создания дочернего окн а возвращает объект формы (а по сути указатель) и с ним можно работать, либо используя переменную - родителя (TForm например) или абстрактный класс с которого наследуется форма в DLL (MyForm := TForm(CreateMDI)).

Неприятности такого похода состоят в том, что разные инструменты разработки (и даже разные версии одной и той же среды) могут быть (скорее всего, но я не проверял) несовместимы. Т.е. DLL с формой, изготовленной в одной версии Дельфи может не работать с пр иложением, скомпилированным в другой. Ведь внутренние структуры объектов и таблицы методов могут не совпадать. Но это не слишком дорого. Есть еще пробляма дублирования кода VCL. Но что делать! Или так или пакеты. Вообще говоря в наше время гигабайтов и Wi n2K спорить о сотне килобайт просто скучно.

Для дех, у кого не вышло: я написал и скомпилировал тестовый пример (Delphi 2). Он работает. Все возможности MDI сохраняются, вроде menu-merging, меню Window и Caption в главной форме. Тексты и скомпилированное приложение прилагаются.

Напоследок. Я не претендую на полное исследование темы. Возможно в других версиях Дельфи есть и другие необходимые глобальные обьекты. Возможно, если формы будут использовать печать, то необходимо передать таким-же образом и объект Printer, однако это сам и можете проверить. Стоит посмотреть, чем занимается delphimm.dll, ведь она устраивает общий менеджер памяти, может и еще чего интересное делает. Удачи всем.




Загрузить RTF файл из ресурса своего EXE


 (*
   Load RTF file from resource:
 
   You can store any kind of file as a RCDATA resource.
   The following example shows this with an RTF file.
 
   Create a text file called textres.rc and put the
   following line in it:
 
   TESTDOC RCDATA "textdoc.rtf"
 
   Next, compile that using the Borland Resource Compiler,
   which is provided with Delphi.
 
   brcc32.exe textres.rc
 
   Your next step is to include the compiled resource (.RES) file into
   your executable, which can be done with the {$R} compiler directive.
 
 *)
 
 (*
 
   Man kann eine beliebige Datei als RCDATA Ressource in eine
   Exe-Datei einbinden.
   Das folgende Beispiel zeigt, wie man einen RTF-Text aus
   einer Ressource ladt und in einem TRichEdit anzeigt.
 
   Erstelle zuerst eine Datei "textres.rc" mit folgendem Inhalt:
 
   TESTDOC RCDATA "textdoc.rtf"
 
   Kompiliere diese mit brcc32.exe:
 
   brcc32.exe textres.rc
 
   Es wurde nun eine textres.res Datei erzeugt.
 
 *)
 
 
 implementation
 
 {$R *.dfm}
 {$R textres.res}  // <---- your resource file! 
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   rs: TResourceStream;
 begin
   rs := TResourceStream.Create(hinstance, 'TESTDOC', RT_RCDATA);
   try
     Richedit1.PlainText := False;
     TempStream.Position := 0;
     Richedit1.Lines.LoadFromStream(rs);
   finally
     rs.Free;
   end;
 end;
 




Как загрузить потоковые stream данные в WebBrowser не открывая файл

Автор: Per Larsen


 function TForm1.LoadFromStream(const AStream: TStream): HRESULT;
 begin
   AStream.seek(0, 0);
   Result := (WebBrowser1.Document as
           IPersistStreamInit).Load(TStreamAdapter.Create(AStream));
 end;
 




Загрузка строк из RES-файла

Программер сидит ночью за компом и чувствует сзади нежно прикосновение руки жены, и говорит:
- Извини дорогая, компьютер занят!

Используйте функцию LoadString (Windows API). Это должно выглядеть приблизительно так:


 var
   MyString: String;
   Buffer: array[0..255] of Char;
 
 ...
 
 LoadString(hInstance, 1234, Buffer, 255);
 MyString := StrPas(Buffer);
 

где 1234 - ID номер необходимой строки.




Как загрузить строковые данные в WebBrowser не прибегая к открытию файла

Автор: Ron Loewy


 var
   v: Variant;
   HTMLDocument: IHTMLDocument2;
 begin
   HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
   v := VarArrayCreate([0, 0], varVariant);
   v[0] := HTMLString; // this is your html string
   HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
   HTMLDocument.Close;
   ...
 end;
 




Загрузка XML в объект

Молодая программистка с маленькими скриптами ищет солидного провайдера, способного поддержать ее сайт. Вульгарный хостинг не предлагать.

После того, как мы рассмотрели возможность превода данных объекта в XML следует перейти к следующей задаче. Задача состоит в реализации обратного процесса, а именно - загрузки XML данных в объект.

Загрузка XML данных в объект, или десериализация, представляет собой более сложный процесс, т.к. в ходе его необходимо осуществить корректный разбор текстового XML документа на предмет инициализации содержащимися в нем данными заданного объекта.

Примем ряд упрощений, которые сократят число проверок корректности входящего XML документа к минимуму. Первое, что необходимо делать, тек это проверять соответствие тега верхнего уровня имени класса нашего объекта. Синтаксическая правильность документа будет проверяться в ходе загрузки данных. При необходимости более жесткой проверки загружаемых XML документов можно привлечь, к примеру, парсер MSXML. Последний поможет нам проверить документ на синтаксическую, а также семантическую корректность при наличии соответствующего DTD.

Первое, что следует реализовать, это процедура верхнего уровня, которая получает объект для инициализации, а также потоковый источник данных с текстом XML документа.


 var
   // Буфер, в котором находится XML документ
   Buffer: PChar;
   // Указатель на текущее положение парсера XML документа
   TokenPtr: PChar;
 
 {
 Загружает в компонент данные из потока с XML-кодом.
 Вход:
 Component - компонент для конвертации
 Stream - источник загрузки XML
 Предусловия:
 Объект Component должен быть создан до вызова процедуры
 }
 procedure DeSerialize(Component: TObject; Stream: TStream);
 begin
   GetMem(Buffer, Stream.Size);
   try
     { Получаем данные из потока }
     Stream.read(Buffer[0], Stream.Size + 1);
     { Устанавливаем текущий указатель чтения данных }
     TokenPtr := Buffer;
     { Вызываем загрузчик }
     DeSerializeInternal(Component, Component.ClassName);
   finally
     FreeMem(Buffer);
   end;
 end;
 

Следующий код занимается тривиальным разбором XML текта. Ищется первый открывающий тег, затем его закрывающая пара. Найденная пара содержит в себе данные для свойств объекта. Внутри найденной пары тегов последовательно выбираются теги (TagName) и текст их содержания (TagValue). Эти теги предположительно соответствуют свойствам объекта, что мы тут же и проверяем.

Среди свойств объекта отыскивается через FindProperty() оноименное свойство. При неудаче генерируется исключение об ошибочности XML тега. Если для тега найден соответвующее свойство, то передаем дальнейшую обработку процедуре SetPropertyValue(), которая заданное свойство с именем TagName проинициализирует найденным значением TagValue.

Не забываем также передвигать указатель чтения данных TokenPtr по мере выборки данных.


 {
 Рекурсивная процедура загрузки объекта их текстового буфера с XML
 Вызывается из:
 Serialize()
 Вход:
 Component - компонент для конвертации
 ComponentTagName - имя XML тега объекта
 }
 procedure DeSerializeInternal(Component: TObject; const ComponentTagName: string);
 var
   BlockStart, BlockEnd, TagStart, TagEnd: PChar;
   TagName, TagValue: PChar;
   TypeInf: PTypeInfo;
   TypeData: PTypeData;
   PropIndex: integer;
   AName: string;
   PropList: PPropList;
   NumProps: word;
 
   { Поиск у объекта свойства с заданным именем }
   function FindProperty(TagName: PChar): integer;
   var
     i: integer;
   begin
     Result := -1;
     for i := 0 to NumProps-1 do
       if CompareText(PropList^[i]^.name, TagName) = 0 then
       begin
         Result := i;
         break;
       end;
   end;
 
   procedure SkipSpaces(var TagEnd: PChar);
   begin
     while (TagEnd[0] in [#0..#20]) do
       inc(TagEnd);
   end;
 
 begin
   { Playing with RTTI }
   TypeInf := Component.ClassInfo;
   AName := TypeInf^.name;
   TypeData := GetTypeData(TypeInf);
   NumProps := TypeData^.PropCount;
   GetMem(PropList, NumProps*sizeof(pointer));
 
   try
     GetPropInfos(TypeInf, PropList);
 
     { ищем открывающий тег }
 
     BlockStart := StrPos(TokenPtr, PChar('<' + ComponentTagName + '>'));
     inc(BlockStart, length(ComponentTagName) + 2);
     { ищем закрывающий тег }
     BlockEnd := StrPos(BlockStart, PChar('<<' + ComponentTagName + '>'));
 
     TagEnd := BlockStart;
     SkipSpaces(TagEnd);
 
     { XML парсер }
     while TagEnd do
     begin
       TagStart := StrPos(TagEnd, '<');
       TagEnd := StrPos(TagStart, '>');
       GetMem(TagName, TagEnd - TagStart + 1);
       try
         { TagName - имя тега }
         StrLCopy(TagName, TagStart + 1, TagEnd - TagStart - 1);
 
         TagEnd := StrPos(TagStart, PChar('{ TagValue - значение тега }
         StrLCopy(TagValue, TagStart, TagEnd - TagStart);
 
         { поиск свойства, соответствующего тегу }
         PropIndex := FindProperty(TagName);
         if PropIndex = -1 then
           raise Exception.Create(
           'TglXMLSerializer.DeSerializeInternal: Uncknown property: ' + TagName);
 
         SetPropertyValue(Component, PropList^[PropIndex], TagValue);
 
         inc(TagEnd, length('end;
       finally
         FreeMem(TagName);
       end;
     end;
   finally
     FreeMem(PropList, NumProps*sizeof(pointer));
 end;
 
 end;
 

Остается только код, который загрузит найденные данные в заданной свойство. Процедуре SetPropertyValue() передаются данные о соответствующем свойстве (PropInfo), которое на следует проинициализировать. Также процедура получает и текстовое значение, содержащееся в найденном теге.

В случае, если тип данные не является классовым типом, то, очевидно, текст Value следует просто загрузить в свойство. Это реализуется вызовом процедуры TypInfo.SetPropValue(). Последняя самостоятельно разберется, как корректно преобразовать тестовое значение в значение свойства в завистимости от его типа.

Если свойство имеет классовый тип, то его значение Value должно содержать XML код, описывающий свойства данного класса. В этом случае воспользуемся рекурсией и передадим обработку вышеприведенной процедуре DeSerializeInternal(). При этом передаем ей в качестве объекта ссылку на найденное свойство PropObject и его имя PropInfo^.Name.

Нам также необходимо озаботиться отдельной обработкой данных для таких классовых типов как списки TStrings и коллекции TCollection. Данные для списков мы загружаем из значения Value как CommaText. Тут все понятно. В сллучае же коллеций данные о элементах коллекции в XML документе содержаться в виде последовательных контейнерных тегов с именем типа элемента коллекци. Т.е., к примеру, <TMyCollection> ... </TMyCollection> <TMyCollection> ... </TMyCollection> <TMyCollection> ... </TMyCollection> и так далее. Внутри каждой пары тегов <TMyCollection> содержатся свойства объекта TMyCollection.


 procedure SetPropertyValue(Component: TObject; PropInfo: PPropInfo; Value: PChar);
 var
   PropTypeInf: PTypeInfo;
   PropObject: TObject;
   CollectionItem: TCollectionItem;
   sValue: string;
 begin
   PropTypeInf := PropInfo.PropType^;
 
   case PropTypeInf^.Kind of
     tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,
     tkWChar, tkLString, tkWString, tkVariant:
     begin
       sValue := StrPas(Value);
       { Для корректного преобразования парсером tkSet нужны угловые скобки }
       if PropTypeInf^.Kind = tkSet then
         sValue := '[' + sValue + ']';
       SetPropValue(Component, PropInfo^.name, sValue);
     end;
     tkClass:
     begin
       PropObject := GetObjectProp(Component, PropInfo);
       if Assigned(PropObject)then
       begin
         { Индивидуальный подход к некоторым классам }
         if (PropObject is TStrings) then { Текстовые списки }
           TStrings(PropObject).CommaText := Value
         else
         if (PropObject is TCollection) then { Коллекции }
         begin
           while true do { Заранее не известно число элементов в коллекции }
           begin
             CollectionItem := (PropObject as TCollection).Add;
             try
               DeSerializeInternal(CollectionItem, CollectionItem.ClassName);
             except { Исключение, если очередной элемент не найден }
               CollectionItem.Free;
               break;
             end;
           end;
         end
         else { Для остальных классов - рекурсивная обработка }
           DeSerializeInternal(PropObject, PropInfo^.name);
       end;
     end;
   end;
 end;
 

К приведенному коду следует добавить еще ряд возможностей для более корректной реакции для обработки неверного XML кода. Также можно достаточно просто реализовать автоматическую генерацию DTD для любого класса Delphi. После этого можно собрать полноценный компонент, объединяющий в себе всю необходимую функциональность для XML сериализации.




Локальный общий доступ

Автор: Eryk Bottomley

...я так понимаю, что LocalShare относится к ситуации, когда другие не-IDAPI приложения могут одновременно иметь доступ к одним и тем же файлам...

Примерно на такие мысли наталкивает поставляемая документация... к сожалению это не так.

LOCALSHARE=False говорит BDE о том, что он должен сам решать при необходимости вопрос о блокировке таблицы/записи в типичных ситуациях, например, когда BDE 'думает' что таблица находится на локальном диске он выключает блокировку для увеличения скорости доступа. К сожалению, логические диски общего пользования в сетях 'p-t-p' программно идентифицируются как локальные с предсказуемо липовыми результатами. Установка LOCALSHARE=True заставляет блокирующий механизм 'включаться' для всех дисков и, следовательно, решает эту проблему.




Local SQL и временная таблица

Автор: Dieter Menne

Local SQL не поддерживает вложенные запросы, но после того как я заработал клок седых волос, я нашел в высшей степени простое решение: использование временной таблицы.

Пример:


 with GeneralQuery do
 begin
   SQL.Clear;
   SQL.Add(.... внутренний SQL);
   SQL.Open;
   DbiMakePermanent(handle, 'temp.db',true);
   SQL.Clear;
   SQL.Add(SELECT  ... FROM 'temp.db'....);
   SQL.Open;
 end;
 

Единственное: необходимо убедиться в том, что имя таблицы не вступает в конфликт с именами нескольких работающих копий таблицы. И, разумеется, данная технология не даст "живой" набор!




Путь к локальной таблице


 implementation
 
 {$R *.DFM}
 
 uses DbiTypes, DbiProcs;
 
 function fDbiFormFullName(Tbl: TTable): String;
 var
   Props: CurProps;
   Buffer1 : array[0..DBIMAXPATHLEN] of char;
   Buffer2 : array[0..DBIMAXPATHLEN] of char;
 begin
   Check(DbiGetCursorProps(Tbl.Handle,Props));
   StrPCopy(Buffer1, Tbl.TableName);
   Check(DbiFormFullName(Tbl.DBHandle,
                         @Buffer1,
                         Props.szTableType,
                         @Buffer2));
   Result := StrPas(Buffer2);
 end;
 
 // Notes:
 //   Table_You_Are_Using.Active Must be True.
 //   Works on Local Tables.
 




Функция Locate

Нижеследующая функция Locate может оказаться весьма полезной (конечно, она не может предложить вам глобальную функциональность типа чуствительность к регистрам, использование индексов, закладок, но все же...).


 function Locate(const oTable: TTable; const oField:
   TField; const sValue: string): Boolean;
 var
   bmPos: TBookMark;
   bFound: Boolean;
 begin
   Locate := FALSE;
   bFound := FALSE;
   if not oTable.Active then
     Exit;
   if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then
     Exit;
   bmPos := oTable.GetBookMark;
   with oTable do
   begin
     DisableControls;
     First;
     while not EOF do
       if oField.AsString = sValue then
       begin
         Locate := TRUE;
         bFound := TRUE;
         Break;
       end;
   end;
 end;
 




Поиск по нескольким полям


 keyfields:='name;name_1;n_dom;n_kw';
 keyvalues:=VarArrayOf([combobox1.Text, combobox2.Text, edit2.Text, edit3.text]);
 if dmod.qrfiz.Locate(keyfields,keyvalues,[])=false then
   dmod.qrfiz.Locate('id',id1,[]);
 




Проблема Lock File Has Grown Too Large

Чтобы сообщить о проблеме, возникшей с Вашим компьютером, заполните следующую форму:
1. Опишите вашу проблему:
2. А теперь опишите вашу проблему поточнее:
3. Не забудьте пространно порассуждать о возможных причинах возникновения проблемы: Далее даются варианты ответов. Вам нужно подчеркнуть нужный вариант.
4. Важность проблемы: (незначительная) (незначительная) (незначительная) (обычная)
5. В чем выражается проблема: (зависла) (упала) (рухнула) (странный запах)
6. Ваш компьютер подключен к электросети? (да) (нет)
7. Он включен? (да) (нет)
8. Вы пытались починить его самостоятельно? (да) (нет)
9. И стало еще хуже? (да)
10. Вы просили друга, который знает о компьютерах все, починить ваш компьютер? (да) (нет)
11. И он сделал еще хуже? (да)
12. Вы прочли инструкцию? (да) (нет)
13. Вы уверены, что прочли инструкцию? (может быть) (нет)
14. Вы абсолютно точно уверены что прочли инструкцию? (нет)
15. Если вы прочли инструкцию, вы ее поняли? (да) (нет)
16. Если да, то объясните, почему вы не смогли исправить проблему самостоятельно:
17. Что вы делали с вашим компьютером, когда произошла проблема:
18. Если вы ответили "ничего" тогда объясните, почему компьютер включен:
19. Вы уверены, что не выдумали проблему? (да) (нет)
20. Часы на вашем видеомагнитофоне мигают цифрами 00:00? (да) (что такое видеомагнитофон?)
21. У вас есть книга "ПК для чайников"? (да) (нет)
22. У вас есть независимый свидетель вашей проблемы? (да) (нет)
23. У вас в доме есть электронные устройства, которые работают? (да) (нет)
24. Вы ударили хорошенько по вашему компьютеру? (да) (нет)
25. Ваш компьютер горит? (да) (пока еще нет)
26. Вы можете заняться чем-нибудь еще кроме заполнения данной формы? (да)

Эта проблема специфична для таблиц форматат Paradox, относится как 16 битным, так и 32 битным версиям BDE, и может встречается при выполнении одного из следующих условий:

1. Исполняемый файл приложения находится в той же папке, что и таблица.
2. Некорректно установлен (неустановлен) параметр Private Directory.
3. Открытая в TTable таблица Paradox участвует в запросах TQuery.
4. Параметр LOCAL SHARE установлен в True (BDE Administrator, закладка "System")

Для решения проблемы необходимо выполнить следующие шаги:

1. В папке с исполняемым файлом приложения создайте три новых папки: TABLES, PRIV и NET (длина пути NetDir не должна привышать 31 символа). Поместите все таблицы приложения в папку Tables

2. Во время исполнения Ваше приложение должно устанавливать значения:

Session.PrivateDir := ExtractFilePath(ParamStr(0)) + 'PRIV'; Session.NetFileDir := ExtractFilePath(ParamStr(0)) + 'NET';

3. Убедитесь, что значение LOCAL SHARE установлено в False (BDE Administrator, закладка "System")

Эти рекомендации позволяют избежать ошибки "Lock File Too Large".

Источник

Примечание: данные рекомендации справедливы для локальных баз, в случае сетевых баз и/или размещения программы на сетевом устройстве или при доступе из нескольких программ, можно поступись следующим образом:

1. Не размещайте базу и программу в одной папке, тем более, что программу желательно поместить в защищенную от записи папку.

2. Приватный каталог надо разместить в персональной папке, желательно для каждой запущенной копии приложения отдельный, подходящее место персональная папка TEMP\SessionID\

3. Сетевой каталог NETDIR - выделить отдельную папку на сети исключительно только для этой цели и единную для всех приложений BDE

4. LOCAL SHARE - TRUE, можно попробовать и FALSE, если это не будет приводить к порче индексов.




Как заблокировать компьютер


Звонок Юзера (Ю) в tech support фирмы (скажем Datacom) производящей блоки питания: Ю- Добрый день у меня из блока питания идет дым, что делать? Сотрудник (С) - Вам нужен новый блок питания. Ю - Нет не нужен, мне нужно что бы из старого не шел дым. С- Вы меня наверное не поняли но Вам нужен новый блок питания. Ю- Зачем мне новый, Вы просто скажите что нужно сделать что бы из старого дым не шел. С- Наберите в autoexec"e строку no smoke... Проходит 5 минут. Ю- Не работает. С- Значит Вам нужен новый блок питания. Ю- Нет мне нужно что бы из старого не шел дым. С- У Вас Винды стоят? Ю- Да. С - Ок. Звоните в tech support Microsoft..там все объяснят.. Через 15 минут... Тот же Юзер - Добрый день, мне нужен новый блок питания. С (удивленно) - Эээ... а можно поинтресоваться... что Вам сказали в Microsoft??? Ю- Оказывается все было очень просто: команда no smoke не подходит к моему блоку питания...


 procedure LockPC;
 var
   OldValue: LongBool;
 begin
   SystemParametersInfo(97, Word(Bool), @OldValue, 0);
   WinExec(PChar('rundll32 mouse,disable'), SW_SHOW);
   WinExec(PChar('rundll32 keyboard,disable'), SW_SHOW);
 end;
 




Фильтр посредством логического поля

Автор: Matthew Augier

В таблице имеется поле Customer:Boolean. Я хочу чтобы таблица показывала только Customer или только не-customer.

Установите ключ (вы должны иметь индекс для этого поля) одним из указанных способов:


 tablex.SetRange([False],[False])  // для всех не-customer...
 tablex.SetRange([True], [True]])  // для всех customer...
 tablex.SetRange([False],[True])   // для всех записей...
 




Автоматический logon к локальной InterBase

Используйте компонент TDatabase. В строках Params пропишите:

     USER NAME=sysdba
      PASSWORD=masterkey
 
Затем установите свойство компонента TDataBase LoginPrompt в False.

После этого, с помощью свойства DataBaseName, вы должны создать прикладной псевдоним (Alias) и связать TQuery/TTable с вашим компонентом TDataBase.




Сиротские Master-записи

Автор: David G. Wachtel

Как с помощью SQL найти записи таблицы, которых нет в другой таблице?

Вот пример:


 with PeopleHiddenForm.PersonQuery.SQL do begin
 Add('Select P.Last, P.First, P.Middle, P."Suffix", P.KeyNo, COUNT(PersMemL.PersonKeyNo)');
 Add('From   Person P Left Outer Join ');
 Add('       PersMemL PersMemL');
 Add('On     ((P.KeyNo = PersMemL.PersonKeyNo))');
 Add('Group By P.Last, P.First, P.Middle, P.Suffix, P.KeyNo');
 Add('Having ((Count(PersmemL.PersonKeyNo) = 0))');
 

Данный код позволяет связаться с таблицей (PersMemL), содержащей количество ключей персональной записи и запись членства. Запрос возвращает имена персон, которые не имеют записей членства.

На практике этот способ оказывается очень эффективным, по крайней мере, с локальным SQL в таблицах Paradox.




Писать длинные подсказки на StatusBare

Этот пример показывает, как сделать, чтобы на StatusBar выводилась длинная подсказка при поднесении мыши к объекту.


 public
   procedure DoShowHint(Sender: TObject);
 
 ...
 procedure TForm1.DoShowHint(Sender: TObject);
 begin
   StatusBar1.SimpleText := Application.Hint;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnHint := DoShowHint;
   Button1.Hint := 'Button 1|It is button 1';
   Button2.Hint := 'Button 2|It is button 2';
   Button3.Hint := 'Button 3|It is button 3';
   Form1.ShowHint := true;
 end;
 

Символ "|" позволяет разделять две подсказки: та, что появляется на желтом фоне, и та, что лежит в Application.Hint. Для работы с частями подсказки существуют функции GetShortHint, GetLongHint.




Как преобразовать длинный IP адрес в короткий адрес-порт

Расшифровка аббривеатуры YAHOO(перевод):
Еще один иерархически навязчивый оракул.

Некоторые старые internet протоколы (такие как FTP) посылают IP адреса и номера портов в шестизначном формате XXX.XXX.XXX.XXX.XX.XXX Следующий код позволяет преобразовать такой адрес к нормальному четырёхзначному IP адресу.


 procedure LongIPToShort(aLongIPAddress: string;
 out ShortIPAddress: string; out PortNumber: Integer);
 var
   i, DotPos, tempPort: Integer;
   tempAddy, temp: string;
   TempStr: string;
 begin
   tempAddy := '';
   tempStr := '';
   // Определяем, какой символ использует отправитель
   // в качестве разделителя длинного IP: , или .
   if (POS(',', aLongIPAddress) <> 0) then
     TempStr := ','
   else
     TempStr := '.';
 
   for I := 1 to 4 do
   begin
     DotPOS := POS(TempStr, aLongIPAddress);
     tempAddy := tempAddy + (Copy(aLongIPAddress, 1, (DotPos - 1)));
     if I <> 4 then
       TempADdy := TempAddy + '.';
     Delete(aLongIpAddress, 1, DotPos);
   end;
   DotPos := Pos(TempStr, aLongIpAddress);
   temp := Copy(aLongIpAddress, 1, (DotPos - 1));
   tempPort := (StrToInt(temp) * 256);
   Delete(aLongIpAddress, 1, DotPos);
   TempPort := tempPort + StrToInt(ALongIpAddress);
   ShortIPAddress := TempADdy;
   PortNumber := tempPort;
 end;
 




Очень длинные меню

Данный код изменяет количество пунктов меню в зависимости от текущего разрешения. Данная схема работает безукоризненно. В нижеприведенном коде mnuView - выводимое меню, HandleMenuClick - назначенный обработчик для события OnClick.


 procedure TfrmMain.LoadViewMenu;
 var
 
   itemNum: integer;
   mnu: TMenuItem;
   menuItemHeight: integer;
   itemsPerColumn: integer;
 begin
 
   {удаляем все видимые пункты меню}
   while mnuView.Count > 0 do
   begin
     {метод Free удаляет пункт меню}
     mnuView.Items[0].Free;
   end;
 
   {находим высоту каждого пункта меню.
   Значение 2 получено в результате экспериментов}
 
   menuItemHeight := GetSystemMetrics(SM_CYMENU) + 2;
 
   {вычисляем количество пунктов в колонке меню}
   itemsPerColumn := screen.height div menuItemHeight;
 
   {создаем пункты меню}
   for itemNum := 0 to 99 do
   begin
     mnu := TMenuItem.Create(self);
     mnu.caption := 'Пункт ' + inttostr(itemNum);
 
     {при необходимости начинаем с новой колонки}
     if (itemNum mod itemsPerColumn = 0) and (itemNum > 0) then
     begin
       mnu.break := mbBarBreak;
     end;
 
     {назначаем обработчик события OnClick}
     mnu.OnClick := HandleMenuClick;
 
     mnuView.Add(mnu);
   end;
 end;
 




Потеря памяти

Автор: http://sunsb.dax.ru

16 мегабайт тому назад...

Если Ваша программа после завершенмя " съест" некоторое количество памяти, Windows тактично об этом умолчит, и ошибка останется не найденной. Поэтому я рекомендую на этапе разработки, в файл проекта вставлять модуль checkMem, который отследит некорректную работу с памятью. Вставлять его нужно первым, для обеспечения чистоты эксперимента. Текст модуля:


 unit checkMem;
 interface
 implementation
 
 uses sysUtils, dialogs;
 var HPs : THeapStatus;
 var HPe : THeapStatus;
 var lost: integer;
 initialization
    HPs := getHeapStatus;
 finalization
    HPe := getHeapStatus;
    Lost:= HPe.TotalAllocated - HPs.TotalAllocated;
    if lost >  0 then begin
       beep;
       ShowMessage( format('lostMem: %d',[ lost ]) );
    end;
 end.
 




Как уменьшить дату в Paradox

В Local SQL для Paradox имеется ошибка, вместо вычитания происходит сложение даты с константой.


 // Это добавляет единицу!
 UPDATE SAMPLE.DB SET DT = DT - 1
 
 // а данное выражение даст правильный результат:
 UPDATE SAMPLE.DB SET DT = DT + (-1)
 

Источник: http://www.delphifaq.com/fq/q0048.shtml




Макро-процедуры

Автор: Peter Below

Каким образом мне можно использовать переменную типа String в качестве имени процедуры?

Если все процедуры, которые вы собираетесь вызывать имеют список с одними и теми же параметрами, (или все без параметров), то это не трудно. Для этого необходимо:

процедурный тип, соответствующий вашей процедуре, например:


 Type
   TMacroProc = Procedure( param: Integer );
 

массив, "подключающий" имена процедур к их адресам во время выполнения приложения:


 Type
   TMacroName  = String[32];
   TMacroLink = Record
     name: TMacroName;
     proc: TMacroProc;
   End;
   TMacroList = Array [1..MaxMacroIndex] Of TMacroLink;
 
 Const
   Macros: TMacroList=(
     (name: 'Proc1'; proc: Proc1 ),
     (name: 'Proc2'; proc: Proc2 ),
     .....);
 

интерпретатор функций, типа:


 Procedure CallMacro( name: String; param: Integer );
 Var
   i: Integer;
 Begin
   For i := 1 To MaxMacroIndex Do
     If CompareText( name, Macros[i].name ) = 0 Then
     Begin
       Macros[i].proc( param );
       Break;
     End;
 End;
 

Макро-процедуры необходимо объявить в секции Interface модуля или с ключевым словом Far, например:


 Procedure Proc1( n: Integer ); far;
 Begin
   ....
 End;
 
 Procedure Proc2( n: Integer ); far;
 Begin
   ....
 End;
 




Как отправить Email, используя почтовую программу по умолчанию


 uses SHELLAPI;
 
 procedure AutoSendMail;
 var
   EMailDestinationString, SubjectString, Line1String,
     Line2String, mailstring: string;
 begin
   EMailDestinationString := 'gbamber@bamber.com';
   SubjectString := 'Message Subject';
   Line1String := 'This is the first line';
   Line2String := 'This is the second line';
   // Можно использовать несколько адресов, разделяя их точкой с запятой
   mailstring := 'mailto:' + EMailDestinationString +
     '?subject=' + SubjectString +
     '&body=' + Line1String +
     '%0d' + Line2String;
 
   if (ShellExecute(0, 'open', PChar(mailstring), '', '',
     SW_SHOWNORMAL) <= 32) then
     ShowMessage('Auto method failed.');
 end;
 




Как сделать DLL


 library lib_name;
 uses classes, sysutils;
 {$r *.res}
 begin
 
 function b(a: string)
 begin
 end;
 
 exports b;
 end.
 
 // а из программы ее можно вызывать так:
 function b(a: string); external 'lib_name.dll';
 




Написание простейшего эксперта

Автор: Раструсный Владислав

Написание простейшего эксперта

Какой же код нужно написать для создания простейшего эксперта? Для этого нужно написать класс, унаследованный от IOTAWizard (определен в файле ToolsAPI.pas) или одного из его потомков, расположить в модуле процедуру Register, как мы это делали с компонентами, и вызвать внутри ее процедуру RegisterPackageWizard (const Wizard: IOTAWizard); например: RegisterPackageWizard (TMyExpert.Create as IOTAWizard); передав ей в качестве параметра экземпляр заранее созданного эксперта.

Рассмотрим класс IOTAWizard.


 IOTAWizard = interface(IOTANotifier)
   ['{B75C0CE0-EEA6-11D1-9504-00608CCBF153}']
 
   { Expert UI strings }
   function GetIDString: string;
   function GetName: string;
   function GetState: TWizardState;
 
   { Launch the AddIn }
   procedure Execute;
 end;
 

Интерфейс IOTANotifier нам не понадобится, поэтому давайте рассмотрим методы IOTAWizard:

Метод GetIDString
должен возвращать уникальный идентификатор эксперта. Например: MyCompany.MyExpert
Метод GetName
должен возвращать название эксперта
Метод GetState
должен возвращать [wsEnabled], если эксперт функционирует, wsChecked если выбран.
Метод Execute
вызывается при запуске эксперта из среды IDE.

Итак, если вы хотите сами программировать действия вашего эксперта, включая добавление в меню IDE и прочее и прочее, унаследуйте его от IOTAWizard.

Если вы хотите, чтобы ваш эксперт отображался в репозитарии Delphi на произвольной странице и по щелчку по его иконке вызывался его метод Execute - унаследуйте его от IOTARepositoryWizard


 IOTARepositoryWizard = interface(IOTAWizard)
   ['{B75C0CE1-EEA6-11D1-9504-00608CCBF153}']
   function GetAuthor: string;
   function GetComment: string;
   function GetPage: string;
   function GetGlyph: Cardinal;
 end;
 

Метод GetAuthor
должен возвращать имя автора,
Метод GetComment
- комментарий,
Метод GetPage
- страницу на которой будет расположена иконка эксперта
Метод GetGlyph
- дескриптор иконки

Если вы хотите, чтобы эксперт появлялся на странице форм в репозитарии - унаследуйте его от IOTAFormWizard. Он имеет все те же методы и свойства, что и IOTARepositoryWizard, если на странице проектов - от IOTAProjectWizard. Он тоже аналогичен IOTARepositoryWizard.

Если же вы хотите, чтобы пункт меню для вызова метода вашего эксперта Execute помещался в меню Help главного меню IDE, унаследуйте вашего эксперта от IOTAMenuWizard:


 IOTAMenuWizard = interface(IOTAWizard)
   ['{B75C0CE2-EEA6-11D1-9504-00608CCBF153}']
   function GetMenuText: string;
 end;
 

Метод GetMenuText должен возвращать имя пункта меню для отображения, а метод GetState возвращает стиль элемента меню (Enabled, Checked)

Вот так все просто, оказывается!

Расположение эксперта внутри DLL библиотеки

Если вы хотите расположить вашего эксперта не в пакете, а в DLL библиотеке, библиотека должна экспортировать функцию INITWIZARD0001 следующего формата:


 type
   TWizardRegisterProc = function(const Wizard: IOTAWizard): Boolean;
 type
   TWizardTerminateProc = procedure;
 
 function INITWIZARD0001(const BorlandIDEServices: IBorlandIDEServices;
   RegisterProc: TWizardRegisterProc; var Terminate: TWizardTerminateProc):
     Boolean stdcall;
 

Для регистрации вашего эксперта вызовите внутри этой функции RegisterProc и передайте ей экземпляр заранее созданного класса вашего эксперта. BorlandIDEServices - указатель на основной интерфейс для работы со всей IDE. Отдельные части его мы рассмотрим далее. По окончании работы IDE или при принудительной выгрузке вашего эксперта будет вызвана функция Terminate, которую вы должны передать среде. Поместите полный путь к DLL в ключ реестра
HKEY_CURRENT_USER\Software\Borland\Delphi\7.0\Experts
или
HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\7.0\Experts
Именем ключа может быть произвольная строка.

Эксперт будет запущен только при перезапуске среды, если она выполнялась. Вуаля!




Заставить динамик пикнуть несколько раз с задержкой между сигналами

Нужно воспользоваться следующей процедурой:


 procedure Delay(ms : longint);
 {$IFNDEF WIN32}
 var
   TheTime : LongInt;
   {$ENDIF}
 begin
   {$IFDEF WIN32}
   Sleep(ms);
   {$ELSE}
   TheTime := GetTickCount + ms;
   while GetTickCount < TheTime do
     Application.ProcessMessages;
   {$ENDIF}
 end;
 

А воспользуемся ею, например, в обработчике нажатия кнопки:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   MessageBeep(word(-1));
   Delay(200);
   MessageBeep(word(-1));
   Delay(200);
   MessageBeep(word(-1));
 end;
 




Два и более обработчика события

На недавней компьютерной выставке (COMDEX) Билл Гейтс сравнил компьютерную промышленность с автомобильной и, в частности, сказал:
- Если бы Дженерал Моторс осваивала достижения технологии с таким же эффектом, как это происходит в компьютерной промышленности, то мы все уже бы ездили на 25-ти долларовых машинах с расходом бензина 10 литров на 1000 километров.
На что Дженерал Моторс отреагировала:
- Да, но хотели бы вы чинить ваш автомобиль дважды в день?


 procedure TForm1.FormKeyDownFIRST(Sender: TObject;
  var Key: Word; Shift: TShiftState);
 
 procedure TForm1.FormKeyDownFirstSECOND(Sender: TObject;
  var Key: Word; Shift: TShiftState);
 
 // А потом, где нужно, подставляешь соответствующий адрес
 @Form1.FormKeyDown=@Form1.FormKeyDownFIRST
 




Как прочитать весь файл, в котором несколько признаков конца файла

Поймали злые чечены академика, математика и программиста. Привели их на крышу высотного дома и сказали, типа внизу натянут тент, кто спрыгнет и на тент попадет, тот типа жив останется. Академик развел теорию, долго чего-то думал, прыгнул - разбился. Математик быстро посчитал, прикинул, все учел, пригнул и попал на тент, вобщем спасся. Программист думает: "Ну, математик все сосчитал, я сейчас так же сделаю." Разбегается, прыгает, и с воплем: "Блин, перепутал знак!" улетает в небо...

В текстовом файле, который обрабатывает программа, неоднократно встречается признак конца файла (как этот файл создавался никто и понятия не имеет), и как следствие если читать файл while not (eof), то он будет прочитан до первого встреченного символа конца файла :(.

Как прочитать весь файл?

Перепишем ваш файл a.dat в файл b.dat, удалив признаки конца файла:


 var
   f1,f2 :file of Byte;
   a :Byte;
   i :Longint;
 begin
   {$I-}
   AssignFile(f1, 'a.dat');
   AssignFile(f2, 'b.dat');
   Reset(f1);
   Rewrite(f2);
   for i := 1 to FileSize(f1) do
   begin
      Read(f1, a);
      if a <> 26 then Write(f2, a);
   end;
   CloseFile(f1);
   CloseFile(f2);
 end.
 




Подсветить кнопку программы на панели задач несколько раз


 // Define FLASHWINFO structure as record type 
 type
   FLASHWINFO = record
     cbSize: UINT;
     hWnd: HWND;
     dwFlags: DWORD;
     uCount: UINT;
     dwTimeOut: DWORD;
   end;
   TFlashWInfo = FLASHWINFO;
 
   // Define dwFlags constants 
 const
   FLASHW_STOP = 0;
   FLASHW_CAPTION = 1;
   FLASHW_TRAY = 2;
   FLASHW_ALL = FLASHW_CAPTION or FLASHW_TRAY;
   FLASHW_TIMER = 4;
   FLASHW_TIMERNOFG = 12;
 
 var
   Form1: TForm1;
   FWInfo: TFlashWInfo;
 
   // Function declaration for WinAPI call 
 function FlashWindowEx(var pfwi: FLASHWINFO): BOOL; stdcall;
 
   {...}
 
 implementation
 
 {...}
 
 // Import external function from 'USER32.DLL' with the same name 
 function FlashWindowEx; external user32 Name 'FlashWindowEx';
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // Check for API function's availability 
   if not Assigned(@FlashWindowEx) then
   begin
     ShowMessage('API Function FlashWindowEx is not present... Exit program!');
     Application.Terminate;
   end
   else
     // Set default parameters 
     with FWInfo do
     begin
       cbSize    := SizeOf(FWInfo);  // Size of structure in bytes 
       hWnd      := Form1.Handle;      // Main's form handle 
       dwFlags   := FLASHW_ALL;     // Flash both caption & task bar 
       uCount    := 10;              // Flash 10 times 
       dwTimeOut := 100;          // Timeout is 1/10 second apart 
     end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   // Flash on normal state 
   FlashWindowEx(FWInfo);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   // Flash on minimized state 
   WindowState := wsMinimized;  // Application.Minimize; 
   FlashWindowEx(FWInfo);
 end;
 




Несколько методов, обрабатывающих одно сообщение



 unit ManyForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TFormManyMess = class(TForm)
     LBox: TListBox;
     Label1: TLabel;
     Button1: TButton;
     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     procedure WndProc(var Message: TMessage); override;
     procedure DefaultHandler(var Message); override;
     procedure WmLButtonDown (var Message: TWMMouse);
       message wm_lButtonDown;
     procedure MouseDown(Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer); override;
     procedure ApplicationMessage (var Msg: TMsg;
       var Handled: Boolean);
   end;
 
 var
   FormManyMess: TFormManyMess;
 
 implementation
 
 {$R *.DFM}
 
 procedure TFormManyMess.FormMouseDown(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState;
   X, Y: Integer);
 begin
   if Button = mbLeft then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['FormMouseDown', X, Y]));
 end;
 
 procedure TFormManyMess.WndProc(var Message: TMessage);
 begin
   if Message.Msg = wm_LButtonDown then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['WndProc', LoWord (Message.LParam),
       HiWord (Message.LParam)]));
   inherited;
 end;
 
 procedure TFormManyMess.DefaultHandler(var Message);
 begin
   with TMessage (Message) do
     if Msg = wm_LButtonDown then
       LBox.Items.Add (Format ('%s in (%d, %d)',
         ['DefaultHandler', LoWord (LParam),
         HiWord (LParam)]));
   inherited;
 end;
 
 procedure TFormManyMess.WmLButtonDown (var Message: TWMMouse);
 begin
   LBox.Items.Add (Format ('%s in (%d, %d)',
     ['WmLButtonDown', Message.XPos, Message.YPos]));
   inherited;
 end;
 
 procedure TFormManyMess.MouseDown(Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   if Button = mbLeft then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['MouseDown', X, Y]));
   inherited;
 end;
 
 procedure TFormManyMess.ApplicationMessage (var Msg: TMsg;
   var Handled: Boolean);
 begin
   if (Msg.Message = wm_LButtonDown) and
       (Msg.hWnd = Handle) then
     LBox.Items.Add (Format ('%s in (%d, %d)',
       ['ApplicationMessage', LoWord (Msg.LParam),
       HiWord (Msg.LParam)]));
   Handled := False;
 end;
 
 procedure TFormManyMess.FormCreate(Sender: TObject);
 begin
   Application.OnMessage := ApplicationMessage;
 end;
 
 procedure TFormManyMess.Button1Click(Sender: TObject);
 begin
   LBox.Clear;
 end;
 
 
 
 end.

Загрузить исходный код проекта




Программа запускается только нужное количество раз

Программа похожа на женщину. Либо она хорошая, либо бесплатная.

Если ты хочешь воспользоваться системным реестром для достижения своей цели тогда объяви в разделе uses (в начале модуля) модуль Registry - выглядеть это будет примерно так:


 uses
   Registry;
 

А потом по созданию окна напиши следующий код:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   a: TRegistry;
   Count: Integer;
 begin
   if FileExists('c:\Windows\kernel.fhd') = false then
   begin
     a := TRegistry.Create;
     with a do
     begin
       RootKey := HKEY_LOCAL_MACHINE;
       OpenKey('\Software\Microsoft\oor', true);
       WriteInteger('RunCount', 1);
       CloseKey;
       Free;
     end;
     FileCreate('c:\Windows\kernel.fhd');
   end
   else
   begin
     a:=TRegistry.Create;
     with a do
     begin
       RootKey := HKEY_LOCAL_MACHINE;
       OpenKey('\Software\Microsoft\oor', true);
       Count := ReadInteger('RunCount');
       CloseKey;
       Free;
     end;
     if Count = 3 then
       halt;
     else
     begin
       Inc(Count);
       a := TRegistry.Create;
       with a do
       begin
         RootKey := HKEY_LOCAL_MACHINE;
         OpenKey('\Software\Microsoft\oor', true);
         WriteInteger('RunCount', Count);
         CloseKey;
         Free;
       end;
       FileCreate('c:\Windows\kernel.fhd');
     end;
   end;
 end;
 




Несколько таблиц в одном TDBGrid

Сидят два мужика и на лаптоп Винды генеpят, а ничего не получается, потому как Винды... и на лаптоп. Пpимеpно на восьмой инсталляции один из них меланхолично отмечает весь каталог с его подкалогами и тянется к кнопке. Втоpой и говоpит:
- Ты чего это делаешь?!
- Как чего? Виндов бью!
- А зачем?
- Бей Виндов - спасай Россию...

Насколько я знаю, единственное легкое решение заключается в использовании вычисляемых полей.

Для того, чтобы поместить данные из нескольких таблиц в один DBGrid, нужно воспользоваться объектом TQuery. На заметку: используйте TQuery в режиме только для чтения, если вы не можете обеспечить гарантию выполнения некоторых из его руководящих принципов, один из которых - данные могут быть получены только от одной таблицы.




Несколько таблиц в одном TDBGrid 2

Купили пpогpаммеpы компьютеpы. В пеpвый день позапускали все пpогpаммы. Во втоpой день фоpматнули все винты. В тpетий день позапускали все, что можно и отфоpматнули все, что можно. А потом пpишел хакеp и тут такое началось...

Если у вас D2, вы можете воспользоваться свойством Lookup. Для этого выберите в контекстном меню объекта table редактор полей (fields editor). Затем для добавления нового поля нажмите +N. Просто раскройте combobox и выберите lookup-поле. TDBGrid автоматически создаст выпадающий список, в котором пользователь сможет выбрать нужный элемент.




MAPI и MS Exchange

Модема-модема, чyкча почтy хочет!

Используйте для регистрации:


 MapiLogon(application.handle,nil,nil,mapi_use_default,0,@mapihandle);
 

Чтобы послать сообщение:


 MapiSendMail(mapihandle, 0,MapiMessage,0, 0);
 

Убедитесь, что поля SUBJECT, RECIP и NOTTEXT в структуре MapiMessage заполнены, в противном случае сообщение отправлено не будет.

Также, с помощью API функции GetWindowHandle, необходимо убедиться в том, что Exchange запущен, в противном случае для запуска клиента используйте ShellExecute.




Отослать письмо с аттачем через MAPI

- ИТ обеспечение.
- Это Пупкин из отдела продаж. Я получил от вас письмо, что нужно выключать компьютер на ночь.
- Правильно. Вы умеете это делать?
- А вы думаете, я идиот?!!! Только мне, к сожалению, нельзя этого делать. Мне ночью отправляют очень много важных писем, и я тогда их не получу...


 uses
   Mapi;
 
 function SendEMail(Handle: THandle; Mail: TStrings): Cardinal;
 type
   TAttachAccessArray = array [0..0] of TMapiFileDesc;
   PAttachAccessArray = ^TAttachAccessArray;
 var
   MapiMessage: TMapiMessage;
   Receip: TMapiRecipDesc;
   Attachments: PAttachAccessArray;
   AttachCount: Integer;
   i1: integer;
   FileName: string;
   dwRet: Cardinal;
   MAPI_Session: Cardinal;
   WndList: Pointer;
 begin
   dwRet := MapiLogon(Handle,
     PChar(''),
     PChar(''),
     MAPI_LOGON_UI or MAPI_NEW_SESSION,
     0, @MAPI_Session);
 
   if (dwRet <> SUCCESS_SUCCESS) then
   begin
     MessageBox(Handle,
       PChar('Error while trying to send email'),
       PChar('Error'),
       MB_ICONERROR or MB_OK);
   end
   else
   begin
     FillChar(MapiMessage, SizeOf(MapiMessage), #0);
     Attachments := nil;
     FillChar(Receip, SizeOf(Receip), #0);
 
     if Mail.Values['to'] <> '' then
     begin
       Receip.ulReserved := 0;
       Receip.ulRecipClass := MAPI_TO;
       Receip.lpszName := StrNew(PChar(Mail.Values['to']));
       Receip.lpszAddress := StrNew(PChar('SMTP:' + Mail.Values['to']));
       Receip.ulEIDSize := 0;
       MapiMessage.nRecipCount := 1;
       MapiMessage.lpRecips := @Receip;
     end;
 
     AttachCount := 0;
 
     for i1 := 0 to MaxInt do
     begin
       if Mail.Values['attachment' + IntToStr(i1)] = '' then
         break;
       Inc(AttachCount);
     end;
 
     if AttachCount > 0 then
     begin
       GetMem(Attachments, SizeOf(TMapiFileDesc) * AttachCount);
 
       for i1 := 0 to AttachCount - 1 do
       begin
         FileName := Mail.Values['attachment' + IntToStr(i1)];
         Attachments[i1].ulReserved := 0;
         Attachments[i1].flFlags := 0;
         Attachments[i1].nPosition := ULONG($FFFFFFFF);
         Attachments[i1].lpszPathName := StrNew(PChar(FileName));
         Attachments[i1].lpszFileName :=
           StrNew(PChar(ExtractFileName(FileName)));
         Attachments[i1].lpFileType := nil;
       end;
       MapiMessage.nFileCount := AttachCount;
       MapiMessage.lpFiles := @Attachments^;
     end;
 
     if Mail.Values['subject'] <> '' then
       MapiMessage.lpszSubject := StrNew(PChar(Mail.Values['subject']));
     if Mail.Values['body'] <> '' then
       MapiMessage.lpszNoteText := StrNew(PChar(Mail.Values['body']));
 
     WndList := DisableTaskWindows(0);
     try
     Result := MapiSendMail(MAPI_Session, Handle,
       MapiMessage, MAPI_DIALOG, 0);
     finally
       EnableTaskWindows( WndList );
     end;
 
     for i1 := 0 to AttachCount - 1 do
     begin
       StrDispose(Attachments[i1].lpszPathName);
       StrDispose(Attachments[i1].lpszFileName);
     end;
 
     if Assigned(MapiMessage.lpszSubject) then
       StrDispose(MapiMessage.lpszSubject);
     if Assigned(MapiMessage.lpszNoteText) then
       StrDispose(MapiMessage.lpszNoteText);
     if Assigned(Receip.lpszAddress) then
       StrDispose(Receip.lpszAddress);
     if Assigned(Receip.lpszName) then
       StrDispose(Receip.lpszName);
     MapiLogOff(MAPI_Session, Handle, 0, 0);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   mail: TStringList;
 begin
   mail := TStringList.Create;
   try
     mail.values['to'] := 'Receiver-Email@test.xyz';
     mail.values['subject'] := 'Hello';
     mail.values['body'] := 'blah';
     mail.values['body'] := 'blah';
     mail.values['attachment0'] := 'C:\Test.txt';
     // mail.values['attachment1']:='C:\Test2.txt'; 
     sendEMail(Application.Handle, mail);
   finally
     mail.Free;
   end;
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS