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

ВИДЕОКУРС ВЗЛОМ
выпущен 10 декабря!


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

БОЛЬШОЙ FAQ ПО DELPHI



Прокрутка TreeView, чтобы держать выделение посередине


  procedure TMyForm.TreeChange(Sender: TObject; Node: TTreeNode);
  var
    i : integer;
    pp, cp : TTreeNode;
  begin
    if Assigned(Tree.Selected) then
      begin
        cp := Tree.Selected;
        pp := cp;
        for i := 1 to Round(Tree.Height/30) do
          if cp <> nil then
            begin
              pp := cp;
              cp := cp.GetPrevVisible;
            end;
        Tree.TopItem := pp;
      end;
  end;
 




Получение доступа к узлам TreeView

Автор: Peter Kane

Небольшие хитрости для работы с узлами TreeView:

Если вы хотите производить поиск по дереву, может быть для того, чтобы найти узел, соответствующий определенному критерию, то НЕ ДЕЛАЙТЕ ЭТО ТАКИМ ОБРАЗОМ:


 for i := 0 to pred(MyTreeView.Items.Count) do
 begin
   if MyTreeView.Items[i].Text = 'Банзай' then
     break;
 end;
 

...если вам не дорого время обработки массива узлов.

Значительно быстрее будет так:


 Noddy := MyTreeView.Items[0];
 Searching := true;
 while (Searching) and (Noddy <> nil) do
 begin
   if Noddy.text = SearchTarget then
   begin
     Searching := False;
     MyTreeView.Selected := Noddy;
     MyTreeView.SetFocus;
   end
   else
   begin
     Noddy := Noddy.GetNext
   end;
 end;
 

В моей системе приведенный выше код показал скорость 33 милисекунды при работе с деревом, имеющим 171 узел. Первый поиск потребовал 2.15 секунд.

Оказывается, процесс индексирования очень медленный. Я подозреваю, что при каждой индексации свойства Items, вы осуществляете линейный поиск, но это нигде не засвидетельствовано, поэтому я могу ошибаться.

Вам действительно не нужно просматривать все дерево, чтобы найти что вам нужно - получить таким образом доступ к MyTreeView.Items[170] займет много больше времени, чем получения доступа к MyTreeView.Items[1].

Как правило, для отслеживания позиции в дереве TreeView, нужно использовать временную переменную TTreeNode, а не использовать целочисленные индексы. Возможно, свойство ItemId как раз и необходимо для такого применения, но, к сожалению, я никак не могу понять абзац в электронной документации, касающийся данного свойства:

     "Свойство ItemId является дескриптором TTreeNode типа HTreeItem
     и однозначно идентифицирует каждый элемент дерева. Используйте
     это свойство, если вам необходимо получить доступ к элементам
     дерева из внешнего по отношению к TreeView элемента управления."

"Я разговаривал с деревьями...вот почему они ушли от меня...." (Spike Milligan)..




Хитрости печати

Все просто. Если знать как. Приведу небольшой код, позволяющий стать гуру в области печати. Надеюсь. Смотрите на комментарии. Все очень просто.


 const
   INCHES_PER_MILIMETER: Real = 0.04;
 
 type
   TOffset = record
     X, Y: Integer;
   end;
 
 var
   FDeviceName: string; {Имя устройства}
 
   FPageHeightPixel, FPageWidthPixel: Integer; {Высота и ширина страницы}
   FOrientation: TPrinterOrientation; {Ориентация}
   FPrintOffsetPixels: TOffset;
   FPixelsPerMMX, FPixelsPerMMY: Real;
   MMSize, FPageHeightMM: Integer;
   TheReport, TheHead, HeadLine, RecordLine, TFname, TLname: string;
 
 procedure TMissing_Rep.GetDeviceSettings;
 
 var
   retval: integer;
   PixX, PixY: Integer;
 
 begin
 
   FDeviceName := Printer.Printers[Printer.PrinterIndex]; {Получаем имя}
   FPageHeightPixel := Printer.PageHeight; {Получаем высоту страницы}
   FPageWidthPixel := Printer.PageWidth; {Получаем ширину страницы}
   FOrientation := Printer.Orientation;
   {Ориентация}
 
   {Получаем отступ при печати (поля страницы)}
 {$IFDEF WIN32}
   FPrintOffsetPixels.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
   FPrintOffsetPixels.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
 {$ELSE}
   retval := Escape(Printer.Handle, GETPRINTINGOFFSET,
     0, nil, @FPrintOffsetPixels);
 {$ENDIF}
   {Получаем количество пикселей, печатаемое на миллиметре бумаги}
   PixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
   PixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
   FPixelsPerMMX := INCHES_PER_MILIMETER * PixX;
   FPixelsPerMMY := INCHES_PER_MILIMETER * PixY;
   FPageHeightMM := Round(FPageHeightPixel / FPixelsPerMMY);
 end;
 
 function TMissing_Rep.PutText(mmX, mmY: Integer; S: string; LeftAlign:
   Boolean): boolean;
 var
 
   X, Y: Integer;
   align: WORD;
 begin
 
   if LeftAlign then
     align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_LEFT)
   else
     align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_RIGHT);
   result := FALSE; {Вначале присваиваем флаг неудачи при выполнении функции}
   X := Trunc(mmX * FPixelsPerMMX) - FPrintOffsetPixels.X;
   Y := Trunc(mmY * FPixelsPerMMY) - FPrintOffsetPixels.Y;
   if X < 0 then
     exit;
   if Y < 0 then
     exit;
   Printer.Canvas.TextOut(X, Y, S);
   result := TRUE;
 end;
 
 procedure TMissing_Rep.Print_ButClick(Sender: TObject);
 
 var
   PixelSize: Integer;
 
 begin
   Print_But.Enabled := False;
   if PrintDialog1.Execute then
 
   begin
     Printer.Canvas.Font := Missing_Rep.Font;
     PixelSize := Printer.Canvas.TextHeight('Yy');
     MMSize := Round(PixelSize / FPixelsPerMMY);
     Printer.Title := 'Отчет';
     Printer.BeginDoc; { начинаем пересылать задание на печать }
     PrintGenerator;
     Printer.EndDoc; { EndDoc заканчивает задание печати }
   end;
   Print_But.Enabled := True;
 end;
 
 procedure TMissing_Rep.PrintGenerator;
 
 var
   yLoc, NumRows, TheRow: Integer;
 
   procedure Heading;
   begin
     yLoc := 20;
     PutText(20, 20, TheHead, TRUE);
     yLoc := yLoc + MMSize;
     PutText(20, yLoc, StringGrid1.Cells[0, 0], TRUE);
     PutText(60, yLoc, StringGrid1.Cells[1, 0], TRUE);
     PutText(100, yLoc, StringGrid1.Cells[2, 0], TRUE);
     PutText(120, yLoc, StringGrid1.Cells[3, 0], TRUE);
     PutText(150, yLoc, StringGrid1.Cells[4, 0], TRUE);
     yLoc := yLoc + MMSize;
   end;
 
   procedure Footer;
   begin
     PutText(100, FPageHeightMM, InttoStr(Printer.PageNumber), TRUE);
   end;
 
 begin
 
   Heading;
   TheRow := 1;
   while (TheRow < StringGrid1.RowCount) do
   begin
     if (yLoc > (FPageHeightMM - MMSize)) then
     begin
       Footer;
       Printer.NewPage;
       Heading;
     end;
     TheGauge.Progress := Round(100 * TheRow / (StringGrid1.RowCount - 1));
     PutText(20, yLoc, StringGrid1.Cells[0, TheRow], TRUE);
     PutText(60, yLoc, StringGrid1.Cells[1, TheRow], TRUE);
     PutText(100, yLoc, StringGrid1.Cells[2, TheRow], TRUE);
     PutText(120, yLoc, StringGrid1.Cells[3, TheRow], TRUE);
     PutText(150, yLoc, StringGrid1.Cells[4, TheRow], TRUE);
     yLoc := yLoc + MMSize;
     TheRow := TheRow + 1;
   end;
   Footer;
 end;
 




Как сделать откат внутри триггера

Внутри триггера нельзя управлять транзакциями, поэтому генерируешь там исключение а откат транзакции делаешь в приложении, пославшем запрос. Естественно exception должен предварительно создан


 SET TERM !!;
 
 CREATE TRIGGER " DELETE_INV"  FOR " TINV"
     ACTIVE BEFORE DELETE
     POSITION 10
     AS
     BEGIN
         IF (EXISTS (SELECT tOst.Id FROM tOst
                     WHERE tOst.Id = tInv.Id))
         THEN
             EXCEPTION EST_OSTATOK;
     END !!
 
 SET TERM ;!!
 
 
 DBase.StartTransaction;
 try
   Query.ExecSQL;
   DBase.Commit;
 except
   DBase.Rollback;
   raise;    // Для последующей обработки
 end;
 




Компонент для последовательного устройства (TRS232)

Просыпается программист с большого бодуна, поворачивается, а рядом какая-то девушка лежит.
- Ooрs, обнаружено новое устройство...

Компонент, который представлен здесь, выполняет функции синхронного чтения и записи в последовательный интерфейс RS232.

В цикле выполняется Application.ProcessMessages, чтобы все сообщения от основной программы обрабатывались.

Ниже приведён метод ReadString из компонента TRS323:


 function TRS232.ReadString(var aResStr: string; aCount: word ): boolean;
 var
   nRead: dword;
   Buffer: string;
   Actual, Before: TDateTime;
   TimeOutMin, TimeOutSec, lCount: word;
 begin
   Result := false;
   if not Connected then
     if not Connect then
       raise Exception.CreateHelp('RS232.ReadString:' +
       ' Connect not possible !', 101);
   aResStr := '';
   TimeOutMin:=TimeOut div 60;
   TimeOutSec:=TimeOut mod 60;
   if (not Connected) or (aCount <= 0) then
     EXIT;
   nRead := 0; lCount := 0;
   Before := Time;
   while lCount < ACOUNT do
   begin
     Application.ProcessMessages;
     SetLength(Buffer,1);
     if ReadFile( FComPortHandle, PChar(Buffer)^, 1, nRead, nil) then
     begin
       if nRead > 0 then
       begin
         aResStr := aResStr + Buffer;
         inc(lCount);
       end;
       Actual := Time;
       if Actual-Before>EncodeTime(0, TimeOutMin, TimeOutSec, 0) then
         raise Exception.CreateHelp('RS232.ReadString: TimeOut !', 103);
     end
     else
     begin
       raise Exception.CreateHelp('RS232.ReadString: Read not possible !', 104);
     end;
   end;
   Result:=true;
 end;
 




Как отловить сообщения о прокрутке TScrollBar

Автор: Олег Кулабухов

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


 type
 {$IFDEF WIN32}
   WParameter = LongInt;
 {$ELSE}
   WParameter = Word;
 {$ENDIF}
   LParameter = LongInt;
 
   {Declare a variable to hold the window procedure we are replacing}
 var
   OldWindowProc: Pointer;
 
 function NewWindowProc(WindowHandle: hWnd;
   TheMessage: WParameter;
   ParamW: WParameter;
   ParamL: LParameter): LongInt
 {$IFDEF WIN32} stdcall;
 {$ELSE}; export;
 {$ENDIF}
 var
   TheRangeMin: integer;
   TheRangeMax: integer;
   TheRange: integer;
 begin
 
   if TheMessage = WM_VSCROLL then
   begin
     {Get the min and max range of the horizontal scroll box}
     GetScrollRange(WindowHandle,
       SB_HORZ,
       TheRangeMin,
       TheRangeMax);
     {Get the vertical scroll box position}
     TheRange := GetScrollPos(WindowHandle,
       SB_VERT);
     {Make sure we wont exceed the range}
     if TheRange < TheRangeMin then
       TheRange := TheRangeMin
     else if TheRange > TheRangeMax then
       TheRange := TheRangeMax;
     {Set the horizontal scroll bar}
     SetScrollPos(WindowHandle,
       SB_HORZ,
       TheRange,
       true);
   end;
 
   if TheMessage = WM_HSCROLL then
   begin
     {Get the min and max range of the horizontal scroll box}
     GetScrollRange(WindowHandle,
       SB_VERT,
       TheRangeMin,
       TheRangeMax);
     {Get the horizontal scroll box position}
     TheRange := GetScrollPos(WindowHandle,
       SB_HORZ);
     {Make sure we wont exceed the range}
     if TheRange < TheRangeMin then
       TheRange := TheRangeMin
     else if TheRange > TheRangeMax then
       TheRange := TheRangeMax;
     {Set the vertical scroll bar}
     SetScrollPos(WindowHandle,
       SB_VERT,
       TheRange,
       true);
   end;
 
   { Call the old Window procedure to }
   { allow processing of the message. }
   NewWindowProc := CallWindowProc(OldWindowProc,
     WindowHandle,
     TheMessage,
     ParamW,
     ParamL);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   { Set the new window procedure for the control }
   { and remember the old window procedure. }
   OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
     GWL_WNDPROC,
     LongInt(@NewWindowProc)));
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   { Set the window procedure back }
   { to the old window procedure. }
   SetWindowLong(ScrollBox1.Handle,
     GWL_WNDPROC,
     LongInt(OldWindowProc));
 end;
 




Как перехватить сообщения прокрутки в TScrollBox

Следующий пример перхватывает сообщения скроллирования в компоненте TScrollBox, тем самым синхронизируя два скролбара. Если один из скролбаров изменяет своё положение, то значение второго скролбара изменяется на такую же величину. Сообщения скролирования перехватываются путём сабклассинга оконной процедуры (WinProc) у скролбара.


 type
   {$IFDEF WIN32}
   WParameter = LongInt;
   {$ELSE}
   WParameter = Word;
   {$ENDIF}
   LParameter = LongInt;
 
 {Declare a variable to hold the window procedure we are replacing}
 var
   OldWindowProc : Pointer;
 
 function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter;
 ParamW : WParameter; ParamL : LParameter) : LongInt
 {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
 var
   TheRangeMin : integer;
   TheRangeMax : integer;
   TheRange : integer;
 begin
   if TheMessage = WM_VSCROLL then
   begin
     {Get the min and max range of the horizontal scroll box}
     GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax);
     {Get the vertical scroll box position}
     TheRange := GetScrollPos(WindowHandle, SB_VERT);
     {Make sure we wont exceed the range}
     if TheRange < TheRangeMin then
       TheRange := TheRangeMin
     else
     if TheRange > TheRangeMax then
       TheRange := TheRangeMax;
     {Set the horizontal scroll bar}
     SetScrollPos(WindowHandle, SB_HORZ, TheRange, true);
   end;
   if TheMessage = WM_HSCROLL then
   begin
     {Get the min and max range of the horizontal scroll box}
     GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax);
     {Get the horizontal scroll box position}
     TheRange := GetScrollPos(WindowHandle, SB_HORZ);
     {Make sure we wont exceed the range}
     if TheRange < TheRangeMin then
       TheRange := TheRangeMin
     else
     if TheRange > TheRangeMax then
       TheRange := TheRangeMax;
     {Set the vertical scroll bar}
     SetScrollPos(WindowHandle, SB_VERT, TheRange, true);
   end;
 
   {Call the old Window procedure to allow processing of the message.}
   NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle,
   TheMessage, ParamW, ParamL);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   {Set the new window procedure for the control and remember
   the old window procedure.}
   OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
   GWL_WNDPROC, LongInt(@NewWindowProc)));
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   {Set the window procedure back to the old window procedure.}
   SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc));
 end;
 




Использование компонента TServerSocket


Попал фидошник в ад. Ему черт говорит:
- Тебе определено 1000 лет наказания, но т. к. я люблю анекдоты, то разрешаю их тебе рассказывать. Пока ты их рассказываешь, этот срок будет вычтен из твоего наказания.
Ну, фидошник начинает травить анекдоты. Год... два... 100 лет... 900 лет прошло, он все рассказывает. Наконец, на 999 году замолкает.
- Все, анекдоты закончились? Ну, давай хоть год тебя помучаю.
- Да погоди ты, сейчас вторую часть офтопик-листа достану!

В Delphi документации по многопотоковому TServerSocket налито довольно много воды, и начинающему программисту сложно понять суть дела. Давайте попытаемся пролить немного света на этот раздел хелпа.

Вообще-то, создать многопотоковый сервер, который ожидает пришедшие сообщения на сокете довольно просто. В Delphi для этой цели достаточно использовать компонент TServerSocket.

Давайте рассмотрим структуру работы данного компонента:

  • Добавляем TServerSocket в Вашу основную форму.
  • Устанавливаем свойство Servertype в stThreadBlocking
  • Создаём новый "unit" (показанный ниже) содержащий поток сервера.

Устанавливаем следующий код на OnSocketGetThread


 procedure TfrmMain.fSocketGetThread(Sender: TObject;
 ClientSocket: TServerClientWinSocket;
 var
   SocketThread: TServerClientThread);
 begin
   // Здесь создаём объект TServerThread, который я привожу ниже.
   // Новый объект создаётся каждый раз, когда когда установлен канал связи.
   SocketThread := TServerThread.Create( FALSE, ClientSocket );
 end;
 

TServerThread - это объект, который я создаю самостоятельно. Объект наследуется от TServerClientThread и содержит код, который обычно читает и пишет данные из/в сокет.

Созданный Unit, содержит следующий код:


 unit serverthread;
 
 interface
 
 uses
   windows, scktcomp, SysUtils, Classes, Forms;
 
 type
   EServerThread = class( Exception );
   // serverthread это потомок TServerClientThread
   TServerThread = class( TServerClientThread )
   private
     fSocketStream : TWinSocketStream;
   public
     procedure ClientExecute; override;
     // ClientExecute отменяет
     // TServerClientThread.ClientExecute
     // и содержит код, который
     // выполняется при старте потока
   end;
 
 implementation
 
 procedure TServerThread.ClientExecute;
 begin
   inherited FreeOnTerminate := TRUE;
   try
     fSocketStream := TWinSocketStream.Create( ClientSocket, 100000 );
     // 100000 - это таймаут в миллисекундах.
     try
       while ( not Terminated ) and ( ClientSocket.Connected ) do
         try
           // В это место обычно помещается код,
           // ожидающий входных данных, читающий из сокета или пишущий в него
           // Пример, приведённый ниже, показывает, что можно добавить в данную
           // секцию программы.
         except
           on e:exception do
           begin
             // Если произошла ошибка, то закрываем сокет и выходим
             ClientSocket.Close;
             Terminate;
           end;
         end;
     finally
       fSocketStream.Free;
     end;
   except
     on e:exception do
     begin
       // Если произошла ошибка, то закрываем сокет и выходим
       ClientSocket.Close;
       Terminate;
     end;
   end;
 end;
 

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


 if (not Terminated) and (not fSocketStream.WaitForData(1000000)) then
 begin
   // Обработчик таймаута (т.е. если по истечении 1000000 миллисекунд
   // от клиента не пришло запроса
 end;
 // В сокете есть входящие данные!
 

Для чтения данных, Вам понадобится создать буфер для хранения полученных данных. Обычно буфер - это PByteArray или массив символов. В этом примере я обозвал буфер как fRequest который является массивом символов. Кроме того я ожидаю фиксированное количество байт. Массив имеет постоянный размер REQUESTSIZE.


 var
   ac, readlen: integer;
 begin
   FillChar( fRequest, REQUESTSIZE, 0 );
   ac := 0;
   repeat
     readlen := fSocketStream.read( fRequest[ac], 1024 );
     // считываем блоки по 1024 байт, до тех пор, пока буфер
     // не заполнится
     ac := ac+readlen;
   until
     (readlen = 0) or (ac = REQUESTSIZE);
 end;
 

Если readlen равно 0, значит больше нет входящих данных. Функция Чтения завершается через 100000 миллисекунд после запуска в TWinSocketStream.Create(). Если Вы не знаете сколько времени нужно ожидать запроса от клиента, то чем меньше будет таймаут, тем лучше. В большинстве случаев максимальный таймаут не должен превышать 30 секунд.

При посылке ответа, Вы должны знать, в каком режиме работает клиент. Многие клиенты ожидают только один пакет ответа, другие ожидают несколько пакетов. В этом примере, я подразумеваю клиента, который ожидает только один пакет, так что я должен послать мои данные назад в одном блоке:


 fSocketStream.WriteBuffer(fRep, fReplySize);
 

fRep это буфер, содержащий ответ на запрос клиента, и fReplySize - это размер буфера.




TStringGrid и файловый поток

- Хотел бы я на "винте" столько места, чтобы на него влез двухсот гигабайтный своп-файл!
- Зачем тебе такой большой своп?!!
- Да не нужен мне такой своп! Просто хотелось бы столько места!..

Какое наилучшее решение для сохранения экземпляра TStringGrid (150x10)?

Если вы хотите сохранить это на диске:


 var:
   myStream: TFileStream;
 begin
   myStream1 := TFileStream.Create('grid1.sav', fmCreate);
   myStream1.WriteComponent(StringGrid1);
   myStream1.Destroy;
 end;
 

Для обратного чтения:


 myStream    := TFileStream.Create('grid1.sav', fmOpenRead);
 StringGrid1 := myStream1.ReadComponent(StringGrid1) as TStringGrid;
 




Форматирование ячеек TStringGrid

Hажмите ! Ещё! Format complete...

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

Вам нужно сделать пару вещей:

  • Обработчик OnDrawCell, отображающий отформатированные данные, выровненные по правому краю.
  • В ячейки вашей сетки загружать неформатированные строки, представляющие собой ваши данные.

В вашем обработчике OnDrawCell создайте код типа того, что приведен ниже. Этот код отображает разделенную запятой величину, выровненную по правому краю:


 begin
   if (Row > 0) and (Col > 0) and (grdDivBudget.Cells[Col, Row] <> '') then
   begin
     {Формат строки с числом с плавающей точкой}
     strText := FloatToStrF(StrToFloat(grdDivBudget.Cells[Col, Row]),
       ffNumber, 13, 2);
 
     {Устанавливаем шрифт}
     grdDivBudget.Canvas.Font.Name := 'Courier';
     if StrToFloat(grdDivBudget.Cells[Col, Row]) < 0 then
       grdDivBudget.Canvas.Font.Color := clRed;
     grdDivBudget.Canvas.Font.Style := grdDivBudget.Canvas.Font.Style -
       [fsBold];
 
     {Центрируем текст в ячейке по вертикали, по правому полю,
     и отодвигаем его от правого поля на два пикселя.}
     X := Rect.Right - grdDivBudget.Canvas.TextWidth(strText);
     Y := Rect.Top + ((Rect.Bottom - Rect.Top -
       grdDivBudget.Canvas.TextHeight(strText)) div 2);
     Dec(Rect.Right, 2);
 
     grdDivBudget.Canvas.TextRect(Rect, X, Y, strText);
   end;
 end;
 

Убедитесь в том, что вы имеете DefaultDrawing := True, так, чтобы вы могли в ячейках выводить только текст, остальную отрисовку за вас сделает VCL.

Теперь все должно работать. При попытке пользователя отредактировать число в ячейке, оно будет отображаться в неформатированном виде (если у вас нет необходимости в обработчике события OnGetEditText).

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




TStringGrid с фокусом (OnDrawCell)

Если вы создаете собственный обработчик компонента TStringGrid OnDrawCell, то вы можете нарисовать все, что вам заблагорассудится. Попробуйте, к примеру, это:


 procedure TForm1.DrawCell(Sender: TObject;
   Col: Longint;
   Row: Longint;
   Rect: TRect;
   State: TGridDrawState);
 var
   lRow, lCol: LongInt;
   S: string;
 begin
   lRow := Row;
   lCol := Col;
   with Sender as TStringGrid, Canvas do
   begin
     if (gdSelected in State) then
     begin
       Brush.Color := clHighlight; { *** }
     end
     else if (lRow < FixedRows) or (lCol < FixedCols) then
     begin
       Brush.Color := FixedColor;
     end
     else
     begin
       Brush.Color := Color;
     end;
     FillRect(Rect);
     SetBkMode(Handle, TRANSPARENT);
     TextOut(Rect.Left + 2, Rect.Top + 2, Cells[lCol, lRow]);
   end;
 end;
 

Строка с комментарием { *** } в данном контексте ключевая. Она "сообщает" о том, что если мы рисуем ячейку, которая имеет фокус, то мы ее рисуем с применением цвета подсветки (highlight) (хотя вы бы могли здесь использовать любой другой нравящийся вам цвет), хотя никто нам специально о необходимости подкрашивания области сфокусированной ячейки и не говорил. Единственная проблема возникает со шрифтом, но в конечном счете я обнаружил, что она решается сама собой, если установить свойство компонента TStringGrid DefaultDrawing в TRUE (я потерял немало времени, решая проблему цвета шрифта со значением FALSE!). Попробуйте также поиграться с другими настройками цветов, может вам повезет и вы добъетесь неописуемой красоты компонента TStringGrid.




TStringList в TIniFile

Летит компьютер с 9-го этажа, и думает: "Вот бы щас зависнуть... "


 uses Classes;
 
 type
   TIniStringlist = class( TStringList )
   public
     procedure LoadFromIni(const FileName, Section: string);
     procedure SaveToIni(const FileName, Section: string);
 end;
 
 implementation
 
 uses
   IniFiles, SysUtils;
 
 procedure TIniStringList.LoadFromIni(const FileName, Section: string);
 var
   index: Integer;
   Line: string;
 begin
   with TIniFile.Create( FileName ) do
     try
       ReadSectionValues( Section, Self);
       for index:= 0 to Count - 1 do
       begin
         { Удаляем имя идентификатора ...}
         Line:= Values[ IntToStr( index ) ];
         { Удаляем тильду ... }
         System.Delete( Line, 1, 1);
         Strings[ index ]:= Line;
       end;
     finally
       Free;
     end;
 end;
 
 procedure TIniStringList.SaveToIni( const FileName, Section: string);
 var
   index: Integer;
   Line: string;
 begin
   with TIniFile.Create( FileName ) do
     try
       EraseSection( Section );
       for index:= 0 to Count - 1 do
       begin
         { Сохраняем белые пробелы, пустые строки ...}
         Line:= '~' + Strings[ index ];
         WriteString( Section, IntToStr( index ), Line);
       end;
     finally
       Free;
     end;
 end;
 
 end.
 

Применение:


 var
   L: TIniStringList;
 begin
   L := TIniStringList.Create;
   L.LoadFromIni('MyFile.Ini', 'Alati'); {Загружаем L..}
   L.Free;
 end.
 




Свойство TStringList

Автор: Mike Orriss

Вам необходимо определять поле как TStrings, а не как TStringList - ловушка, в которую, подразумеваю, попадал не я один!

Следующий пример показывает подход, необходимый для создания свойства, имеющего тип TStringList:


 private
   FList: TStrings;
 
 protected
   procedure SetList(Value: TStrings);
 published
   property List: TStrings read FList write SetList;
 
 ...
 
 constructor Txxxxx.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FList := TStringList.Create;
 end;
 
 destructor Txxxxx.Destroy;
 begin
   FList.Free;
   inherited Destroy;
 end;
 
 procedure Txxxxx.SetList(Value: TStrings);
 begin
   FList.Assign(Value);
 end;
 




Редактор свойства TStringListProperty

Автор: Pat Ritchey

Я пишу редактор для свойства TStrings. В зависимости от значений других свойств, я хотел бы показывать или свой редактор свойства, или редактор свойства TStringListProperty, заданный по умолчанию, но я не знаю как передавать управление TStringListProperty...

Сделайте ваш редактор свойства наследником TStringListProperty (добавьте STREDIT в список используемых модулей) и согласно вашим обстоятельствам вызывайте метод предка Edit:


 unit MyEditor;
 
 interface
 
 uses STREDIT;
 
 type
   TMyStringListProperty = class(TStringListProperty)
     procedure Edit; override;
   end;
 
 implementation
 
 procedure TMyStringListProperty.Edit;
 begin
   if { какие-то условия } then
     { что-то делаем }
   else
     inherited Edit;
 end;
 
 end.
 




TStringList и потоки

Автор: Mike Scott

Возможно ли выполнить StringList.SaveToStream во время процесса WriteComponent? Если необходимо создать код, сохраняющий каждую строку, могу ли я воспользоваться Stream.WriteStr, или мне необходимо сохранять длину в байтах + сами символы? (Все мои строки < 256 символов).

Вы можете легко записывать строки, если определите, что список строк вместо DefineBinaryPropery должен использовать DefineProperty. Чтение и запись должны выпоняться соответственно с помощью методов TReader и TWriter. Записывать вы можете приблизительно так:


 Writer.WriteListBegin ;
 for i := 0 to TheStringList.Count - 1 do
 Writer.WriteString( TheStringList[ i ] ) ;
 Writer.WriteListEnd ;
 

Для чтения можно воспользоваться следующим кодом:


 Reader.ReadListBegin ;
 while not Reader.EndOfList do
 TheStringList.Add( Reader.ReadString ) ;
 Reader.ReadListEnd ;
 




TStringList.IndexOf. Зависимость от сортировки

Автор: Илья Илларионов

Свойство Sorted и метод IndexOf. В VCL Help написано, что TStringlist.IndexOf возвращает ссылку на ПЕРВЫЙ объект списка, имеющий заданное имя. В случае, если Sorted == False, это именно так, потому что индекс ищется путем прямого сканирования имен. В случае же, если Sorted == True, и объектов с одинаковым именем в списке НЕСКОЛЬКО, IndexOf возвращает вхождение ПОСЛЕДНЕГО объекта, т.к. поиск осуществляется по отсортированному массиву, а именно после последнего объекта должен добавлять метод Add при добавлении в сортированный массив. Логично, но полное противоречие с Help.

Способ решения пока такой: после получения индекса пытаться сканировать вверх до тех пор, пока имя не перестанет совпадать с требуемым, или до 0. При сканировании следует обращать внимание на свойство CaseSensitive класса.

КОММЕНТАРИЙ

Анализ кода TStringList.IndexOf (D5) показывает, что в случае отсутствия сортировки работает линейный метод TStrings.IndexOf, иначе - метод Find, который и находит (согласно Help) последний из одинаковых элементов.

Вывод: недоработана статья из Help по TStringList.IndexOf, где эта особенность не описана.




TStringList, владеющий объектами

В этом случае вам нужно освобождать объекты StringList точно также, как вы это делали без него. StringList.Free просто очистит список и строки, но не ассоциированные с ними объекты. Дело в том, что вы могли бы иметь указатели на объекты, например, в двух StringList, и вы могли бы захотеть освободить в одном список строк без освобождения объектов, содержащихся в другом.

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


 TOwnerStringList = class(TStringList)
 private
   FOwnsObjects: Boolean;
 public
   constructor Create(AOwnsObjects: Boolean); override;
   destructor Destroy; override;
 end;
 
 constructor TOwnerStringList.Create(AOwnsObjects: Boolean);
 begin
   inherited Create;
   FOwnsObjects := AOwnsObjects;
 end;
 
 destructor TOwnerStringList.Destroy;
 var
   I: Integer;
 begin
   if FOwnsObjects then
     for I := 0 to MyStrLst.Count - 1 do
       TObject(Objects[I]).Free;
   inherited Destroy;
 end;
 

Теперь, когда у вас есть взаимно-однозначное соответствие между списком строк и имеющимися объектами, то для создания нового списка, который уничтожал бы объекты при освобождении списка строк, вам необходимо выполнить команду: "MyStringList := TOwnerStringList.Create(True)". Для того, чтобы список вел себя как обычно, передавайте в методе Create в качестве параметра False, или просто используйте нормальный TStringList.




TStringList. Неустойчивость сортировки

Автор: Илья Илларионов

Метод Sort класса TStringList является НЕУСТОЙЧИВЫМ. Это критично при работе со свойством Objects. Например, при использовании в качестве строкового индекса для добавляемых объектов. После вызова Sort объекты с одинаковым именем в списке располагаются в порядке, обратном тому, в котором были добавлены.

Способ решения - всегда сортировать список два раза. В этом случае, даже если Borland поправит недокументированный глюк с неустойчивостью сортировки, объекты все равно будут, после перекомпиляции на новых исходниках TStringList, находиться в нужном порядке.

КОММЕНТАРИЙ

Этот камень перенесен из категории БИБЛИОТЕКА.

Описываемый эффект обусловлен особенностью реализации метода сортировки QuickSort. Во первых, нельзя считать его неустойчивым, поскольку он всегда поступает однообразно по отношению к элементам с одинаковым значением ключа - а именно переупорядочивает их строго в обратном порядке по отношению к исходному. Во-вторых, как справедливо замечено в обсуждении, метод сортировки не несет ответственности за порядок сортировки при неуникальных ключах.




Показываем директории в TTreeView


 procedure TForm1.GetDirectories(Tree: TTreeView; Directory: string;
 Item: TTreeNode; IncludeFiles: Boolean);
 var
   SearchRec: TSearchRec;
   ItemTemp: TTreeNode;
 begin
   Tree.Items.BeginUpdate;
   if Directory[Length(Directory)] <> '\' then Directory := Directory + '\';
   if FindFirst(Directory + '*.*', faDirectory, SearchRec) = 0 then
   begin
     repeat
       if (SearchRec.Attr and faDirectory = faDirectory) and
       (SearchRec.Name[1] <> '.') then
       begin
         if (SearchRec.Attr and faDirectory > 0) then
           Item := Tree.Items.AddChild(Item, SearchRec.Name);
         ItemTemp := Item.Parent;
         GetDirectories(Tree, Directory + SearchRec.Name, Item, IncludeFiles);
         Item := ItemTemp;
       end
       else if IncludeFiles then
         if SearchRec.Name[1] <> '.' then
           Tree.Items.AddChild(Item, SearchRec.Name);
     until FindNext(SearchRec) <> 0;
     FindClose(SearchRec);
   end;
   Tree.Items.EndUpdate;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Node: TTreeNode;
   Path: string;
   Dir: string;
 begin
   Dir := 'c:\temp';
   Screen.Cursor := crHourGlass;
   TreeView1.Items.BeginUpdate;
   try
     TreeView1.Items.Clear;
     GetDirectories(TreeView1, Dir, nil, True);
   finally
     Screen.Cursor := crDefault;
     TreeView1.Items.EndUpdate;
   end;
 end;
 




Получить строковый путь в TTreeView


 function SrNodeTree(pTreeNode: TTreeNode; var sRuta: string): string;
 begin
   sRuta := pTreeNode.Text + ' > ' + sRuta;
   if pTreeNode.Level = 0 then Result := sRuta
   else
     Result := SrNodeTree(pTreeNode.Parent, sRuta);
 end;
 
 {*---------------------------------------------
   Click an Item
  ---------------------------------------------*}
 
 procedure TForm1.TreeView1Click(Sender: TObject);
 var
   sPath: string;
 begin
   label1.Caption := SrNodeTree(TreeView1.Selected, sPath);
 end;
 




Принцип и порядок работы с TUpdateSQL для работы с неживыми запросами

Автор: Nomadic

Кидаешь UpdateSQL на форму, после чего в том SQL, который ты собираешься редактировать, устанавливаешь в UpdateObject имя этого UpdateSQL. После этих дел по дабл-клику на UpdateSQL выдаётся редактор, в котором ты должен для каждой из таблиц,входящих в твой запрос, указать набор полей, являющихся уникальным ключём таблицы, и набор полей, которые требуется редактировать. В общем случае возможны глюки с редактированием, если в числе изменяемых полей будут элементы ключа. Указав все поля, давишь кнопку Generate SQL и в результате у тебя генерятся запросы на редактирование, добавление и удаление, которые прописываются в том же UpdateSQL. Обычно эти запросы никакого дополнительного редактирования не требуют. После всех этих дел ты можешь нормально редактировать запрос, как обычную таблицу.

Hекоторые моменты.

Для того, чтобы всё это нормально работало, нужно, чтобы в TQuery были включены RequestLive и CashedUpdates. Соответственно, для подтверждения изменений нужно вызывать TQuery.ApplyUpdates и TQuery.CommitUpdates, либо TDatabase.ApplyUpdates, а для отмены - CancelUpdates.

Если меняешь структуру таблиц, то не забывай менять списки полей в UpdateSQL, иначе можешь получить неприятный сюрприз - будешь долго сидеть и думать, почему при редактировании/добавлении некоторые поля не прописываются :-).

Hасчёт CachedUpdates.

Сия хреновина придумана для того, чтобы обеспечить сохранение/отмену редактирования/добавления/удаления сразу нескольких записей. Принцип совершенно элементарен: если CachedUpdates включен, то все производимые изменения в датасете по команде Post фиксируются не в базе, а во временном файле на винте клиента. Для того, чтобы прописать изменения в таблице (физически), необходимо вызвать для соответствующего запроса последовательно методы ApplyUpdates и CommitUpdates, а для отмены ВСЕХ изменений (начиная от последнего выполненного CommitUpdates), вызвать CancelUpdates. Кроме того, метод ApplyUpdates у TDataBase. Этому методу нужен список датасетов, и он производит их обновление в одной транзакции.

Практическое применение, например, такое: на форме редактирования с гридом и набором кнопок Добавить, Удалить, Редактировать, ОК, Отмена, вешаешь на первые три кнопки обработчики с Insert, Delete и Edit соответственно, на ОК - такой примерно обработчик:


 with DataSet do
 begin
   if State in [dsEdit,dsInsert] then
     Post;
   ApplyUpdates;
   CommitUpdates;
 end;
 

а на Отмену такой:


 with DataSet do
 begin
   if State in [dsEdit,dsInsert] then
     Cancel;
   CancelUpdates;
 end;
 

В результате юзер может редактировать хоть всю таблицу, но если успеет спохватиться, то может отменить все свои художества. Только желательно на выходе из формы проверить, сохранены ли изменения,и если нет, то напомнить/переспросить.

Лучше использовать конструкцию "State in dsEditModes"




Как отключить хранитель экрана

Автор: Олег Кулабухов

Встречаются два юзера. Один другому:
- Что-то лицо мне ваше знакомо, вы в скринсейверах не снимались?


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   {Turn it off}
   SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, 0);
 
   {Turn it on}
   SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, 0);
 end;
 




Как выключит спикеp

Автор: Nomadic

Сидит программист дома (работает)... Подходит жена и подносит чашку кофе.
Муж: (отхлебнув глоток) Ты же знаешь, что я люблю кофе без сахара!
Жена: Да, любимый, просто очень захотела услышать твой голос.

Это выключит спикеp:


 SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);
 

Это включит:


 SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);
 




Как включить Caps Lock


 procedure TMyForm.Button1Click(Sender: TObject);
 Var
   KeyState:  TKeyboardState;
 begin
   GetKeyboardState(KeyState);
   if (KeyState[VK_NUMLOCK] = 0) then
     KeyState[VK_NUMLOCK] := 1
   else
     KeyState[VK_NUMLOCK] := 0;
   SetKeyboardState(KeyState);
 end;
 

Для Caps Lock замените VK_NUMLOCK на VK_CAPITAL.




Включение и выключение закладки Notebook

Автор: Ralph Friedman

Выключать компьютер - Шататься дауном.

Вот хороший трюк от Xavier Pacheco:


 unit TabDis;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls, TabNotBk;
 
 type
   TFrmTabDis = class(TForm)
     TabbedNotebook1: TTabbedNotebook;
     Button1: TButton;
     procedure FormCreate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private-Deklarationen }
   public
     { Public-Deklarationen }
   end;
 
 var
   FrmTabDis: TFrmTabDis;
 
 implementation
 
 {$R *.DFM}
 
 procedure TFrmTabDis.FormCreate(Sender: TObject);
 var
   i: integer;
   j: integer;
 begin
   { Создаем имена для всех Notebook TTabButton }
 
   j := 0;
 
   with TabbedNotebook1 do
     for i := 0 to ControlCount - 1 do
       if Controls[i].ClassName = 'TTabButton' then
       begin
         Controls[i].Name := Controls[i].ClassName + IntToStr(j);
         Inc(j);
       end;
 end;
 
 procedure TFrmTabDis.Button1Click(Sender: TObject);
 begin
   { Делаем недоступной определенную страницу notebook }
   with TControl(TabbedNotebook1.FindComponent('TTabButton2')) do
     Enabled := not Enabled;
 end;
 
 end.
 




Как программно включить или выключить NumLock


Хотите получить много $$$$$, все очень просто, от вас практически ничего не требуется, прсто нажмите клавишу Shift и удерживая ее - клавишу 4.


 var
   abKeyState: array [0..255] of byte;
 begin
   GetKeyboardState( Addr( abKeyState[ 0 ] ) );
   abKeyState[ VK_NUMLOCK ] := abKeyState[ VK_NUMLOCK ] or $01;
   SetKeyboardState( Addr( abKeyState[ 0 ] ) );
 end;
 




Добавить текущую страницу TWebBrowser в Избранное

Ответ в окне браузера:
ты ответа не дождешься, глупый юзер, я не твой!


 // You need: 1 TEdit, 2 TButtons, 1 TWebbrowser 
 const
   NotAllowed: set of Char = ['"'] + ['/'] + ['\'] + ['?'] + [':'] + ['*'] +
     ['<'] + ['>'] + ['|'];
 
 implementation
 
 {$R *.DFM}
 
 function Load(Path, Key: string): string;
 var
   Reg: TRegistry;
 begin
   Reg := TRegistry.Create;
   try
     Reg.RootKey := HKEY_CURRENT_USER;
     Reg.OpenKey(Path, False);
     try
       Result := Reg.ReadString(Key);
     except
       Result := '';
     end;
     Reg.CloseKey;
   finally
     Reg.Free;
   end;
 end;
 
 function WinDir: string;
 var
   WinDir: PChar;
 begin
   WinDir := StrAlloc(MAX_PATH);
   GetWindowsDirectory(WinDir, MAX_PATH);
   Result := string(WinDir);
   if Result[Length(Result)] <> '\' then
     Result := Result + '\';
   StrDispose(WinDir);
 end;
 
 function GetSysDir: string;
 var
   dir: array [0..MAX_PATH] of Char;
 begin
   GetSystemDirectory(dir, MAX_PATH);
   Result := StrPas(dir);
 end;
 
 // Navigate to a page 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Webbrowser1.Navigate(edit1.Text);
 end;
 
 // Add the current page to the favorites 
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   url: TStringList;
   fav: string;
   title, b: string;
   i: Integer;
   c: Char;
 begin
   fav := Load('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders','Favorites');
   url := TStringList.Create;
   try
     url.Add('[InternetShortcut]');
     url.Add('URL=' + webbrowser1.LocationURL);
     url.Add('WorkingDirectory=' + WinDir());
     url.Add('IconIndex=0');
     url.Add('ShowCommand=7');
     url.Add('IconFile=' + GetSysDir() + '\url.dll');
     title := Webbrowser1.LocationName;
     b := '';
     for i := 1 to Length(title) do
     begin
       c := title[i];
       if not (c in NotAllowed) then
       begin
         b := b + Webbrowser1.LocationName[i];
       end;
     end;
     url.SaveToFile(fav + '\' + b + '.url');
   finally
     url.Free;
   end;
 end;
 
 end.
 




Как в TWEBBrowser организовать изменение размера шрифта


 procedure TWebBrowserXXX.SetFontSize(nSize: OleVariant);
 begin
   if (nSize >= 0) and (nSize <= 4) then
     ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, nSize)
 end;
 




Заменить рисунки в TWEBBrowser

Сидит на Пр. Ленина студентка и играет на баяне. Перед ней табличка: "Помогите бедной студентке на интернет."


 procedure TForm1.Button1Click(Sender: TObject);
 var
   li: Word;
 begin
   // Loop through all images of a TWebbrowser 
   // Schleife ьber alle Bilder im Webbrowser 
 
   for li := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
     // Exchange image with an own image 
     // Austauschen der Bilder im webbrowser - durch 'MyImage.gif' 
     WebBrowser1.OleObject.Document.Images.Item(0).Src := 'c:\MyImage.gif';
 end;
 




Мерцание формы

Автор: Jeff Johnson

Как бы это осуществить рисование в окне без его дурацкого мерцания и без помощи создания виртуального изображения в памяти? WM_SETREDRAW здесь поможет?

Попробуйте этот код. Даже если некоторые компоненты имеют пару BeginUpdate / EndUpdate, то для таких компонентов, как TTreeView, интенсивное рисование может послужить причиной перемещения полосы прокрутки и появления других "барабашек". В таких ситуаций вместо дескриптора элемента управления используйте родительский дескриптор.


 procedure BeginScreenUpdate(hwnd: THandle);
 begin
   if (hwnd = 0) then
     hwnd := Application.MainForm.Handle;
   SendMessage(hwnd, WM_SETREDRAW, 0, 0);
 end;
 
 procedure EndScreenUpdate(hwnd: THandle; erase: Boolean);
 begin
   if (hwnd = 0) then
     hwnd := Application.MainForm.Handle;
   SendMessage(hwnd, WM_SETREDRAW, 1, 0);
   RedrawWindow(hwnd, nil, 0, DW_FRAME + RDW_INVALIDATE +
     RDW_ALLCHILDREN + RDW_NOINTERNALPAINT);
   if (erase) then
     Windows.InvalidateRect(hwnd, nil, True);
 end;
 




Две колонки в DBLookupComboBox

Попробуйте использовать что-то типа этого:


 DBLookupCombo1.LookupDisplay := 'Company;City;Country';
 

Т.е., для того, чтобы выводить более одного поля, разделите имя каждого поля точкой с запятой.




Drag and Drop для двух компонентов TOutline

Автор: Lloyd Linklater (Sysop) (Delphi Technical Support)


 unit Unit1;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, Grids, Outline;
 
 type
 
   TForm1 = class(TForm)
     Outline1: TOutline;
     Outline2: TOutline;
     procedure OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);
     procedure OutlineMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
     procedure OutlineDragOver(Sender, Source: TObject; X, Y: Integer;
 
       State: TDragState; var Accept: Boolean);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);
 begin
 
   with Sender as TOutline do
   begin
     AddChild(GetItem(x, y),
       TOutline(Source).Items[TOutline(Source).SelectedItem].Text);
   end;
 
 end;
 
 procedure TForm1.OutlineMouseDown(Sender: TObject; Button: TMouseButton;
 
   Shift: TShiftState; X, Y: Integer);
 begin
 
   if Button = mbLeft then
     with Sender as TOutline do
     begin
       if GetItem(x, y) >= 0 then
         BeginDrag(False);
     end;
 end;
 
 procedure TForm1.OutlineDragOver(Sender, Source: TObject; X, Y: Integer;
 
   State: TDragState; var Accept: Boolean);
 begin
 
   if (Source is TOutline) and (TOutline(Source).GetItem(x, y) <>
     TOutline(Source).SelectedItem) then
 
     Accept := True
   else
     Accept := False;
 
 end;
 
 end.
 
 




Компонет TWrapGrid, осуществляющий перенос текста в TStringGrid

Я наконец нашел время и создал заказной компонент TWrapGrid, функционально идентичный TStringGrid, но умеющий переносить текст в ячейках. Пока это бета-версия, поэтому поэкспериментируйте с ним, и в случае наличия каких-либо замечаний или предложений не забудьте уведомить об этом меня. При использовании компонента не забывайте про RowHeights (или DefaultRowHeight), т.к. при переносе текста потребуется отобразить несколько строк.

Для использования скопируйте код в модуль, сохраните его с именем 'Wrapgrid.PAS' и следуйте за инструкциями, расположенными в верхней части кода.

Присылайте свой комментарии и пожелания. Вот код:


 {  Код заказного компонента для Delphi.
 
 Позволяет переносить текст в TStringGrid, отсюда и его имя - TWrapGrid.
 Автор Luis J. de la Rosa.
 E-mail: delarosa@ix.netcom.com
 Вы свободны в использовании, распространении и улучшении кода.
 
 Для использования:  Выберите в Delphi пункты меню 'Options' - 'Install Components'.
 Нажмите 'Add'.
 Найдите и выберите файл с именем 'Wrapgrid.PAS'.
 Нажмите 'OK'.
 После этого вы увидете компонент во вкладке "Samples" палитры компонентов
 Delphi.
 После этого вы можете использовать компонент вместо стандартного TStringGrid.
 
 Пожалуйста шлите любые комментарии и пожелания на адрес delarosa@ix.netcom.com.
 Успехов!
 
 Несколько дополнительных замечаний по коду:
 Методы Create и DrawCell были перекрыты. Everything else should
 behave just like a TStringGrid.
 The Create sets the DefaultDrawing to False, so you don't need to.
 
 Also, I am using the pure block emulation style of programming, making my
 code easier to read.
 }
 
 unit Wrapgrid;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, Grids;
 
 type
 
   TWrapGrid = class(TStringGrid)
   private
     { Private declarations }
   protected
     { Protected declarations }
     { Процедура DrawCell осуществляет перенос текста в ячейке }
     procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
       AState: TGridDrawState); override;
   public
     { Public declarations }
     { Процедура Create перекрывается для того, чтобы использовать процедуру DrawCell
     по умолчанию }
     constructor Create(AOwner: TComponent); override;
   published
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 constructor TWrapGrid.Create(AOwner: TComponent);
 begin
 
   { Создаем TStringGrid }
   inherited Create(AOwner);
 
   { Заставляем компонент перерисовываться нашей процедурой по умолчанию DrawCell }
   DefaultDrawing := FALSE;
 end;
 
 { Процедура DrawCell осуществляет перенос текста в ячейке }
 
 procedure TWrapGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
 
   AState: TGridDrawState);
 var
 
   Sentence, { Выводимый текст }
   CurWord: string; { Текущее выводимое слово }
   SpacePos, { Позиция первого пробела }
   CurX, { Х-координата 'курсора' }
   CurY: Integer; { Y-координата 'курсора' }
   EndOfSentence: Boolean; { Величина, указывающая на заполненность ячейки }
 begin
 
   { Инициализируем шрифт, чтобы он был управляющим шрифтом }
   Canvas.Font := Font;
 
   with Canvas do
   begin
     { Если это фиксированная ячейка, тогда используем фиксированный цвет }
     if gdFixed in AState then
     begin
       Pen.Color := FixedColor;
       Brush.Color := FixedColor;
     end
       { в противном случае используем нормальный цвет }
     else
     begin
       Pen.Color := Color;
       Brush.Color := Color;
     end;
 
     { Рисуем подложку цветом ячейки }
     Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
   end;
 
   { Начинаем рисование с верхнего левого угла ячейки }
   CurX := ARect.Left;
   CurY := ARect.Top;
 
   { Здесь мы получаем содержание ячейки }
   Sentence := Cells[ACol, ARow];
 
   { для каждого слова ячейки }
   EndOfSentence := FALSE;
   while (not EndOfSentence) do
   begin
     { для получения следующего слова ищем пробел }
     SpacePos := Pos(' ', Sentence);
     if SpacePos > 0 then
     begin
       { получаем текущее слово плюс пробел }
       CurWord := Copy(Sentence, 0, SpacePos);
 
       { получаем остальную часть предложения }
       Sentence := Copy(Sentence, SpacePos + 1, Length(Sentence) - SpacePos);
     end
     else
     begin
       { это - последнее слово в предложении }
       EndOfSentence := TRUE;
       CurWord := Sentence;
     end;
 
     with Canvas do
     begin
       { если текст выходит за границы ячейки }
       if (TextWidth(CurWord) + CurX) > ARect.Right then
       begin
         { переносим на следующую строку }
         CurY := CurY + TextHeight(CurWord);
         CurX := ARect.Left;
       end;
 
       { выводим слово }
       TextOut(CurX, CurY, CurWord);
       { увеличиваем X-координату курсора }
       CurX := CurX + TextWidth(CurWord);
     end;
   end;
 end;
 
 procedure Register;
 begin
 
   { Вы можете изменить закладку Samples на любую другую
   палитре компонентов Delphi }
   RegisterComponents('Samples', [TWrapGrid]);
 end;
 
 end.
 




Пример TWriter и TReader

Вот что вы должны cделать для того, чтобы с помощью TWriter/TReader записать строку в поток. До сих пор для простоты я использую TMemoryStream.

Ключевыми являются вызовы Read/WriteListBegin и Read/WriteListEnd. Без них вы получите исключение.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   sWrite, sRead: string[25];
 
   MyStream: TMemoryStream;
   MyWriter: TWriter;
   MyReader: TReader;
 begin
 
   MyStream := TMemoryStream.Create;
   MyStream.SetSize(4096);
   MyWriter := TWriter.Create(MyStream, 4096);
   sWrite := 'sWriteContents';
 
   MyWriter.WriteListBegin;
   MyWriter.WriteString(sWrite);
   MyWriter.WriteListEnd;
   MyWriter.free;
 
   MyStream.Seek(0, 0);
 
   MyReader := TReader.Create(MyStream, 4096);
   MyReader.ReadListBegin;
   sRead := MyReader.ReadString;
   MyReader.ReadListEnd;
   MyReader.free;
 
   Label1.Caption := sRead;
   MyStream.free;
 end;
 




Типизированные константы

Чтобы инициализировать переменную на стадии ее создания, нужно объявить ее, как типизированную константу. Таким способом можно инициализировать переменные простых типов, а также записи, массивы, множества.

Пример:


 procedure TForm1.FormCreate(Sender: TObject);
 const
   a: integer = 0;
   p: TPoint = (x: 10; y: 20);
   BoolStr: array [boolean] of string = ('false', 'true');
   figures: set of char = ['0'..'9'];
 begin
   p := Form1.ClientToScreen(p);
   SetCursorPos(p.x, p.y);
   Form1.Caption := BoolStr[GetKeyState(VK_NUMLOCK) and 1 > 0];
 end;
 




Как запрограммировать Undo

Встречаются два программиста - один идет веселый, пьет пиво, а второй - грустный, но с коляской. Первый:
- Ты чего такой? Жизнь прекрасна!
Второй (указывая на коляску):
- Да вот!.. Ни Uninstall, ни Undo не помогли


 Memo1.Perform(EM_UNDO, 0, 0);
 




Универсальный создатель формы

Обратите внимание на методы FindClass/GetClass и RegisterClass. С помощью их вы можете эффективно перевести строку (имя класса формы) в тип класса этой формы, и затем выполнить такую команду:


 MyForm := TForm(FindClass(SomeString)).Create(Self);
 




Unix-строки (чтение и запись Unix-файлов)

Противоламерская Оборона, имею медаль"За защиту UNIX'а от Мелкомягких"

Данный модуль позволяет читать и записывать файлы формата Unix.


 unit StreamFile;
 
 interface
 
 uses
   SysUtils;
 
 procedure AssignStreamFile(var F: Text; Filename: string);
 
 implementation
 
 const
   BufferSize = 128;
 
 type
   TStreamBuffer = array[1..High(Integer)] of Char;
   TStreamBufferPointer = ^TStreamBuffer;
 
   TStreamFileRecord = record
     case Integer of
       1:
       (
         Filehandle: Integer;
         Buffer: TStreamBufferPointer;
         BufferOffset: Integer;
         ReadCount: Integer;
         );
       2:
       (
         Dummy: array[1..32] of Char
         )
   end;
 
 function StreamFileOpen(var F: TTextRec): Integer;
 
 var
   Status: Integer;
 begin
   with TStreamFileRecord(F.UserData) do
   begin
     GetMem(Buffer, BufferSize);
     case F.Mode of
       fmInput:
         FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone);
       fmOutput:
         FileHandle := FileCreate(StrPas(F.Name));
       fmInOut:
         begin
           FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone or
             fmOpenWrite or fmOpenRead);
 
           if FileHandle <> -1 then
             status := FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }
           F.Mode := fmOutput;
         end;
     end;
     BufferOffset := 0;
     ReadCount := 0;
     F.BufEnd := 0;
       { В этом месте подразумеваем что мы достигли конца файла (eof). }
     if FileHandle = -1 then
       Result := -1
     else
       Result := 0;
   end;
 end;
 
 function StreamFileInOut(var F: TTextRec): Integer;
 
   procedure Read(var Data: TStreamFileRecord);
     procedure CopyData;
     begin
       while (F.BufEnd < Sizeof(F.Buffer) - 2)
         and (Data.BufferOffset <= Data.ReadCount)
         and (Data.Buffer[Data.BufferOffset] <> #10) do
       begin
         F.Buffer[F.BufEnd] := Data.Buffer^[Data.BufferOffset];
         Inc(Data.BufferOffset);
         Inc(F.BufEnd);
       end;
       if Data.Buffer[Data.BufferOffset] = #10 then
       begin
         F.Buffer[F.BufEnd] := #13;
         Inc(F.BufEnd);
         F.Buffer[F.BufEnd] := #10;
         Inc(F.BufEnd);
         Inc(Data.BufferOffset);
       end;
     end;
 
   begin
 
     F.BufEnd := 0;
     F.BufPos := 0;
     F.Buffer := '';
     repeat
       begin
         if (Data.ReadCount = 0) or (Data.BufferOffset > Data.ReadCount) then
         begin
           Data.BufferOffset := 1;
           Data.ReadCount := FileRead(Data.FileHandle, Data.Buffer^, BufferSize);
         end;
         CopyData;
     end until (Data.ReadCount = 0)
     or (F.BufEnd >= Sizeof(F.Buffer) - 2);
     Result := 0;
   end;
 
   procedure Write(var Data: TStreamFileRecord);
   var
     Status: Integer;
     Destination: Integer;
     II: Integer;
   begin
     with TStreamFileRecord(F.UserData) do
     begin
       Destination := 0;
       for II := 0 to F.BufPos - 1 do
       begin
         if F.Buffer[II] <> #13 then
         begin
           Inc(Destination);
           Buffer^[Destination] := F.Buffer[II];
         end;
       end;
       Status := FileWrite(FileHandle, Buffer^, Destination);
       F.BufPos := 0;
       Result := 0;
     end;
   end;
 begin
   case F.Mode of
     fmInput:
       Read(TStreamFileRecord(F.UserData));
     fmOutput:
       Write(TStreamFileRecord(F.UserData));
   end;
 end;
 
 function StreamFileFlush(var F: TTextRec): Integer;
 
 begin
   Result := 0;
 end;
 
 function StreamFileClose(var F: TTextRec): Integer;
 
 begin
   with TStreamFileRecord(F.UserData) do
   begin
     FreeMem(Buffer);
     FileClose(FileHandle);
   end;
   Result := 0;
 end;
 
 procedure AssignStreamFile(var F: Text; Filename: string);
 
 begin
   with TTextRec(F) do
   begin
     Mode := fmClosed;
     BufPtr := @Buffer;
     BufSize := Sizeof(Buffer);
     OpenFunc := @StreamFileOpen;
     InOutFunc := @StreamFileInOut;
     FlushFunc := @StreamFileFlush;
     CloseFunc := @StreamFileClose;
     StrPLCopy(Name, FileName, Sizeof(Name) - 1);
   end;
 end;
 
 end.
 




Создаём собственный UnRar, используя unrar.dll

Едут в переполненном автобусе качок, каратист и программист. Измученный толкотней качок предлагает:
- Давайте, ребята, поднажмем и лишний народ вытолкнем.
Каратист не согласен:
- Да, ну, давайте лучше замочим человек пять, а остальные сами разбегутся.
Программист с умным лицом предлагает:
- Зачем мучиться, давайте лучше заархивируем всех и положим на переднее сиденье.


 // Объявления
 
 function RAROpenArchive(ArchiveData : Pointer): Integer; stdcall;
 external 'unrar.dll' name 'RAROpenArchive';
 
 function RARCloseArchive(hArcData : Integer): Integer; stdcall;
 external 'unrar.dll' name 'RARCloseArchive';
 
 function RARReadHeader(hArcData : Integer; HeaderData : Pointer):
 Integer; stdcall;
 external 'unrar.dll' name 'RARReadHeader';
 
 function RARProcessFile(hArcData : Integer; Operation : Integer;
 DestPath : Pointer; DestName : Pointer): Integer; stdcall;
 external 'unrar.dll' name 'RARProcessFile';
 
 
 const
   ERAR_END_ARCHIVE = 10;
   ERAR_NO_MEMORY = 11;
   ERAR_BAD_DATA = 12;
   ERAR_BAD_ARCHIVE = 13;
   ERAR_UNKNOWN_FORMAT = 14;
   ERAR_EOPEN = 15;
   ERAR_ECREATE = 16;
   ERAR_ECLOSE = 17;
   ERAR_EREAD = 18;
   ERAR_EWRITE = 19;
   ERAR_SMALL_BUF = 20;
 
   RAR_OM_LIST = 0;
   RAR_OM_EXTRACT = 1;
   RAR_SKIP = 0;
   RAR_TEST = 1;
   RAR_EXTRACT = 2;
   RAR_VOL_ASK = 0;
   RAR_VOL_NOTIFY = 1;
 
 type
   Char260 = array [1..260] of Char;
 
   TRAROpenArchiveData = record
     ArcName : PChar; // в C++ это будет выглядеть как: char *ArcName
     OpenMode : Cardinal;
     OpenResult : Cardinal;
     CmtBuf : PChar;
     CmtBufSize : Cardinal;
     CmtSize : Cardinal;
     CmtState : Cardinal;
   end;
 
   TRARHeaderData = record
     ArcName : Char260;
     FileName : Char260;
     Flags : Cardinal;
     PackSize : Cardinal;
     UnpSize : Cardinal;
     HostOS : Cardinal;
     FileCRC : Cardinal;
     FileTime : Cardinal;
     UnpVer : Cardinal;
     Method : Cardinal;
     FileAttr : Cardinal;
     CmtBuf : PChar;
     CmtBufSize : Cardinal;
     CmtSize : Cardinal;
     CmtState : Cardinal;
   end;
 
 
 var
   RARExtract : boolean;
   RAROpenArchiveData : TRAROpenArchiveData;
   RARComment : array [1..256] of Char;
   RARHeaderData : TRARHeaderData;
 
 ...
 
 procedure ExtractRARArchive;
 var
   sDir : string;
   s : string;
   sTest : string;
   iTest : integer;
   bTestDone : boolean;
   RARhnd : Integer;
   RARrc : Integer;
   PDestPath : Char260;
 begin
   RARExtract:=TRUE;
   lKBWritten:=0;
   ProgressBar2.Position := 0;
   ProgressBar2.Max := lTotalSize;
   RARStartTime:=Time;
 
   RAROpenArchiveData.OpenResult:=99;
   RAROpenArchiveData.OpenMode := RAR_OM_EXTRACT; // открываем для распаковки
   RAROpenArchiveData.ArcName:= @RARFileName;
   RAROpenArchiveData.CmtBuf := @RARComment;
   RAROpenArchiveData.CmtBufSize := 255;
 
   // Открываем RAR архив и выделяем память
   RARhnd := RAROpenArchive (@RAROpenArchiveData);
   if RAROpenArchiveData.OpenResult <> 0 then
   begin
     case RAROpenArchiveData.OpenResult of
       ERAR_NO_MEMORY   : s:='Not enough memory to initialize data structures';
       ERAR_BAD_DATA    : s:='Archive header broken';
       ERAR_BAD_ARCHIVE : s:='File is not valid RAR archive';
       ERAR_EOPEN       : s:='File open error';
     end;
     MessageDlg('Unable to open rar archive: ' + s + '!',mtError, [mbOK], 0);
   end;
 
   RARSetProcessDataProc(RARhnd,@Form.OnRarStatus);
   StrPCopy(@PDestPath, EInstallPath.Text);
 
   repeat
     RARrc := RARReadHeader (RARhnd, @RARHeaderData);// Читаем заголовок
     if RARrc <> ERAR_END_ARCHIVE then
     begin
       ProgressBar1.Position := 0;
       ProgressBar1.Max := RARHeaderData.UnpSize;
       s:=RARHeaderData.FileName;
       lblCurrentFile.Caption := s;
       lKBytesDone := 0;
     end;
 
     if RARrc = 0 then
       RARrc:=RARProcessFile (RARhnd, RAR_EXTRACT, @PDestPath, nil);
     if (RARrc <> 0) and (RARrc <> ERAR_END_ARCHIVE) then
     begin
       MessageDlg('An Error occured during extracting of ' + sTest+'!' + #13#10 +
       'RARProcessFile: ' + MakeItAString(RARrc),mtError, [mbOK], 0);
     end;
   until
     RARrc <> 0;
 
   // закрываем RAR архив и освобождаем память
   if RARCloseArchive(RARhnd) <> 0 then
   begin
     MessageDlg('Unable to close rar archive!',mtError, [mbOK], 0);
   end;
 end;
 




Как избавиться от зарегистрированного имени сервера

Автор: Nomadic

Запустите исполняемый файл сервера с ключом /UNREGSERVER:

MYSERVER.EXE /UNREGSERVER

Это обычный путь разрегистрации саморегистрирующегося сервера автоматизации OLE.




Как сделать, чтобы первая буква каждого слова в строке была в верхнем регистре

Вчера хакерам удалось взломать програмное обеспечение новой российской ракеты "Tополь". Получив root, они заменили заглавную букву в названии на "Ж".


 function LowCase(ch: CHAR): CHAR;
 begin
   case ch of
     'A'..'Z': LowCase := CHR(ORD(ch) + 31);
   else
     LowCase := ch;
   end;
 end;
 
 function Proper(source, separators: string): string;
 var
   LastWasSeparator: BOOLEAN;
   ndx: INTEGER;
 begin
   LastWasSeparator := TRUE;
   ndx := 1;
   while (ndx <= Length(source)) do
   begin
     if LastWasSeparator then
       source[ndx] := UpCase(source[ndx])
     else
       source[ndx] := LowCase(source[ndx]);
     LastWasSeparator := Pos(source[ndx], separators) > 0;
     inc(ndx);
   end;
   Result := source;
 end;
 

Можно так:


 function TfrmLoadProtocolTable.ToMixCase(InString: string): string;
 var
   I: Integer;
 begin
   Result := LowerCase(InString);
   Result[1] := UpCase(Result[1]);
   for I := 1 to Length(InString) - 1 do
   begin
     if (Result[I] = ' ') or (Result[I] = '''') or (Result[I] = '"')
       or (Result[I] = '-') or (Result[I] = '.') or (Result[I] = '(') then
       Result[I + 1] := UpCase(Result[I + 1]);
   end;
 end;
 

Примечание:

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

Попробуйте взамен это:


 function proper(s: string): string;
 var
   t: string;
   i: integer;
   newWord: boolean;
 begin
   if s = '' then
     exit;
   s := lowercase(s);
   t := uppercase(s);
   newWord := true;
   for i := 1 to length(s) do
   begin
     if newWord and (s[i] in ['a'..'z']) then
     begin
       s[i] := t[i];
       newWord := false;
       continue;
     end;
     if s[i] in ['a'..'z', ''''] then
       continue;
     newWord := true;
   end;
   result := s;
 end;
 




Перевод символа в верхний регистр для русского алфавита


 function UpCaseRus(ch: Char): Char;
 asm
   CMP   AL,'a'
   JB    @@exit
   CMP   AL,'z'
   JA    @@Rus
   SUB   AL,'a' - 'A'
   RET
 @@Rus:
   CMP   AL,'я'
   JA    @@Exit
   CMP   AL,'а'
   JB    @@yo
   SUB   AL,'я' - 'Я'
   RET
 @@yo:
   CMP   AL,'¸'
   JNE   @@exit
   MOV   AL,'¨'
 @@exit:
 end;
 


 function LoCaseRus( ch : Char ) : Char;
 {Перевод символа в нижний регистр для русского алфавита}
 asm
   CMP          AL,'A'
   JB              @@exit
   CMP          AL,'Z'
   JA              @@Rus
   ADD          AL,'a' - 'A'
   RET
 @@Rus:
   CMP          AL,'Я'
   JA              @@Exit
   CMP          AL,'А'
   JB              @@yo
   ADD          AL,'я' - 'Я'
   RET
 @@yo:
   CMP          AL,'¨'
   JNE            @@exit
   MOV          AL,'¸'
 @@exit:
 end;
 




Внести изменения в набор данных и не потерять текушей позиции


 procedure TMyForm.MakeChanges;
 var
   aBookmark: TBookmark;
 begin
   Table1.DisableControls;
   aBookmark := Table.GetBookmark;
   try
     {ваш код}
   finally
     Table1.GotoBookmark(aBookmark);
     Table1.FreeBookmark(aBookmark);
     Table1.EnableControls;
   end;
 end;
 




Обработка нажатий клавиш вверх-вниз

Автор: Галимарзанов Фанис

- Захотел ты беcпредел? Так нажми контрол+алт+дел!

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


 procedure TfmAbProps.edNameKeyDown(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 begin
   if (Key = vk_down) and
     not (ssAlt in Shift)
       {// здесь обработка для "выпадающих" окошек типа TRxDBCalcEdit} then
   begin
     Key := 0;
     SelectNext(Sender as TWinControl, true, true);
   end
   else if Key = vk_up then
   begin
     Key := 0;
     SelectNext(Sender as TWinControl, false, true);
   end;
 end;
 

Для элементов редактирования типа TDbEdit, TRxDBCalcEdit or TDBDateEdit назначим


 OnKeyDown:=edNameKeyDown
 

Сложнее с типами вроде TRxDBLookupCombo. Наш прежний обработчик для них не подходит. Я пытался изменить характер TRxDBLookupCombo - но вовремя опомнился - есть же FormKeyDown;


 procedure TfmAbProps.FormKeyDown(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 begin
   if (ActiveControl is TRxDBLookupCombo) then
   begin
     if Key = vk_down then
     begin
       if not (ssAlt in Shift) and not
         // здесь нельзя обработать нажатие при вызове "выпадающего"
       (ActiveControl as TRxDBLookupCombo).IsDropDown then
       begin // и в случае уже "выпвшего"
         Key := 0;
         selectnext(ActiveControl, true, true);
       end;
     end
     else if Key = vk_up then
     begin
       if not (ActiveControl as TRxDBLookupCombo).IsDropDown then
       begin
         Key := 0;
         selectnext(ActiveControl, false, true);
       end;
     end;
   end;
 end;
 




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

Strs : Тоже самое, что и Str (для integer/longint), но в более функциональной форме, что позволяет сделать преобразование числа в строку более простым.

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

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

FP : данная функция создана для работы в стиле условной строки "C", которая возвращает результат в виде другой строки, основываясь на результатах логического выражения. (я мог бы осуществить поддержку различных типов данных, но не посчитал это особо актуальным для формирования выходной строки).


 Function Strs (I:longint) : string ;
 Var
   X : string[16] ;
 begin
   STR (I,X) ;
   Strs := X ;
 end ;
 

Пример:


 s :='пользователь=Вася';
 Text := After ('=',s);
 Text := Text+fp(Text<>'',' есть #Неизвестный ') + Before ('=',s);
 

Text будет содержать 'Вася есть пользователь'
Если s содержало бы только 'пользователь' или 'пользователь=' то Text был бы 'Неизвестный пользователь'


 Function Before ( Src:string ; Var S:string ) : string ;
 Var
   F : Word ;
 begin
   F := POS (Src,S) ;
   if F=0 then
     Before := S
   else
     Before := COPY(S,1,F-1) ;
 end ;
 


 Function After ( Src:string ; Var S:string ) : string ;
 Var
   F : Word ;
 begin
   F := POS (Src,S) ;
   if F=0 then
     After := ''
   else
     After := COPY(S,F+length(src),length(s)) ;
 end ;
 

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

Пример 1:


 MyText := strs(N)+' компьютер'+FP (N>1,'ы') ;
 

Пример 2:


 if Nargs<>4 then
   Msg :='Имеется '+FP(Nargs>4,'много#несколько')+' аргументов.');
 


 const
   MY_SEP : Char = '#';
 
 Function FP ( B : Boolean ; S:string ) : string ;
 begin
   if POS (MY_SEP,S)>0 then
     if B then
       S := Before (MY_SEP,S)
     else
       S := After (MY_SEP,S)
   else
   if not B then
     S := '' ;
   FP := S ;
 end ;
 




Uses в DLL

...синтаксис для DLL должен быть немного другим. Вот как нужно правильно делать:

Вам необходимо, по крайней мере, два файла -- библиотечный файл и файл с исходным кодом:

Библиотечный файл: mylib.dpr


 library MyLib;
 
 uses
 MyCode in 'MYCODE.PAS';
 
 exports
 MyFunc index 1;
 
 begin
 end.
 

Файл с исходным кодом: mycode.pas


 unit MyCode;
 
 interface
 
 function MyFunc( MyParam: string ): string; export;
 
 implementation
 
 function MyFunc( MyParam: string ): string;
 
 begin
 Result := 'Это просто пример!';
 end;
 
 end.
 

Совет написан по мотивам книги Delphi Developer's Guide, изданной издательством Borland Press/Sams Publishing.




Использование таблиц Access

Может кто-нибудь, предпочтительно из персонала Borland, ПОЖАЛУЙСТА, дать мне ПОЛНЫЙ рассказ о том, как с помощью Delphi и сопутствующего программного обеспечения получить доступ и работать с базами данных MS Access. Среди прочего, мне необходимо узнать...

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

Драйвер ODBC, предусмотренный для доступа к Access 2.0, разработан только для работы в пределах среды Microsoft Office. Для работы со связкой ODBC/Access в Delphi, вам необходим Microsoft ODBC Desktop Driver kit, part# 273-054-030, доступный через Microsoft Direct за $10.25US (если вы живете не в США, воспользуйтесь службой WINEXT). Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Имейте в виду, что смена драйверов (в частности Desktop Drivers) может негативно сказаться на работе других приложений Microsoft. Для информации (и замечаний) обращайтесь в форум WINEXT.

Также вам необходимы следующие файлы ODBC:

  Минимум:
   ODBC.DLL       03.10.1994, Версия 2.00.1510
   ODBCINST.DLL   03.10.1994, Версия 2.00.1510
   ODBCINST.HLP   11.08.1993
   ODBCADM.EXE    11.08.1993, Версия 1.02.3129
 
  Рекомендуется:
   ODBC.DLL       12.07.1994, Версия 2.10.2401
   ODBCINST.DLL   12.07.1994, Версия 2.10.2401
   ODBCINST.HLP   12.07.1994
   ODBCADM.EXE    12.07.1994, Версия 2.10.2309
 
 
Нижеследующие шаги приведут вас к искомой цели:

  1. Используя администратора ODBC, установите источник данных (datasource) для вашей базы данных. Не забудьте задать путь к вашему mdb-файлу. Для нашего примера создайте источник с именем MYDSN.
  2. Загрузите утилиту BDE Configuration.
  3. Выберите пункт "New Driver".
  4. Назначьте драйверу имя (в нашем случае ODBC_MYDSN).
  5. В выпадающем списке драйверов выберите "Microsoft Access Driver (*.mdb)
  6. В выпадающем списке имен выберите MYDSN
  7. Перейдите на страницу "Alias" (псевдонимы).
  8. Выберите "New Alias" (новый псевдоним).
  9. Введите MYDSN в поле имени.
  10. Для Alias Type (тип псевдонима) выберите ODBC_MYDSN.
  11. На форме Delphi разместите компоненты DataSource, Table, и DBGrid.
  12. Установите DBGrid1.DataSource на DataSource1.
  13. Установите DataSource1.DataSet на Table1.
  14. Установите Table1.DatabaseName на MYDSN.
  15. В свойстве TableName компонента Table1 щелкните на стрелочку "вниз" и вы увидите диалог "Login". Нажмите OK и после короткой паузы вы увидите список всех имен ваших таблиц. Выберите одно.
  16. Установите свойство Active Table1 в True и данные вашей таблицы появятся в табличной сетке.



Использование таблиц Access2

Автор: Ralph Friedman

Можно ли как-то в Delphi работать с файлами Microsoft Access? Я слышал что некоторые программисты пробовали, но у них ничего не получилось.

Из приложений Delphi вы можете получить доступ к .MDB-файлам Microsoft Access, используя драйверы ODBC. Delphi действительно может дать все необходимое, но некоторые вещи не столь очевидные. Вот шаги для достижения вашей цели.

Что вам нужно: Первое: проверьте, установлен ли ODBC Administrator (файл ODBCADM.EXE в WINDOWS\SYSTEM, вам также необходим файл DBCINST.DLL для установки новых драйверов и ODBC.DLL). Администратор ODBC должен присутствовать в Панели Управления в виде иконки ODBC. Если у вас его не было, то после установки Delphi он должен появиться. Если вы получаете сообщение типа "Your ODBC is not up-to-date IDAPI needs ODBC greater then 2.0", у вас имеется старая версия администратора и вы должны обновить ее до версии, включенной в поставку Delphi. Проверьте, имеете ли вы доступ к драйверу Access ODBC, установленному в Windows. Вы можете сделать это, щелкнув на "Drivers" в диалоговом окне "Data Sources", появляющемся при запуске ODBC Administrator. Delphi должна в диалоге добавить пункты Access Files (*.mdb) и Access Data (*.mdb), работающие с файлами Access 1.10 и использующие драйвер SIMBA.DLL (имейте в виду, что для данного DLL необходимы также файлы RED110.DLL и SIMADMIN.DLL, устанавливаемые для вас Delphi). Данные файлы должны поставляться с дистрибутивом вашей программы как часть ReportSmith Runtime библиотеки. Если вы хотите работать с файлами Access 2.0 или 2.5, вам необходимо иметь другой набор драйверов от Microsoft. Ключевой файл - MSAJT200.DLL, также необходимы файлы MSJETERR.DLL и MSJETINT.DLL. В США набор ODBC Desktop Drivers, Version 2.0. стоит $10.25. Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Очевидно есть обновление этих драйверов для файлов Access 2.5 на форуме MSACCESS CompuServe. Имейте в виду, что драйвер Access ODBC, поставляемый с некоторыми приложениями Microsoft (например, MS Office) могут использоваться только другими MS-приложениями. К сожалению, они могут сыграть с вами злую шутку: сначала заработать, а потом отказать в совершенно неподходящий момент! Поэтому не обращайте внимания (запретите себе обращать внимание!) на строчку "Access 2.0 for MS Office (*.mdb)" в списке драйверов ODBC Administrator. Вы можете установить новые ODBC драйверы с помощью ODBC Administrator в Панели Управления.

Добавление источника данных ODBC (Data Source): если у вас имеются все необходимые файлы, можете начинать. Представленный здесь пример использует драйвер Access 1.10, обеспечиваемый Delphi. Используя ODBC Administrator, установите источник данных для ваших файлов Access: щелчок на кнопке "Add" в окне "data sources" выведет диалог "Add Data Source", выберите Access Files (*.mdb) (или что-либо подходящее, в зависимости от установленных драйверов). В диалоге "ODBC Microsoft Access Setup" необходимо ввести имя в поле "Data Source Name". В данном примере мы используем "My Test". Введите описание "Data Source" в поле Description. Щелкните на "Select Database" для открытия диалога "Select Database". Перейдите в директорию, где хранятся ваши Access .MDB-файлы и выберите один. Мы выберем файл TEST.MDB в директории C:\DELPROJ\ACCESS. Нажмите OK в диалоге "Setup". Теперь в списке источников данных (Data Sources) должен появиться "My Test" (Access Files *.mdb). Нажмите Close для выхода из ODBC Administrator. Используя этот метод, вы можете установить и другие, необходимые вам, источники данных.

Настройка Borland Database Engine: загрузите теперь Borland Database Engine (BDE) Configuration Utility. На странице "Drivers" щелкните на кнопке New ODBC Driver. Имейте в виду, что это добавит драйвер Access в BDE и полностью отдельное управление дополнительно к драйверам Access в Windows, устанавливаемым при помощи ODBC Administrator. В открывшемся диалоге Add ODBC Driver в верхнем поле редактировании введите ACCESS (или что-то типа этого). BDE автоматически добавит на первое место ODBC_. В combobox, расположенном немного ниже, выберите Access Files (*.mdb). Выберите Data Source в следующем combobox (Default Data Source Name), это должен быть источник данных, который вы установили с помощью ODBC Administration Utility. Здесь можно не беспокоиться о вашем выборе, поскольку позднее это можно изменить (позже вы узнаете как это можно сделать). Нажмите OK. После установки драйвера BDE, вы можете использовать его более чем с одним источником данных ODBC, применяя различные псевдонимы (Alias) для каждого ODBC Data Source. Для установки псевдонима переключитесь на страницу "Aliases" и нажмите на кнопку "New Alias". В диалоговом окне "Add New Alias" введите необходимое имя псевдонима в поле "Alias Name". В нашем примере мы используем MY_TEST (не забывайте, что пробелы в псевдониме недопустимы). В combobox Alias Type выберите имя ODBC-драйвера, который вы только что создали (в нашем случае ODBC_ACCESS). Нажмите OK. Если вы имеете более одного ODBC Data Source, измените параметр ODBC DSN ("DSN" = "Data Source Name") в списке "Parameters" псевдонима на подходящий источник данных ODBC Data Source, как установлено в ODBC Administrator. Имейте в виду, что вы не должны ничего добавлять в параметр Path (путь), так как ODBC Data Source уже имеет эту информацию. Если вы добавляете параметр Path, убедитесь, что путь правильный, в противном случае ничего работать не будет! Теперь сохраните конфигурацию BDE, выбирая пункты меню File|Save, и выходите из Database Engine Configuration Utility.

В Delphi: Создайте новый проект и расположите на форме компоненты Table и DataSource из вкладки Data Access палитры компонентов. Затем из вкладки Data Controls выберите компонент DBGrid и также расположите его на форме. В Table, в Инспекторе Объектов, назначьте свойству DatabaseName псевдоним MY_TEST, установленный нами в BDE Configuration Utility. Теперь спуститесь ниже и раскройте список TableName. Вас попросят зарегистрироваться в базе данных Access MY_TEST. Обратите внимание, что если бюджет не установлен, то User Name и Password можно не заполнять, просто нажмите на кнопку OK. После некоторой паузы раскроется список, содержащий доступные таблицы для ODBC Data Source указанного псевдонима BDE. Выберите TEST. В DataSource, в Инспекторе Объектов, назначьте свойству DataSet таблицу Table1. В DBGrid, также в Инспекторе Объектов, назначьте свойству DataSource значение DataSource1. Возвратитесь к таблице, и в том же Инспекторе Объектов установите свойство Active в True. Данные из таблицы TEST отобразятся в табличной сетке. Это все! Одну вещь все-таки стоит упомянуть: если вы создаете приложение, использующее таблицы Access и запускаете его из-под Delphi IDE, то при попытке изменения данных в таблице(ах) вы получите ошибку. Если же вы запустите скомпилированный .EXE-файл вне Delphi (предварительно Delphi закрыв), то все будет ОК. Сообщения об ошибках ODBC, к несчастью, очень туманные и бывает достаточно трудно понять его источник в вашем приложении, в этом случае проверьте установку ODBC Administrator и BDE Configuration Utility, они также могут помочь понять источник ошибки. Для получения дополнительной информации обратитесь к ODBC 2.0 Programmer's Reference или SDK Guide от Microsoft Press (ISBN 1-55615-658-8, цена в США составляет $24.95). В этом документе вы получите исчерпывающую информацию о возможных ошибках при использовании Access-файлов посредством ODBC. Также здесь вы можете найти рапорты пользователей о найденных ошибках, в том числе и при использовании Delphi. Более того, я выяснил, что большинство описанных проблем возникает при неправильных настройках ODBC, т.е. те шаги, которые я описал выше. Надеюсь, что с развитием технологии доступа к базам данных такие сложности уйдут в прошлое. Кроме того, имейте в виду, что если вам необходимо создать новую таблицу Access 1.10, вы можете воспользоваться Database Desktop, включаемый в поставку Delphi.

Авторы данной технологии Ralph Friedman (CompuServe 100064,3102), Bob Swart и Chris Frizelle.




Использование анимированных курсоров

Автор: Nomadic

- В винде без мышки, чувствуешь себя скалолазом без снаряжения!


 const
   crMyCursor = 1;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // Загружаем курсор. Единственный способ для этого
   Screen.Cursors[crMyCursor] :=
     LoadCursorFromFile('c:\mystuff\mycursor.ani');
 
   // Используем курсор на форме
   Cursor := crMyCursor;
 end;
 




Использование анимированных курсоров 2

Драйвер мыши (MOUSE.DRV) не найден, использовать другой драйвер (RAT.DRV)?

Сперва Вы должны взять хэндл курсора Windows и присвоить его одному из элементов массива Cursors обьекта Screen.

Предопределенные курсоры имеют отрицательный индекс, а определенные пользователем (Вами) курсоры получают положительные индексы.

Ниже пример формы, использующей анимированный курсор:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   h: THandle;
 begin
   h := LoadImage(0,
     'C:\TheWall\Magic.ani',
     IMAGE_CURSOR,
     0,
     0,
     LR_DEFAULTSIZE or
     LR_LOADFROMFILE
     );
   if h = 0 then
     ShowMessage('Cursor not loaded')
   else
   begin
     Screen.Cursors[1] := h;
     Form1.Cursor := 1;
   end;
 end;
 




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



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



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


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