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

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июня!


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

БОЛЬШОЙ FAQ ПО DELPHI



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


 {
   Constants:
 
   CSIDL_DESKTOP
   CSIDL_INTERNET
   CSIDL_PROGRAMS
   CSIDL_CONTROLS
   CSIDL_PRINTERS
   CSIDL_PERSONAL
   CSIDL_FAVORITES
   CSIDL_STARTUP
   CSIDL_RECENT
   CSIDL_SENDTO
   CSIDL_BITBUCKET
   CSIDL_STARTMENU
   CSIDL_DESKTOPDIRECTORY
   CSIDL_DRIVES
   CSIDL_NETWORK
   CSIDL_NETHOOD
   CSIDL_FONTS
   CSIDL_TEMPLATES
   CSIDL_COMMON_STARTMENU
   CSIDL_COMMON_PROGRAMS
   CSIDL_COMMON_STARTUP
   CSIDL_COMMON_DESKTOPDIRECTORY
   CSIDL_APPDATA
   CSIDL_PRINTHOOD
   CSIDL_ALTSTARTUP
   CSIDL_COMMON_ALTSTARTUP
   CSIDL_COMMON_FAVORITES
   CSIDL_INTERNET_CACHE
   CSIDL_COOKIES
   CSIDL_HISTORY
 }
 
 uses
   ActiveX, ShlObj;
 
 procedure TForm1.Button1Click(Sender: TObject);
   // Replace CSIDL_HISTORY with the constants above 
 var
   Allocator: IMalloc;
   SpecialDir: PItemIdList;
   FBuf: array[0..MAX_PATH] of Char;
   PerDir: string;
 begin
   if SHGetMalloc(Allocator) = NOERROR then
   begin
     SHGetSpecialFolderLocation(Form1.Handle, CSIDL_HISTORY, SpecialDir);
     SHGetPathFromIDList(SpecialDir, @FBuf[0]);
     Allocator.Free(SpecialDir);
     ShowMessage(string(FBuf));
   end;
 end;
 
 // With Windows Me/2000, the SHGetSpecialFolderLocation function 
 // is superseded by ShGetFolderLocation. 
 
 
 // function to get the desktop folder location: 
 
 function GetDeskTopPath : string;
 var
   shellMalloc: IMalloc;
   ppidl: PItemIdList;
   PerDir: string;
 begin
   ppidl := nil;
   try
     if SHGetMalloc(shellMalloc) = NOERROR then
     begin
       SHGetSpecialFolderLocation(Form1.Handle, CSIDL_DESKTOP, ppidl);
       SetLength(Result, MAX_PATH);
       if not SHGetPathFromIDList(ppidl, PChar(Result)) then
         raise exception.create('SHGetPathFromIDList failed : invalid pidl');
       SetLength(Result, lStrLen(PChar(Result)));
     end;
   finally
    if ppidl <> nil then
          shellMalloc.free(ppidl);
   end;
 end;
 




Как программно щелкнуть по компоненту SpeedButton

Разработали новый процессор на женской логике, обрабатывающий четыре логических значения: "Ни да, ни нет", "И да, и нет", "Три раза нет!" и "Нет, и не проси!!!"

Я пытался использовать SendMessage но у Speedbuttons нет "handle"... ;-(

В примере используется метод Perform класса TControl для отправки сообщения.


 procedure TForm1.SpeedButton1Click(Sender: TObject);
 begin
   ShowMessage('Delphi World is the BEST');
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
   SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
 end;
 




Скорость работы процессора, точный таймер

Автор: ISV

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

Данная тема уже обсуждалась, но у меня есть своя реализация сабжа. Начиная с Pentium MMX, Intel ввели в процессор счетчик тактов на 64 бита (Присутствуэт точно и в К6). Для того чтобы посотреть на его содержание, была введена команда "rdtsc" (подробное описание в интеловской мануале). Эту возможность можно использовать для реализации сабжа. Посоку Делфя не вкурсе насчет rdtsc, то пришлось юзать опкод (0F31). Привожу простенький примерчик юзания, Вы уж извините - немножко кривоват получился, да и ошибка компалера какая-то вылезла :( (V4 Bld5.104 Upd 2). Кому интересно, поделитесь своими соображениями по этому поводу. Особенно интерисует работа в режиме когда меняется частота процессора (Duty Cycle, StandBy).

Проверялось под еНТями на Пне 2 333.


 // (C) 1999 ISV
 unit Unit1;
 
 interface
 
 uses
 Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms,Dialogs,  StdCtrls, Buttons, ExtCtrls;
 
 type  TForm1 = class(TForm)
     Label1: TLabel;
     Timer1: TTimer;
     Label2: TLabel;
     Label3: TLabel;
     Button1: TButton;
     Button2: TButton;
     Label4: TLabel;
     procedure Timer1Timer(Sender: TObject);
     procedure FormActivate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
 { Private declarations }
   public
 { Public declarations }
     Counter:integer;
       //Счетчик срабатывания таймера    
 Start:int64;
 //Начало роботы    
 Previous:int64;
 //Предыдущее значение    
 PStart,PStop:int64;
  //Для примера выч. времени   
  CurRate:integer;
      //Текущая частота проца    
 function GetCPUClick:int64;
 function GetTime(Start,Stop:int64):double;
  end;
 var  Form1: TForm1;implementation{$R *.DFM}
 // Функция работает на пнях ММХ или выше а
 // также проверялась на К6
 function TForm1.GetCPUClick:int64;
 begin
   asm    db  0fh,31h
 // Опкод для команды rdtsc
 // mov dword ptr result,eax
 // mov dword ptr result[4],edx
 end;
 // Не смешно :(. Без ?той штуки
 // Компайлер выдает Internal error C1079  
 Result:=Result;
 end;
 // Время в секундах между старт и стоп
 function TForm1.GetTime(Start,Stop:int64):double;
 begin
   try    result:=(Stop-Start)/CurRate  except    result:=0;
  end;
 end;
 // Обработчик таймера считает текущую частоту, выводит ее, а также
 // усредненную частоту, текущий такт с момента старта процессора.
 // При постоянной частоте процессора желательно интервал братьпобольше
 // 1-5с для точного прощета частоты процессора.
 procedure TForm1.Timer1Timer(Sender: TObject);
   var    i:int64;
 begin
   i:=GetCPUClick;
   if Counter=0    then Start:=i    else
 begin
       Label2.Caption:=Format('Частота общая:%2f',
        [(i-Start)/(Counter*Timer1.Interval*1000)]);
       Label3.Caption:=Format('Частота текущая:%2f',
        [(i-Previous)/(Timer1.Interval*1000)]);
       CurRate:=Round(((i-Previous)*1000)/(Timer1.Interval));
     end;
   Label1.Cap примера
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   PStart:=GetCPUClick;
 end;
 // Останавливаем отсчет времени и показуем соко
 // прошло секунд
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   PStop:=GetCPUClick;
   Label4.Caption:=Format!
 ('Время между нажатиями:%gсек',[GetTime(PStart,PStop)])
 end;
 end.
 




Великолепный метод Perform

Автор: Михаил Христосенко
WEB сайт: http://mihandelphi.narod.ru

В этой статье я постараюсь показать что можно делать с помощью метода Perform, и какие интересные вещи скрываются в VCL кодах (в частности messages.pas). Метод Perform дает вам возможность посылать сообщения различным компонентам. Все сообщения описаны в файле Messages.pas (настоятельно рекомендую вам его посмотреть!!!). Данный метод надо вызывать по такой схеме:


 Имя_компонента.Perform(Сообщение, верхний параметр: Integer, нижний параметр: Integer);
 

Начнем с самого простого. Попробуем закрыть форму. Для этого поставьте на форму одну кнопку и в обработчике ее события OnClick напишите:


 Form1.Perform(WM_CLOSE, 0, 0);
 

Теперь попробуем изменить иконку вашей программы. Поставьте на форму компонент Image и загрузите в него какую-нибудь иконку. Будем использовать сообщение WM_SETICON. А поскольку в качестве параметров необходима величина типа Integer, то мы воспользуемся указателем на иконку (handle). Теперь обработчик нажатия кнопки может иметь вид:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Perform(WM_SETICON, 0, image1.Picture.Icon.Handle);
 end;
 

Теперь попробуем осуществить программный клик по кнопке 1. Поставьте на форму еще одну кнопку и в ее обработчике события OnClick, напишите:


 Button1.Perform(WM_LBUTTONDOWN, 0, 0);
 Button1.Perform(WM_LBUTTONUP, 0, 0);
 

А можно и попроще реализовать:


 Button1.Perform(BM_CLICK, 0, 0);
 

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

Теперь маленько коснемся компонентов для работы с текстом. Для начала установите на форму компонент Memo. Будем делать с ним разные стандартные вещи: добавлять символы, копировать, вставлять, вырезать, отменять и т.д.

Начнем с вырезания текста. Обработчик кнопки поменяйте на:


 Memo1.SelectAll;
 Memo1.Perform(WM_CUT, 0, 0);
 

С начала выделяется весь текст, а потом вырезается и помещается в буфер. Также можно и копировать текст, только надо изменить сообщение на: WM_COPY. Соответственно, чтобы вставить текст из буфера напишите:


 Memo1.Perform(WM_PASTE, 0, 0);
 

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


 Memo1.Perform(EM_UNDO, 0, 0);
 

Чтобы добавить символ в Memo нужно написать так:


 Memo1.Perform(WM_CHAR, 192, 0);
 

где 192, номер символа 'A', этот вызов метода Perform, можно заменить на аналогичный:


 Memo1.Perform(WM_CHAR, LongInt(char('A')), 0);
 

Здесь значение символа 'A' как тип Char преобразуется в тип LongInt, а затем добавляется в Memo.

Теперь будем разбираться с Listbox' ами. Для этого добавьте его на форму а событие OnClick кнопки замените на:


 Listbox1.Perform(LB_ADDSTRING, 0, LongInt(Pchar('Эта строка появится в ListBoxe')));
 

Если заменить LB_ADDSTRING на LB_INSERTSTRING, то строка будет вставляться в зависимости от первого параметра, который равен 0 в первом случае.

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


 Listbox1.Perform(LB_SELECTSTRING, 0, LongInt(pchar('текст строки, которую нужно найти')));
 

С помощью приведенной выше строчки кода можно реализовать поиск в ListBox'e, наподобие того, как это делается в FontDialog. В текстовом поле ввода вы вводите текст, и наиболее похожий по шрифт выделяется. Чтобы это осуществить поставьте на форму компонент Edit. А в обработчике его события OnChange напишите:


 Listbox1.Perform(LB_SELECTSTRING, 0, LongInt(pchar(Edit1.Text)));
 

Ну вот кратенький обзор метода Perform подошел к концу. Хочется посоветовать только одного, смотрите файл Messages.pas, ищите новые решения и не бойтесь пробовать, а вдруг сработает!!!




Splitter Bar

...я использую TOutline, выровненный с помощью alLeft, и desktop, выровненной по его правой части. Панель расположена после TOutline, и также выровнена с помощью alLeft. Все это дело прилипает к TOutline. Я назвал новую панель 'splitter'. "Отрегулируйте" splitter под себя, сделайте его поУже, создайте красивый контур и нарисуйте двунаправленный курсор. В приведенном ниже примере вы можете заменить TOutLine на нужный вам компонент. Создайте обработчик события мыши и напишите следующий код:


 procedure TMainForm.SplitterMouseMove(Sender: TObject; Shift: TShiftState;
   X, Y: Integer);
 begin
   if ssLeft in Shift then
     outline.Width := outline.Width + X;   {замените OutLine нужным вам объектом}
 end;
 




Разрезать и соединить файлы


 {
   Parameters:
 
   FileToSplit: Specify a file to split.
   SizeofFiles: Specify the size of the files you want to split to (in bytes)
   Progressbar: Specify a TProgressBar to show the splitting progress
 
   Result:
   SplitFile() will create files  FileName.001, FileName.002, FileName.003 and so on
   that are SizeofFiles bytes in size.
  }
 
 function SplitFile(FileName : TFileName; SizeofFiles : Integer;
 ProgressBar : TProgressBar) : Boolean;
 var
   i : Word;
   fs, sStream: TFileStream;
   SplitFileName: String;
 begin
   ProgressBar.Position := 0;
   fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
   try
     for i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do
     begin
       SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
       sStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive);
       try
         if fs.Size - fs.Position < SizeofFiles then
           SizeofFiles := fs.Size - fs.Position;
         sStream.CopyFrom(fs, SizeofFiles);
         ProgressBar.Position := Round((fs.Position / fs.Size) * 100);
       finally
         sStream.Free;
       end;
     end;
   finally
     fs.Free;
   end;
 
 end;
 
 // Combine files / Dateien zusammenfьhren 
 
 {
   Parameters:
 
   FileName: Specify the first piece of the splitted files
   CombinedFileName: Specify the combined file name. (the output file)
 
   Result:
   CombineFiles() will create one large file from the pieces
  }
 
 function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean;
 var
   i: integer;
   fs, sStream: TFileStream;
   filenameOrg: String;
 begin
   i := 1;
   fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive);
   try
     while FileExists(FileName) do
     begin
       sStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
       try
         fs.CopyFrom(sStream, 0);
       finally
         sStream.Free;
       end;
       Inc(i);
       FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
     end;
   finally
     fs.Free;
   end;
 end;
 
 // Examples: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SplitFile('C:\temp\FileToSplit.chm',1000000, ProgressBar1);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   CombineFiles('C:\temp\FileToSplit.001','H:\temp\FileToSplit.chm');
 end;
 




Существует ли способ для определение числа заданий Spoolerа печати

Вопрос: Существует ли способ для определение числа заданий spoolerа печати?

Ответ: Spoolerа печати Windows посылает WM_SPOOLERSTATUS каждый раз при добавлении и удалении заданий в очереди печати. В следующем примере показано как перехватить это сообщение

Пример:


 type
   TForm1 = class(TForm)
     Label1: TLabel;
   private
     { Private declarations }
     procedure WM_SpoolerStatus(var Msg: TWMSPOOLERSTATUS);
       message WM_SPOOLERSTATUS;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WM_SpoolerStatus(var Msg: TWMSPOOLERSTATUS);
 begin
   Lable1.Caption := IntToStr(msg.JobsLeft) +
     ' Jobs currenly in spooler';
   msg.Result := 0;
 end;
 




Распространение BDE

Следуйте приведенной ниже инструкции для разворачивания BDE на клиентской машине:

  1. Отформатируйте две дискеты в дисководе клиентской машины. Пометьте дискеты как "Disk 1" и "Disk 2".
  2. Скопируйте файлы с DELPHI CD, содержащиеся в каталоге \REDIST\BDEINST\DISK1 на дискету, помеченную как "Disk 1", и файлы из каталога \REDIST\BDEINST\DISK2 на дискету "Disk 2".
  3. Вставьте в дисковод клиентской машины дискету, помеченную как "BDE Install 1" (в нашем примере мы используем дисковод с буквой A:).
  4. Убедитесь в том, что в Windows отсутствуют запущенные программы. В Windows Program Manager выберите File|Run, введите в поле редактирования командной строки ("Command Line") "A:\DISK1\SETUP" и нажмите "OK" для начала установки Borland Database Engine на клиентской машине.
  5. Сначала, на короткое время, появится окно "Database Engine Install", затем диалог "preparing to install...", и, наконец, диалог "BDE Redisttributable", содержащий кнопки Continue (Продолжить) и Exit (Выйти). Нажмите "Continue".
  6. Появится диалог "Borland Database Engine Location Settings", позволяющий изменить каталог установки программ BDE и конфигурационных файлов. Оставьте настройки по умолчанию и нажмите "Continue" (Продолжить).
  7. Появится диалог "Borland Database Engine Installation", позволяющий вернуться к предыдущим диалогам или начать установку. Нажмите "Install" (Установить).
  8. Процесс копирования дискеты "Disk 1" будет отображаться полоской прогресса.
  9. Появится диалог "BDE Redistributable Install Request". Вставьте дискету "Disk 2". Нажмите "continue" (Продолжить).
  10. По окончании процедуры установки появится диалог "Borland Database Engine Installation Notification", сообщающий об успешной установке BDE. Нажмите "Exit" (Выход).
  11. Завершите работу Windows, удалите дискету из дисковода и перегрузите клиентскую машину.
Если настройки по умолчанию уже где-то используются, произойдут изменения, указанные ниже.

На клиентской машине появятся два новых каталога - \IDAPI и \IDAPI\LANGDRV. Обратите внимание на то, что утилита BDE Configuration Utility, BDECFG.EXE, располагается в каталоге \IDAPI. Языковые драйвера располагаются в каталоге \IDAPI\LANGDRV как файлы *.LD. AUTOEXEC.BAT, CONFIG.SYS и SYSTEM.INI при инсталляции не изменяются.

WIN.INI в каталоге \WINDOWS\SYSTEM будет иметь новые секции:

 [IDAPI]
 DLLPATH=C:\IDAPI
 CONFIGFILE01=C:\IDAPI\IDAPI.CFG
 
 [Borland Language Drivers]
 LDPath=C:\IDAPI\LANGDRV
 



Функции дат в SQL

Автор: Steve Koterski

Кто-нибудь знает как "вытащить" месяц или год из datetime-поля с помощью SQL? Я знаю, что QBE этого не может. SQL в состоянии это сделать?

Как насчет функции EXTRACT?

  SELECT SALEDATE,
     EXTRACT(DAY FROM SALEDATE) AS DD,
     EXTRACT(MONTH FROM SALEDATE) AS MM,
     EXTRACT(YEAR FROM SALEDATE) AS YY
   FROM ORDERS



SQL и расширенные символы

Я использую поле Tmemo.

Это классно работает до тех пор, пока я не использую расширенные символы (с кодом больше 127). При использовании этих символов текст-то я послать могу, но при последующем поиске записи я получаю такое сообщение об ошибке:

"General SQL error : Cannot transliterate character between character sets." (Общая ошибка SQL: не могу сопоставить символ с имеющимися наборами символов).

Я понял, в чем ваша ошибка: вы должны установить встроенный набор символов LIBS в DEFAULT CHARACTER SET ISO8859_1. Когда вы впоследствии создадите таблицу, она будет использовать данный набор символов для создания alfanumeric-данных и Blob-полей. Псевдоним базы данных должен быть установлен на драйвер языка BLLT1FR.

После того, как я сделал это и пересоздал базу данных, все заработало как надо.

Может быть и не стоило публиковать эту информацию, поскольку многие пользователи пользуются локальными драйверами, наборами символов и новой версией SQL, но я посчитал ее ценной, поскольку как раз эта инфорамция в описании и отсутствует. Она присутствует только в LIBS "readme"-файле.




SQL в Delphi

Автор: OAmiry (Borland)

Delphi поддерживает статический и динамический SQL. В Delphi имеется объект TQuery, который используется для хранения и выполнения SQL-запросов.

Свойство TQuery SQL содержит текст SQL-запроса, выполняемых TQuery.
Данное свойство имеет тип TStrings, означающее, что оно может хранить в списке целую серию строк. Список ведет себя подобно массиву, но в действительности это специальный класс с уникальными возможностями.

Компонент TQuery позволяет выполнять два типа SQL-запросов:

  • Статические SQL-запросы
  • Динамические SQL-запросы
Статический SQL-запрос устанавливается во время проектирования и не содержит никаких параметров или переменных. Например, следующая строка является статическим SQL-запросом:

SELECT * FROM CUSTOMER WHERE CUST_NO = 1234

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

SELECT * FROM CUSTOMER WHERE CUST_NO = :Number

Переменная Number, указанная после двоеточия - параметр, который вы назначаете во время выполнения приложения. Во время выполнения запроса параметр может изменяться.

Delphi-приложения могут использовать SQL для получения доступа к следующим БД:

  • Таблицы Paradox или dBASE, использующие локальный SQL. Допустимый синтаксис является подмножеством стандарта ANSI-standard SQL и включает основные SELECT, INSERT, UPDATE, и DELETE запросы. Для получения дополнительной информации о локальном синтаксисе SQL обратитесь к справке Using Local SQL.
  • Базы данных Local InterBase Server, включая Local InterBase Server. Допускаются любые запросы InterBase SQL. Для получения дополнительной информации о синтаксисе и ограничениях обратитесь к электронной справке SQL Statement and Function Reference.
  • Базы данных на удаленных серверах баз данных (только в версии Delphi Client/server). По-видимому вы установили подходящий SQL Link. В SQL серверах допускаются любые стандартные SQL запросы. Для получения дополнительной информации о синтаксисе и ограничениях обратитесь к электронной справке вашего сервера.
Delphi также поддерживает разнородные запросы к более чем одному серверу или типу таблицы (для примера, данные из таблицы Oracle и таблицы Paradox). Для получения дополнительной информации обратитесь к электронной справке Creating Heterogeneous Queries (создание гетерогенных запросов).

Обработка транзаций в приложениях:

Delphi приложения могут управлять транзакциями следующими способами:

  1. Неявно, автоматически стартуя и запуская транзакции, когда приложение пытается передать данные (Post data).
  2. Явно, следующими способами в зависимости от уровня управления, требующемуся вашему приложению:
    • Методы TDatabase StartTransaction, Commit, и Rollback.
    • Это рекомендуемый метод.
  3. Passthrough (транзитная пересылка) SQL в компоненте TQuery. Ваше приложение должно использовать специфически-серверные SQL запросы управления транзакциями, и вы должны понять как управляются транзакции вашим сервером.



SQL outer join


 Select * From "TEST.DB" Test Left Outer Join "Emp.DB" Emp
 On Test.Emp_ID = Emp.Emp_ID
 

Вместо Left вы можете также задать Right или Full.




Зарезервированные слова Local SQL

Ниже приведен список в алфавитном порядке слов, зарезервированных Local SQL в Borland Database Engine. Имейте в виду, что данный совет публикуется "как есть".

ACTIVE, ADD, ALL, AFTER, ALTER, AND, ANY, AS, ASC, ASCENDING, AT, AUTO, AUTOINC, AVG

BASE_NAME, BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN, BOTH, BY, BYTES

CACHE, CAST, CHAR, CHARACTER, CHECK, CHECK_POINT_LENGTH, COLLATE, COLUMN, COMMIT, COMMITTED, COMPUTED, CONDITIONAL, CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING, CURRENT, CURSOR

DATABASE, DATE, DAY, DEBUG, DEC, DECIMAL, DECLARE, DEFAULT, DELETE, DESC, DESCENDING, DISTINCT, DO, DOMAIN, DOUBLE, DROP

ELSE, END, ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE, EXISTS, EXIT, EXTERNAL, EXTRACT

FILE, FILTER, FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION

GDSCODE, GENERATOR, GEN_ID, GRANT, GROUP, GROUP_COMMIT_WAIT_TIME

HAVING, HOUR

IF, IN, INT, INACTIVE, INDEX, INNER, INPUT_TYPE, INSERT, INTEGER, INTO, IS, ISOLATION

JOIN

KEY

LONG, LENGTH, LOGFILE, LOWER, LEADING, LEFT, LEVEL, LIKE, LOG_BUFFER_SIZE

MANUAL, MAX, MAXIMUM_SEGMENT, MERGE, MESSAGE, MIN, MINUTE, MODULE_NAME, MONEY, MONTH

NAMES, NATIONAL, NATURAL, NCHAR, NO, NOT, NULL, NUM_LOG_BUFFERS, NUMERIC

OF, ON, ONLY, OPTION, OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW

PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD, PLAN, POSITION, POST_EVENT, PRECISION, PROCEDURE, PROTECTED, PRIMARY, PRIVILEGES

RAW_PARTITIONS, RDB$DB_KEY, READ, REAL, RECORD_VERSION, REFERENCES, RESERV, RESERVING, RETAIN, RETURNING_VALUES, RETURNS, REVOKE, RIGHT, ROLLBACK

SECOND, SEGMENT, SELECT, SET, SHARED, SHADOW, SCHEMA, SINGULAR, SIZE, SMALLINT, SNAPSHOT, SOME, SORT, SQLCODE, STABILITY, STARTING, STARTS, STATISTICS, SUB_TYPE, SUBSTRING, SUM, SUSPEND

TABLE, THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE, TO, TRAILING, TRANSACTION, TRIGGER, TRIM

UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER, USER

VALUE, VALUES, VARCHAR, VARIABLE, VARYING, VIEW

WAIT, WHEN, WHERE, WHILE, WITH, WORK, WRITE

YEAR

Операторы:

||, -, *, /, <>, <, >, ,(запятая), =, <=, >=, ~=, !=, ^=, (, )




SQL - сортировка вычисляемого поля

У молодого хакера спрашивают:
- Максим, ну что тебе нравится, кроме женщин и компьютеров?
- Как что? Девушки и калькуляторы.

Иногда схема данных требует, чтобы набор данных имел вычисляемый результат. В приложениях Delphi в случае использования SQL это возможно, но эта технология немного разнится в зависимости от используемого типа данных.

Для локального SQL, включая таблицы Paradox и dBASE, вычисляемому полю дают имя с использованием ключевого слова AS. При этом допускается ссылаться на такое поле для задания порядка сортировки с помощью ключевой фразы ORDER BY в SQL-запросе. Например, используя демонстрационную таблицу ITEMS.DB:

  SELECT I."PARTNO", I."QTY", (I."QTY" * 100) AS TOTAL
   FROM "ITEMS.DB" I
   ORDER BY TOTAL
В данном примере вычисляемому полю было присвоено имя TOTAL (временно, только для ссылки), после чего оно стало доступным в SQL-запросе для выражения ORDER BY.

Вышеуказанный метод не поддерживается в InterBase. Тем не менее, сортировать вычисляемые поля в таблицах InterBase (IB) или сервере Local InterBase Server все же возможно. Вместо использования имени вычисляемого поля, в выражении ORDER BY используется порядковое число, представляющее собой позицию вычисляемого поля в списке полей таблицы. Например, используя демонстрационную таблицу EMPLOYEE (расположенную в базе данных EMPLOYEE.GDB):

  SELECT EMP_NO, SALARY, (SALARY / 12) AS MONTHLY
   FROM EMPLOYEE
   ORDER BY 3 DESCENDING
В то время, как таблицы IB и LIBS используют второй метод, и не могут воспользоваться первым, оба метода доступны при работе с локальным SQL. К примеру, используя SQL-запрос для таблицы Paradox, и приспосабливая его для работы с относительной позицией вычисляемого поля, а не его именем:
  SELECT I."PARTNO", I."QTY", (I."QTY" * 100) AS TOTAL
   FROM "ITEMS.DB" I
   ORDER BY 3



SQL - вложенные пробелы

Письмо в компьютерный сервисный центр:
- Этанутипауменяпробелполомалсячеделатьто?
Ответ:
- Настоящие_программисты_не_пользуются_пробелами.

Выполнение SQL с пробелами и специальными символами в имени поля/колонки

Выполнение SQL-запросов в Delphi-компоненте TQuery (или специального средства SQL-запроса в Database Desktop, Visual dBASE или Paradox for Windows) требует специального синтаксиса для любых колонок, содержащих пробелы или специальные символы.

Пользуясь таблицей Biolife.DB из демо-данных Delphi, проиллюстрируем использование любых специфических требований синтаксиса. Запрос SQL Select мог бы быть сформирован следующим образом:

  SELECT
    Species No,
    Category,
    Common_Name,
    Species Name,
    Length (cm),
    Length_In,
    Notes,
    Graphic
   FROM
    BIOLIFE
В нормальной ситуации пробелы в номерах и именах колонок, длина в сантиметрах, круглые скобки и другие символы могут стать причиной синтаксической ошибки.

Для коррекции синтаксиса в вышеприведенном SQL-выражении необходимо внести два изменения. Во-первых, любые колонки, содержищие пробелы или специальные символы должны быть заключены в двойные или одинарные (апострофы) кавычки. Во-вторых, ссылке на имя колонки должна предшествовать ссылка на саму таблицу и точка после нее. Второе требование особенно важно, поскольку заключенная в кавычки строка интерпретируется не как строковое выражение, а как значение колонки. Ниже приведено правильно отформатированное выражение:

  SELECT
    BIOLIFE."Species No",
    BIOLIFE."Category",
    BIOLIFE."Common_Name",
    BIOLIFE."Species Name",
    BIOLIFE."Length (cm)",
    BIOLIFE."Length_In",
    BIOLIFE."Notes",
    BIOLIFE."Graphic"
   FROM
    "BIOLIFE.DB" BIOLIFE
В приведенном выше примере таблицный псевдоним BIOLIFE используется в качестве ссылки на саму таблицу и располагается перед именем колонки . Данная ссылка может принимать форму имени псевдонима, реального имени таблицы, или ссылаться на имя файла при использовании таблиц dBASE или Paradox. Следующее SQL-выражение должно также хорошо работать.

Примечание: Данное SQL-выражение может использоваться при условии, что необходимый псевдоним уже открыт. В случае TQuery это означает, что псевдоним определен в свойстве DatabaseName.

  SELECT
    BIOLIFE."Species No",
    BIOLIFE.Category,
    BIOLIFE.Common_Name,
    BIOLIFE."Species Name",
    BIOLIFE."Length (cm)",
    BIOLIFE.Length_In,
    BIOLIFE.Notes,
    BIOLIFE.Graphic
   FROM
    BIOLIFE
Если псевдоним недоступен, то для таблицы должен быть определен путь целиком, например, так:
   SELECT
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Species No",
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Category",
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Common_Name",
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Species Name",
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Length (cm)",
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Length_In",
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Notes",
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"."Graphic"
   FROM
    "C:\DELPHI\DEMOS\DATA\BIOLIFE.DB"

Наконец, есть два средства автоматического форматирования специального синтаксиса. Первым является Visual Query Builder, включаемой в версию Client/Server Delphi. Visual Query Builder выполняет такое форматирование автоматически, по мере создания запроса. Другое средство - Database Desktop Show SQL, доступный при создании и редактировании запроса QBE-типа. После выбора пункта меню Query|Show SQL, отображаемый SQL-текст может быть вырезан и вставлен где необходимо.




Синтах SQL-функции Substring


 SUBSTRING('Delphi World - это супер!!!' from 1 to 6)
 




SQL - использование функции SUBSTRING

SQL-функция SUBSTRING может использоваться в приложениях Delphi, работающих с запросами к локальной SQL, но она не поддерживается при работе с таблицами InterBase (IB) и Local InterBase Server (LIBS). Ниже приведен синтаксис функции SUBSTRING, примеры ее использования в запросах к local SQL, и альтернатива для возвращения тех же результатов для таблиц IB/LIBS.

Синтаксис функции SUBSTRING:

  SUBSTRING(<column> FROM <start> [, FOR <length>])
Где:

<column> - имя колонки таблицы, из которой должна быть получена подстрока (substring).

<start> место в значении колонки, начиная с которого извлекается подстрока.

<length> длина извлекаемой подстроки.

Функция SUBSTRING в примере ниже возвратит второй, третий и четвертый символы из колонки с именем COMPANY:

  SUBSTRING(COMPANY FROM 2 FOR 3)
Функция SUBSTRING может быть использована и для списка полей в SELECT-запросе, где ключевое слово WHERE допускает сравнение значения с определенным набором колонок. Функция SUBSTRING может использоваться только с колонками типа String (на языке SQL тип CHAR). Вот пример функции SUBSTRING, использующей список колонок в SELECT-запросе (используем демонстрационную таблицу Paradox CUSTOMER.DB):
  SELECT (SUBSTRING(C."COMPANY" FROM 1 FOR 3)) AS SS
   FROM "CUSTOMER.DB" C
Данный SQL-запрос извлекает первые три символа из колонки COMPANY, возвращаемой как вычисляемая колонка с именем SS. Вот пример функции SUBSTRING, использованной в SQL-запросе с ключевым словом WHERE (используем ту же самую таблицу):
  SELECT C."COMPANY"
   FROM "CUSTOMER.DB" C
   WHERE SUBSTRING(C."COMPANY" FROM 2 FOR 2) = "an"
Данный запрос возвратит все строки таблицы, где второй и третий символы в колонке COMPANY равны "ar".

Так как функция SUBSTRING не поддерживается в базах данных IB и LIBS, операции с подстроками со списком колонок в запросе невозможны (исключение: IB может работать с подстроками через функции, определяемые пользователем, User-Defined Functions). Но с помощью оператора LIKE и сопутствующих символьных маркеров подстановки возможно работать с подстрокой и в случае WHERE. Вот пример на основе таблицы EMPLOYEE (в базе данных EMPLOYEE.GDB):

  SELECT LAST_NAME, FIRST_NAME
   FROM EMPLOYEE
   WHERE LAST_NAME LIKE "_an%"

Данный SQL-запрос возвратит все строки таблицы, где второй и третий символы в колонке LAST_NAME равны "an", см. предыдущий пример на основе таблицы Paradox. Базам данных IB и LIBS для выполнения сравнения подстроки в операторе запроса WHERE данный метод необходим (и невозможно воспользоваться функцией SUBSTRING), таблицы же Paradox и dBASE (например, local SQL) могут воспользоваться любым методом.




SQL - суммирование вычисляемого поля

Антивирус. Ты кто?
Вирус. Область данных!
Антивирус. А не вирус?
Вирус. Hи боже мой!
Антивирус. А зачем прерывания перехватываешь?
Вирус. Я?!
Антивирус. Вот же подпрограмма.
Вирус. Это не подпрограмма. Это цитата из Лао-цзы на языке оригинала в альтернативной кодировке.
Антивирус. А зачем EXE-файлы ищешь?
Вирус. А вдруг хозяин спросит: "А где мои ЕХЕ-файлы?" А я ему - вот они!
Антивирус. Сдается мне, что ты все-таки вирус.
Вирус. Hу ладно, только тебе признаюсь, только ты никому не говори! Hа самом деле я... антивирусная вакцина!
Антивирус. А зачем нужна антивирусная вакцина, если есть я?
Вирус. Откуда я знаю? У хозяина спроси.
Антивирус. А если я тебя на всякий случай все-таки грохну?
Вирус. А если я тебя?
Антивирус. Hе получится. У меня управление.
Вирус. А ты свою контрольную сумму давно пересчитывал?
Антивирус. А причем тут моя контрольная... ой!!!
Вирус. То-то же.

Бывают случаи, когда в приложении Delphi, которое для получения доступа к данным использует SQL, необходимо узнать сумму вычисленных данных. Другими словами, необходимо с помощью SQL создать вычисляемое поле и применить к нему функцию SUM.

При выполнении такой операции с SQL-таблицами (например, Local InterBase Server), все достаточно тривиально, и сумма вычисляется простым использованием функции SUM с указанием поля. Например, используя демонстрационную таблицу EMPLOYEE (из базы данных EMPLOYEE.GDB):

   SELECT SUM(SALARY / 12)
   FROM EMPLOYEE
Та же самая методика применима в случае возвращаемого набора данных, в котором значения группируются в другом столбце с помощью утверждения GROUP BY:
  SELECT EMP_NO, SUM(SALARY / 12)
   FROM EMPLOYEE
   GROUP BY EMP_NO
   ORDER BY EMP_NO

Пока SQL базы данных поддерживают суммирование вычисляемых полей, локальный SQL этого делать не будет. Для получения результатов нужны другие методы, например копирование результатов запроса с вычисляемым полем во временную таблицу (как и в случае компонента TBatchMove), и использование компонента TQuery для вычисления суммы данных во временной таблице.




Имя SQL-таблицы

Этот SQL не работает для RequestLive := True : SELECT * FROM DBO.TABLE1

Этот SQL работает для RequestLive := True : SELECT * FROM "DBO.TABLE1"

Помните о том, что кавычки необходимы для обозначения имени таблицы! Также имейте в виду, что поставляемая документация говорит о том, что для таблиц Oracle кавычки не нужны! Неверно, нужны!!!




sscanf в Delphi

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


 unit Scanf;
 
 interface
 uses SysUtils;
 
 type
 
   EFormatError = class(ExCeption);
 
 function Sscanf(const s: string; const fmt: string;
   const Pointers: array of Pointer): Integer;
 implementation
 
 { Sscanf выполняет синтаксический разбор входной строки. Параметры...
 
 s - входная строка для разбора
 fmt - 'C' scanf-форматоподобная строка для управления разбором
 %d - преобразование в Long Integer
 %f - преобразование в Extended Float
 %s - преобразование в строку (ограничено пробелами)
 другой символ - приращение позиции s на "другой символ"
 пробел - ничего не делает
 Pointers - массив указателей на присваиваемые переменные
 
 результат - количество действительно присвоенных переменных
 
 Например, ...
 Sscanf('Name. Bill   Time. 7:32.77   Age. 8',
 '. %s . %d:%f . %d', [@Name, @hrs, @min, @age]);
 
 возвратит ...
 Name = Bill  hrs = 7  min = 32.77  age = 8 }
 
 function Sscanf(const s: string; const fmt: string;
 
   const Pointers: array of Pointer): Integer;
 var
 
   i, j, n, m: integer;
   s1: string;
   L: LongInt;
   X: Extended;
 
   function GetInt: Integer;
   begin
     s1 := '';
     while (s[n] = ' ') and (Length(s) > n) do
       inc(n);
     while (s[n] in ['0'..'9', '+', '-'])
       and (Length(s) >= n) do
     begin
       s1 := s1 + s[n];
       inc(n);
     end;
     Result := Length(s1);
   end;
 
   function GetFloat: Integer;
   begin
     s1 := '';
     while (s[n] = ' ') and (Length(s) > n) do
       inc(n);
     while (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E'])
       and (Length(s) >= n) do
     begin
       s1 := s1 + s[n];
       inc(n);
     end;
     Result := Length(s1);
   end;
 
   function GetString: Integer;
   begin
     s1 := '';
     while (s[n] = ' ') and (Length(s) > n) do
       inc(n);
     while (s[n] <> ' ') and (Length(s) >= n) do
     begin
       s1 := s1 + s[n];
       inc(n);
     end;
     Result := Length(s1);
   end;
 
   function ScanStr(c: Char): Boolean;
   begin
     while (s[n] <> c) and (Length(s) > n) do
       inc(n);
     inc(n);
 
     if (n <= Length(s)) then
       Result := True
     else
       Result := False;
   end;
 
   function GetFmt: Integer;
   begin
     Result := -1;
 
     while (TRUE) do
     begin
       while (fmt[m] = ' ') and (Length(fmt) > m) do
         inc(m);
       if (m >= Length(fmt)) then
         break;
 
       if (fmt[m] = '%') then
       begin
         inc(m);
         case fmt[m] of
           'd': Result := vtInteger;
           'f': Result := vtExtended;
           's': Result := vtString;
         end;
         inc(m);
         break;
       end;
 
       if (ScanStr(fmt[m]) = False) then
         break;
       inc(m);
     end;
   end;
 
 begin
 
   n := 1;
   m := 1;
   Result := 0;
 
   for i := 0 to High(Pointers) do
   begin
     j := GetFmt;
 
     case j of
       vtInteger:
         begin
           if GetInt > 0 then
           begin
             L := StrToInt(s1);
             Move(L, Pointers[i]^, SizeOf(LongInt));
             inc(Result);
           end
           else
             break;
         end;
 
       vtExtended:
         begin
           if GetFloat > 0 then
           begin
             X := StrToFloat(s1);
             Move(X, Pointers[i]^, SizeOf(Extended));
             inc(Result);
           end
           else
             break;
         end;
 
       vtString:
         begin
           if GetString > 0 then
           begin
             Move(s1, Pointers[i]^, Length(s1) + 1);
             inc(Result);
           end
           else
             break;
         end;
 
     else
       break;
     end;
   end;
 end;
 
 end.
 




Описание протокола SSL (Secure Socket Layer)

Встретились как-то два командира Нортон и Волков. Нортон как всегда в окружении симпатичных утилиток и с полной сумкой вьюверов, а Волков в гордом одиночестве, но с сознанием собственного совершенства. И зашел между ними спор, кто круче.
- Я как брошу файлы с одного компьютера, так через всю комнату летят и в другой попадают, - хвастается Нортон.
- А я как ударю по каталогу, так он весь сразу и рассыпается, - хвастает Волков.
Так спорили они, спорили, и решили, что только кто-нибудь третий может их рассудить. Видят в сторонке, немного прихрамывая, мужик идет, весь в разукрашенной одежде и изо всех карманов какие-то приспособления торчат.
- Эй, мужик, - обратился к нему командир Нортон, - разреши наш спор.
- Скажи, кто из нас круче, - подхватил командир Волков.
- Вы оба никуда не годитесь, - отвечает мужик, - старые уже, никого удовлетворить не можете, пора вам на свалку.
- Да кто ты такой, что нам так говорить! - возмутились командиры.
- Я - Дос Навигатор, - ответил мужик.

Протокол SSL (secure socket layer) был разработан фирмой Netscape, как протокол обеспечивающий защиту данных между сервисными протоколами (такими как HTTP, NNTP, FTP и т.д.) и транспортными протоколами (TCP/IP). Не секрет, что можно без особых технических ухищрений просматривать данные, которыми обмениваются между собой клиенты и серверы. Был даже придуман специальный термин для этого _ Tsniffer. А в связи с увеличением объема использования Интернета в коммерческих целях, неизбежно вставал вопрос о защите передаваемых данных. И пользователи не очень были бы рады, если номер их кредитной карточки, был бы перехвачен, каким ни будь предприимчивым хакером Tпо дороге к виртуальному магазину. И, в общем, появление такого протокола как SSL было вполне закономерным явлением. С одной стороны остаются все возможности сервисных протоколов (для программ-серверов), плюс к этому все данные передаются в зашифрованном виде. И разкодировать их довольно трудно. Опустим здесь возможности взлома SSL (она, безусловно, есть, но это отдельная тема для большой статьи). Следует отметить, что SSL не только обеспечивает защиту данных в Интернете, но так же производит Tопознание_ сервера и клиента (Tserver/client authentication_). В данный момент протокол SSL принят W3 консорциумом (W3 Consortium) на рассмотрение, как основной защитный протокол для клиентов и серверов (WWW browsers and servers) в сети Интернет.

Алгоритм работы SSL построен на принципе публичных ключей. Этот принцип построен на использовании пары асимметричных ключей (публичном и приватном) для кодирования/декодирования информации. Публичный ключ раздается всем желающим. И с его помощью шифруются необходимые данные, которые можно дешифровать только с помощью приватного ключа. Отходя от темы, можно сказать, что так оно выглядит в теории. На практике все несколько менее строго. Из-за юридических ограничений на длину ключей, они поддаются взлому, хотя для этого и необходимы достаточно большие вычислительные мощности.

Теперь рассмотрим, каким образом все-таки работает SSL

Представьте себе, что есть два человека, которые общаются посредством Интернета и соответственно не видят друг друга. И лишены возможности, узнать, о том кто же его абонент. Их имена _ Алиса и Боб. Допустим Алисе надо, узнать действительно она разговаривает с Бобом или нет. В этом случае диалог может выглядеть следующим образом:

  1. Алиса отправляет Бобу случайное сообщение.
  2. Боб шифрует его с помощью своего приватного ключа и отправляет его Алисе.
  3. Алиса дешифрует это сообщение (с помощью публичного ключа Боба). И сравнив это сообщение с посланным, может убедиться в том, что его действительно послал Боб.
  4. Но на самом деле со стороны Боба не очень удачная идея шифровать сообщение от Алисы с помощью своего приватного ключа. И возвращать его. Это аналогично подписи документа, о котором Боб мало что знает. С такой позиции Боб должен сам придумать сообщение. И послать его Алисе в двух экземплярах. В первом сообщение передается открытым текстом, а второе сообщение зашифровано с помощью приватного ключа Боба. Такое сообщение называется message digest. А способ шифрования сообщения с помощью своего приватного ключа _ цифровой подписью (digital signature).

Теперь закономерно встает вопрос о том, каким образом распространять свои публичные ключи. Для этого (и не только) была придумана специальная форма - сертификат (certificate). Сертификат состоит из следующих частей:

  • Имя человека/организации выпускающего сертификат.
  • Для кого был выпущен данный сертификат (субъект сертификата).
  • Публичный ключ субъекта.
  • Некоторые временные параметры (срок действия сертификата и т.п.).
  • Сертификат Tподписывается_ приватным ключом человека (или огрганизации), который выпускает сертификаты. Организации, которые производят подобные операции называются _ TCertificate authority (CA). Если в стандартном Web-клиенте (web-browser), который поддерживает SSL, зайти в раздел security. То там можно увидеть список известных организаций, которые Tподписывают_ сертификаты. С технической стороны, создать свою собственную CA достаточно просто. Но против этого могут действовать скорее юридические препятсвия.

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

  1. Алиса: привет.
  2. Боб: привет, я Боб (выдает свой сертификат).
  3. Алиса: а ты точно Боб?
  4. Боб: Алиса я Боб. (Сообщение передается два раза, один раз в открытую, второй раз, зашифрованный с помощью приватного ключа Боба).
  5. Алиса: все нормально, ты действительно Боб. (И присылает Бобу секретное сообщение, зашифрованное с помощью публичного ключа Боба).
  6. Боб: А вот и мое сообщение (посылает сообщение, которое было зашифровано с помощью секретного ключа, например того же шифрованного сообщения Алисы).
  7. Поскольку Боб знает сообщение Алисы, потому что он владеет приватным ключом и Алиса знает, что было в том сообщении. Теперь они могут использовать симметричный шифровальный алгоритм (где в качестве секретного ключа выступает сообщение Алисы) и безбоязненно обмениваться шифрованными сообщениями. А для контроля над пересылкой сообщений (от случайного/преднамеренного изменения) используется специальный алгоритм - Message Authentication Code (MAC). Довольно распространенным является алгоритм MD5. Обычно, и сам MAC-code так же шифруется. В связи с этим достоверность сообщений повышается в несколько раз. И внести изменения в процесс обмена практически невозможно.

Теперь несколько слов о реализации SSL. Наиболее распространенным пакетом программ для поддержки SSL _ является SSLeay. Последняя версия (SSLeay v. 0.8.0) поддерживает SSLv3. Эта версия доступна в исходных текстах. И без особых проблем устанавливается под UNIX (я не пробовал ставить SSLeay под операционные системы фирмы Microsoft). Этот пакет предназначен для создания и управления различного рода сертификатами. Так же в его состав входит и библиотека для поддержки SSL различными программами. Эта библиотека необходима, например, для модуля SSL в распространенном HTTP сервере _ Apache. Если Вы устанавливаете версию, вне США, то особых проблем с алгоритмом RSA быть не должно. Но только накладывается ограничение на длину ключа в 40 бит (возможно, на данный момент это ограничение снято, но на пакете SSLeay это никоим образом не отразилось. Действеут это ограничение и на другой пакет от фирмы Netscape - SSLRef). А вот если компьютер с SSLeay находится на территории США, то за использование алгоритма RSA необходимо заплатить какие то деньги. Но об этом нужно разговаривать с самой фирмой RSA Data Security Inc. Я точно не знаю, но по слухам необходимо регистрировать сертификаты в ФСБ. Если кто обладает такой информацией, всегда буду рад узнать.

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




Узнаём стандартные папки Windows

Если не можете выйти из виндов, есть запасной выход:" Выдерни шнур, выдави стекло...".


 uses Registry;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   reg : TRegistry;
   ts : TStrings;
   i : integer;
 begin
   reg := TRegistry.Create;
   reg.RootKey := HKEY_CURRENT_USER;
   reg.LazyWrite := false;
   reg.OpenKey(
    'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
               false);
     ts := TStringList.Create;
     reg.GetValueNames(ts);
     for i := 0 to ts.Count -1 do begin
       Memo1.Lines.Add(ts.Strings[i] +
                       ' = ' +
                       reg.ReadString(ts.Strings[i]));
     end;
     ts.Free;
   reg.CloseKey;
   reg.free;
 end;
 




Окно в виде звезды


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


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ExtCtrls, jpeg;
 
 type
   TForm1 = class(TForm)
     Label1: TLabel; //Это метка для отображения времени
     Timer1: TTimer; //Это таймер - с помощью него мы отображаем время
     Image1: TImage; //Компонент Image - нужен для вывода рисунка на форме
     procedure FormCreate(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     {Для перемещения формы вне заголовка объявляем процедуру}
     procedure WMNCHitTest(var M:TWMNCHitTest);message wm_NCHitTest;
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 {Для перемещения формы вне заголовка описываем процедуру}
 procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
 begin
   inherited;
   if M.Result = htClient then
     M.Result := htCaption;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   hsWindowRegion, hsWindowRegion2: integer;
   p: array [0..11] of TPoint;
 begin
   p[0].x:=30; p[0].y:=40;
   p[1].x:=80; p[1].y:=70;
   p[2].x:=95; p[2].y:=20;
   p[3].x:=110; p[3].y:=70;
   p[4].x:=160; p[4].y:=40;
   p[5].x:=130; p[5].y:=85;
   p[6].x:=260; p[6].y:=230;
   p[7].x:=110; p[7].y:=100;
   p[8].x:=95; p[8].y:=200;
   p[9].x:=80; p[9].y:=100;
   p[10].x:=30; p[10].y:=130;
   p[11].x:=60; p[11].y:=85;
 
   hsWindowRegion:=CreatePolygonRgn(P,12,Alternate);
   hsWindowRegion2:=CreateEllipticRgn(50,50,140,120);
 
   CombineRgn(hsWindowRegion, hsWindowRegion, hsWindowRegion2, rgn_or);
   SetWindowRgn(Handle, hsWindowRegion, true);
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   Label1.Caption:=TimeToStr(Time);
 end;
 
 end.
 




Обработчик события OwnerDraw в компоненте StatusBar


 procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
 Panel: TStatusPanel; const Rect: TRect);
 begin
   with statusbar1.Canvas do
   begin
     Brush.Color := clRed;
     FillRect(Rect);
     TextOut(Rect.Left, Rect.Top, 'Панель '+IntToStr(Panel.Index));
   end;
 end;
 




Показ всплывающих подсказок в строке состояния

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

Шаг 1:

Расположите TStatusBar на всех формах, где вы хотите увидеть подсказки в строке состояния. Установите свойство SimplePanel в True и присвойте компоненту другое имя (я использую SBStatus). Смотри мой комментарий относительно имени, который я поместил в шаге 4.

Шаг 2:

Создайте необходимые подсказки в свойствах Hint. Не забудьте вставить '|', если вам необходим длинный текст.

Шаг 3:

Поместите следующую строку в обработчике события FormCreate вашей формы:


 Application.OnHint := DisplayHint;
 

Шаг 4:

Создайте эту процедуру. Пожалуйста обратите внимание на комментарии.


 procedure TFrmMain.DisplayHint(Sender: TObject);
 var
   Counter, NumComps: integer;
 begin
   with Screen.ActiveForm do
   begin
     NumComps := ControlCount - 1;
     for Counter := 0 to NumComps do
       {SBStatus - имя всех моих компонентов TStatusBar.
       При необходимости его можно изменить.}
       if (TControl(Controls[Counter]).Name = 'SBStatus') then
       begin
         if (Application.Hint = '') then
           {ConWorkingName - используемая константа.
           При необходимости ее можно изменить.}
           TStatusBar(Controls[Counter]).SimpleText := ConWorkingName
         else
           TStatusBar(Controls[Counter]).SimpleText := Application.Hint;
         break;
       end;
   end;
 end; {DisplayHint}
 

Не забудьте поместить 'Procedure DisplayHint(Sender: TObject) в секции Public.

Это все, что вы должны сделать. Если вы хотите придать такую функциональность другим формам, просто поместите на них TStatusBar и установите свойство Hint у необходимых компонентов. Я надеюсь это просто.




Показ всплывающих подсказок в строке состояния 2

Автор: Иваненко Фёдор Григорьевич

Пришло мне письмо:

...cовет за номером 000306 содержит интересную идею -- выводить Hint'ы не на основную форму, а на активную, я сам до этого не дошел... Но не совсем понятно, чем автору не понравился стандартный метод TForm.FindComponent, существующий со времен Delphi I ? С его использованием метод ShowHint выглядит попроще, да и работает не хуже:


 procedure TAnyForm.ShowHint;
 var
   C: TStatusBar;
 begin
   // ищем наш StatusBar1 на активной форме
   C := TStatusBar(Screen.ActiveForm.FindComponent('StatusBar1'));
   // если не найден -- ищем на основной форме
   if not Assigned(C) then
     C := TStatusBar(Application.MainForm.FindComponent('StatusBar1'));
   // если что-то обнаружено -- рисуем на н?м наш текст
   if Assigned(C) then
     C.SimpleText := '  ' + Application.Hint;
 end;
 

Желаю Вам всяческих успехов!




Установить размер шрифта для панели StatusBar


 With StatusBar1.Panels[1] do
 begin
   Text := Edit1.Text;
   Canvas.Font.Size := StatusBar1.Font.Size;
   Width := Canvas.TextWidth(Text) + 10;
 end;
 




Форма постоянно сверху приложения

Форма должна иметь нормальный стиль (normal style), необходимо лишь переписать процедуру CreateParams:


 procedure TFloatingToolbar.CreateParams( var Params: TCreateParams );
 begin
   inherited CreateParams( Params );
   with Params do
   begin
     Style := Style or ws_Overlapped;
     WndParent := MainForm.Handle;
   end;
 end;
 




Липкие окошки

Едет программист в такси. Вдруг машина останавливает и дальше ну никак не едет. Водитель и так, и эдак... Программист и советует: - А вы закройте лишние окна. Поможет...

В статье рассматривается приём создания обработчиков сообщений, которые позволяют форме при перетаскивании "прилипать" к краям экранной области.

Конечно же в Win API такой возможности не предусмотрено, поэтому мы воспользуемся сообщениями Windows. Как нам извесно, Delphi обрабатывает сообщения через события, генерируя его в тот момент, когда Windows посылает сообщений приложению. Однако некоторые сообщения не доходят до нас. Например, при изменении размеров формы, генерируется событие OnResize, соотвествующее сообщению WM_SIZE, но при перетаскивании формы никакой реакции не происходит. Конечно же форма может получить это сообщение, но изначально никаких действий для данного сообщения не предусмотрено.

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

Так же существует сообщение WM_WINDOWPOSCHANGING, которое посылается окну, в случае, если его размер, расположение или место в Z порядке собираются измениться, как результат вызова функции SetWindowPos либо другой функции управления окном.

Чаще всего с сообщением передаются дополнительные параметры, которые сообщают нам необходимую информацию. Например, сообщение WM_MOVE, указывающее на то, что форма изменила своё местоположение, так же передаёт в параметре LPARAM новые координаты X и Y.

Сообщение WM_WINDOWPOSCHANGING передаёт нам ТОЛЬКО один параметр - указатель на структуру WindowPos, которая содержит информацию о новом размере и местоположении окна. Вот как выглядит структура WindowPos:


 TWindowPos = packed record
   hwnd: HWND; {Identifies the window.}
   hwndInsertAfter: HWND; {Window above this one}
   x: Integer; {Left edge of the window}
   y: Integer; {Right edge of the window}
   cx: Integer; {Window width}
   cy: Integer; {Window height}
   flags: UINT; {Window-positioning options.}
 end;
 

Наша задача проста: нам необходима, чтобы форма прилипла к краю экрана, если она находится на определённом расстоянии от окна (допустим 20 пикселей).

Пример

К новой форме добавьте Label, один контрол Edit и четыре Check boxes. Измените имя контрола Edit на edStickAt. Измените имена чекбоксов на chkLeft, chkTop, и т.д... Для установки количества пикселей используем edStickAt, который будет использоваться для определения необходимого расстояния до края экрана достаточного для приклеивания формы.

Нас интересует только одно сообщение WM_WINDOWPOSCHANGING. Обработчик для данного сообщения будет объявлен в секции private. Ниже приведён полный код этого процедуры "прилипания" вместе с комментариями. Обратите внимание, что Вы можете предотвратить "прилипание" формы к определённому краю, путё снятия нужной галочки.

Для получения рабочей области декстопа (минус панель задач, панель Microsoft и т.д.), используем SystemParametersInfo, первый параметр которой SPI_GETWORKAREA.


 ...
 private
   procedure WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
   message WM_WINDOWPOSCHANGING;
 ...
 
 procedure TfrMain.WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
 const
   Docked: Boolean = FALSE;
 var
   rWorkArea: TRect;
   StickAt : Word;
 begin
   StickAt := StrToInt(edStickAt.Text);
 
   SystemParametersInfo(SPI_GETWORKAREA, 0, @rWorkArea, 0);
 
   with Msg.WindowPos^ do
   begin
     if chkLeft.Checked then
       if x <= rWorkArea.Left + StickAt then
       begin
         x := rWorkArea.Left;
         Docked := TRUE;
       end;
 
     if chkRight.Checked then
       if x + cx >= rWorkArea.Right - StickAt then
       begin
         x := rWorkArea.Right - cx;
         Docked := TRUE;
       end;
 
     if chkTop.Checked then
       if y <= rWorkArea.Top + StickAt then
       begin
         y := rWorkArea.Top;
         Docked := TRUE;
       end;
 
     if chkBottom.Checked then
       if y + cy >= rWorkArea.Bottom - StickAt then
       begin
         y := rWorkArea.Bottom - cy;
         Docked := TRUE;
       end;
 
     if Docked then
     begin
       with rWorkArea do
       begin
         // не должна вылезать за пределы экрана
         if x < Left then
           x := Left;
         if x + cx > Right then
           x := Right - cx;
         if y < Top then
           y := Top;
         if y + cy > Bottom then
           y := Bottom - cy;
       end; {ширина rWorkArea}
     end;
   end; {с Msg.WindowPos^}
 
   inherited;
 end;
 
 end.
 

Теперь достаточно запустить проект и перетащить форму к любому краю экрана.

Вот собственно и всё.

Комментарии:

Автор: Nashev

а так короче... И, ИМХО, лучше:


 procedure TCustomGlueForm.WMWindowPosChanging1(var Msg: TWMWindowPosChanging);
 var
   WorkArea: TRect;
   StickAt : Word;
 begin
   StickAt := 10;
   SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
   with WorkArea, Msg.WindowPos^ do
   begin
     // Сдвигаем границы для сравнения с левой и верхней сторонами
     Right:=Right-cx;
     Bottom:=Bottom-cy;
     if abs(Left - x) <= StickAt then
       x := Left;
     if abs(Right - x) <= StickAt then
       x := Right;
     if abs(Top - y) <= StickAt then
       y := Top;
     if abs(Bottom - y) <= StickAt then
       y := Bottom;
   end;
   inherited;
 end;
 

В проекте осталось 2 глюка:

  1. Если у формы, к которой прицепили другую форму за правую/нижнюю границы попробовать переместить эти границы, прицепленная форма останется на месте но все равно будет прикрепленной.
  2. Иногда 3 формы прикрепляются друг к другу, и иначе, как воспользовавшись 1-ым глюком, их не расцепить.

Для использования сделанного в своих проектах надо добавить в проект, и свои формы создавать, наследуя от него, например, через мастер "File/New..."

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


 procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging);
 message WM_WINDOWPOSCHANGING;
 

и все переменные, а в самом WMWindowPosChanging удалить все упоминания этих переменных.




Как склеить несколько файлов в один и наоборот (работа с TStream)

Лучший метод сжатия файлов: "DEL *.*" - 100% сжатие.

Как-то раз понадобилось запихнуть много файлов в один поток(stream), так как необходимо было отправить их как один файл. Вот, что для этого было сделано:


 Procedure TForm1.ThisISHowIPutFilesIn ;
 var
   ABigFileStream, SomeSmallFiles : TMemoryStream ;
 
 begin
   ABigFileStream := TMemoryStream.Create ;
   try
     SomeSmallFiles := TMemoryStream.Create ;
      try
       SomeSmallFiles.LoadFromFile('C:\SomeSmalFile1.txt');
       AddToStream(SomeSmallFiles,ABigFileStream);
       SomeSmallFiles.LoadFromFile('C:\SomeSmalFile2.txt');
       AddToStream(SomeSmallFiles,ABigFileStream);
       // enz 
      finally
       SomeSmallFiles.Free ;
      end;
   ABigFileStream.SaveToFile('C:\MrBig.DDD')
   finally
   ABigFileStream.free ;
   end;
 end;
 
 Procedure TForm1.ThisISHowIGetStufOut ;
 var
   ABigFileStream, SomeSmallFiles : TMemoryStream ;
 
 begin
   ABigFileStream := TMemoryStream.Create ;
   try
     ABigFileStream.LoadFromFile('C:\MrBig.DDD');
     SomeSmallFiles := TMemoryStream.Create ;
      try
       GetFromStream(ABigFileStream,SomeSmallFiles,0);
       SomeSmallFiles.SaveToFile('C:\SomeSmalFile1.txt');
       GetFromStream(ABigFileStream,SomeSmallFiles,1);
       SomeSmallFiles.SaveToFile('C:\SomeSmalFile2.txt');
       // и т.д.
      finally
       SomeSmallFiles.Free ;
      end;
   finally
   ABigFileStream.free ;
   end;
 end;
 
 Procedure TForm1.AddToStream ( Source , Dest : TStream );
 var
 Size : Integer ;
 begin
 Source.position := 0 ;
 // Сохраняем размер, помещая его в первый байт
 Size := Source.Size ;
 Dest.Write(Size,SizeOf(Integer));
 Dest.CopyFrom(Source,Source.size);
 end;
 
 Procedure TForm1.GetFromStream ( Source , Dest : TStream ; Index : Integer  );
 Var
   Size , I : Integer ;
 
 begin
 Source.Position := 0 ;
 For i := 0 to index-1 do
    begin
      Source.Read(Size,SizeOf(Integer));
      Source.Position := Source.Position + Size ;
    end;
 // Если марк¸р в файле равен размеру, то что-то пошло не так :(
 if Source.position = Source.Size then
   Raise EAccessViolation.Create('Index Out Of Bounds') ;
 // Получаем желаемый размер файла
 Source.Read(Size,SizeOf(Integer));
 // Очищаем буфер у Dest
 Dest.Position := 0 ;
 Dest.Size := 0 ;
 Dest.CopyFrom(Source,Size);
 end;
 




Остановка и запуск сервисов

Автор: Postmaster

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

Unit1.dfm


 object Form1: TForm1
   Left = 192
     Top = 107
     Width = 264
     Height = 121
     Caption = 'Сервис'
     Color = clBtnFace
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     OldCreateOrder = False
     PixelsPerInch = 96
     TextHeight = 13
     object Label1: TLabel
     Left = 2
       Top = 8
       Width = 67
       Height = 13
       Caption = 'Имя сервиса'
   end
   object Button1: TButton
     Left = 4
       Top = 56
       Width = 95
       Height = 25
       Caption = 'Стоп сервис'
       TabOrder = 0
       OnClick = Button1Click
   end
   object Button2: TButton
     Left = 148
       Top = 56
       Width = 95
       Height = 25
       Caption = 'Старт сервис'
       TabOrder = 1
       OnClick = Button2Click
   end
   object Edit1: TEdit
     Left = 0
       Top = 24
       Width = 241
       Height = 21
       TabOrder = 2
       Text = 'Messenger'
   end
 end
 

Unit1.pas


 unit Unit1;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Winsvc;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     Edit1: TEdit;
     Label1: TLabel;
     procedure Button1Click(Sender: TObject);
     procedure StopService(ServiceName: string);
     procedure Button2Click(Sender: TObject);
     procedure StartService(ServiceName: string);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   StopService(Edit1.Text);
 end;
 
 procedure TForm1.StopService(ServiceName: string);
 var
 
   schService,
     schSCManager: DWORD;
   p: PChar;
   ss: _SERVICE_STATUS;
 begin
 
   p := nil;
   schSCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
   if schSCManager = 0 then
     RaiseLastWin32Error;
   try
     schService := OpenService(schSCManager, PChar(ServiceName),
       SERVICE_ALL_ACCESS);
     if schService = 0 then
       RaiseLastWin32Error;
     try
       if not ControlService(schService, SERVICE_CONTROL_STOP, SS) then
         RaiseLastWin32Error;
     finally
       CloseServiceHandle(schService);
     end;
   finally
     CloseServiceHandle(schSCManager);
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   StartService(Edit1.Text);
 end;
 
 procedure TForm1.StartService(ServiceName: string);
 var
 
   schService,
     schSCManager: Dword;
   p: PChar;
 begin
 
   p := nil;
   schSCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
   if schSCManager = 0 then
     RaiseLastWin32Error;
   try
     schService := OpenService(schSCManager, PChar(ServiceName),
       SERVICE_ALL_ACCESS);
     if schService = 0 then
       RaiseLastWin32Error;
     try
       if not Winsvc.startService(schService, 0, p) then
         RaiseLastWin32Error;
     finally
       CloseServiceHandle(schService);
     end;
   finally
     CloseServiceHandle(schSCManager);
   end;
 end;
 
 end.
 




Приостановить работу программы

- После того как на МИГ-29 установили операционную систему Windows 2000, он совершил невероятную фигуру высшего пилотажа.
- И какую же?
- Он ЗАВИС!!!

Используйте Sleep(Milliseconds). Программа перестает работать на указанное в скобках количество тысячных секунд. Погрешность на моем компьютере, а он не старый, до 10 мсек. При этом способе ничего не происходит, даже перерисовка. Чтобы этого избежать можно использовать другой способ.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   t: integer;
 begin
   t := GetTickCount;
   repeat
     Application.ProcessMessages
   until
     GetTickCount - t >= 1000;
   Button1.Caption := Button1.Caption + '1';
 end;
 




Как остановить автодобавление из DBGrid


Программист обиделся, что о нем анекдот про 2 стакана сочинили (ну, вы знаете). Жалуется системному программисту. А тот задумался и говорит:
- Нет, 2-х стаканов недостаточно. Нужно 4.
- ???
- Системное резервирование.

Добавьте в событие "BeforeInsert" Вашего TTables следующие строки:


 procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset);
 begin
   Abort;
 end;
 

или


 procedure TForm8.DBGrid1KeyDown(Sender: TObject;
 var Key: Word; Shift: TShiftState);
 begin
   if (Key = VK_DOWN) then
   begin
     TTable1.DisableControls;
     TTable1Next;
     if TTable1.EOF then
       Key := 0
     else
       TTable1.Prior;
     TTable1.EnableControls;
   end;
 end;
 




Остановить длинное действие

Вовочкa: -Пaпa, a что тaкое клитор?
Пaпa,не отрывaясь от компa:
- Язык прогрaммировaния. Рaботaет с фaйлaми DBF формaтa.

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


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   randomize;
   repeat
     Form1.Canvas.Pixels[random(Form1.ClientWidth),
     random(Form1.ClientHeight)] :=
     RGB(random(255),random(255),random(255));
     Application.ProcessMessages;
   until
     Application.Terminated;
 end;
 

Эта программа останавливается при нажатии на Button2


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   randomize;
   Form1.Tag := 0;
   repeat
     Form1.Canvas.Pixels[random(Form1.ClientWidth),
     random(Form1.ClientHeight)] :=
     RGB(random(255),random(255),random(255));
     Application.ProcessMessages;
   until
     Form1.Tag > 0;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   Form1.Tag := 1;
 end;
 




Проблемы StoredProc у SQL server

Автор: David Gecawich

Обнаруженная мною проблема заключается в ненормальной работе BDE с TStoredProc, когда хранимая процедура SQL получает на входе параметр типа String. Как я понял, BDE/SQL Links перед вызовом хранимой процедуры заносит в строку управляющие символы. Чтобы обойти эту проблему, Borland предлагает использовать TQuery. Конечно, ничего не стоит перевести TStoredProcs в TQuerys (с сохранением полного набора характеристик и без потери скорости), но мне стала интересна причина такого поведения компонента, и я решил покопаться в TStoredProc насколько это было мне возможно и интересно, для чего я добавил дополнительный параметр к хранимой процедуре, позволяющий указывать длину передаваемой процедуре строки. Затем, уже в процедуре, если реальная длина строки оказывалась больше, с помощью дополнительно передаваемого параметра бралась, и в дальнейшем использовалась только левая часть строки, а остальные управляющие символы игнорировались.

Вот пример:

Приведенная ниже процедура SQL Server возвращает 1 если таблица существует, и 2 в противном случае.

 CREATE PROCEDURE up_TableExists
   ( @TableName varchar(50), @TableNameLen int = null)
 AS
   declare @CleanTblName varchar(50)
   if @TableNameLen is not null
     select @CleanTblName = SubString(@TableName,1,@TableNameLen)
   else
     select @CleanTblName = @TableName
   if EXISTS (SELECT name FROM sysobjects WHERE name = @CleanTblName)
     RETURN 1
   else
     RETURN 2
Поехали...

В Delphi, прежде чем вызвать ExecProc, установите параметр длины строки... вот пример вызова хранимой процедуры в Delphi...


 var
   sTableName: string;
   rc: Boolean;
 begin
   ...
   sTableName := 'MyTable';
   with StoredProc1 do
   begin
     ...
       ParamByName('@TableName').AsString := sTableName;
     { обход проблемы: передаем длину строки SQL Server для
     обработки хранимой процедурой }
     ParamByName('@TableNameLen').AsInteger := Length(sTableName);
     Prepare;
     ExecProc;
     rc := ParamByName('Result').AsInteger = 1; {rc True если result = 1}
     if rc then
       ....
   end;
 end;
 




StrAlloc и GetMem

StrAlloc непосредственно использует GetMem, поэтому обе функции живут за счет Кучи. StrAlloc имеет преимущество: он распределяет на два байта больше, чем вы просите и там хранит размер размещенного блока. Поэтому StrDispose знает сколько памяти освободить и вы можете этого не помнить (в отличие от GetMem/FreeMem). Не смешивайте при работе эти две функциональные пары, иначе вы будете потрясены количеством возникающих ошибок!




Сохранение и загрузка формы с компонентами потоком



 unit InfoForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
   Dbctrls, Dbgrids, Dblookup, Dbtables, Ddeman, Dialogs,
   Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
   Olectrls, Outline, Tabnotbk, Tabs;
 
 type
   TMainForm = class(TForm)
     Panel1: TPanel;
     ComboBox1: TComboBox;
     Label1: TLabel;
     Label2: TLabel;
     ComboBox2: TComboBox;
     SpeedSaveForm: TSpeedButton;
     SpeedText: TSpeedButton;
     SpeedLoadForm: TSpeedButton;
     SpeedSavePas: TSpeedButton;
     OpenDialog1: TOpenDialog;
     SaveDialog1: TSaveDialog;
     procedure FormCreate(Sender: TObject);
     procedure SpeedSaveFormClick(Sender: TObject);
     procedure SpeedLoadFormClick(Sender: TObject);
     procedure SpeedSavePasClick(Sender: TObject);
     procedure SpeedTextClick(Sender: TObject);
   public
     function GetNextName (MyClass: TComponentClass): string;
     procedure UpdateList;
   end;
 
 var
   MainForm: TMainForm;
 
 implementation
 
 {$R *.DFM}
 
 uses
   OutForm, MemoF;
 
 type
   TClassArray = array [1..107] of TPersistentClass;
 
   // definition temporary used to check the data types
   //  TClassArray = array [1..107] of TComponentClass;
 
 const
   ClassArray: TClassArray = (
     TApplication, TDDEServerItem, TPanel, TAutoIncField,
     TDirectoryListBox, TPopupMenu, TBatchMove, TDrawGrid,
     TPrintDialog, TBCDField, TDriveComboBox, TPrinterSetupDialog,
     TBevel, TEdit, TProgressBar, TBitBtn,
     TField, TQuery, TBlobField, TFileListBox,
     TRadioButton, TBooleanField, TFilterComboBox, TRadioGroup,
     TButton, TFindDialog, TReplaceDialog, TBytesField,
     TFloatField, TCheckBox, TFontDialog,
     TRichEdit, TColorDialog, TForm, TSaveDialog,
     TComboBox, TGraphicField, TScreen, TCurrencyField,
     TGroupBox, TScrollBar, TDatabase, THeader,
     TScrollBox, TDataSource, THeaderControl, TSession,
     TDateField, THotKey, TShape, TDateTimeField,
     TImage, TSmallIntField, TDBCheckBox, TImageList,
     TSpeedButton, TDBComboBox, TIntegerField, TStatusBar,
     TDBCtrlGrid, TLabel, TStoredProc, TDBEdit,
     TListBox, TStringField, TDBGrid, TListView,
     TStringGrid, TDBImage, TMainMenu, TTabbedNotebook,
     TDBListBox, TMaskEdit, TTabControl, TDBLookupCombo,
     TMediaPlayer, TTable, TMemoField, TDBLookupComboBox,
     TMemo, TTabSet, TDBLookupList, TTabSheet,
     TDBLookupListBox, TMenuItem, TTimeField, TDBMemo,
     TNotebook, TDBNavigator, TOleContainer, TTimer,
     TDBRadioGroup, TOpenDialog, TTrackBar, TDBText,
     TOutline, TTreeView, TDDEClientConv, TOutline,
     TUpdateSQL, TDDEClientItem, TPageControl, TUpDown,
     TDDEServerConv, TPaintBox, TVarBytesField, TWordField);
 
 procedure TMainForm.FormCreate(Sender: TObject);
 var
   I: Integer;
 begin
   // register all of the classes
   RegisterClasses (Slice (ClassArray, High (ClassArray)));
   // copy class names to the listbox
   for I := Low (ClassArray) to High (ClassArray) do
     ComboBox1.Items.Add (ClassArray [I].ClassName);
 end;
 
 function TMainForm.GetNextName (MyClass: TComponentClass): string;
 var
   I, nTot: Integer;
 begin
   nTot := 0;
   with OutputForm do
   begin
     for I := 0 to ComponentCount - 1 do
       if Components [I].ClassType = MyClass then
         Inc (nTot);
     Result := Copy (MyClass.ClassName, 2, Length (MyClass.ClassName) - 1) +
       IntToStr (nTot);
   end;
 end;
 
 procedure TMainForm.UpdateList;
 var
   I: Integer;
 begin
   Combobox2.Items.Clear;
   with OutputForm do
     for I := 0 to ComponentCount - 1 do
       ComboBox2.Items.Add (Components [I].Name);
 end;
 
 procedure TMainForm.SpeedSaveFormClick(Sender: TObject);
 var
   Str1 : TFileStream;
 begin
   if SaveDialog1.Execute then
   begin
     Str1 := TFileStream.Create (SaveDialog1.FileName,
       fmOpenWrite or fmCreate);
     try
       // disable the event
       OutputForm.OnMouseDown := nil;
       Str1.WriteComponentRes (
         OutputForm.ClassName, OutputForm);
     finally
       Str1.Free;
       OutputForm.OnMouseDown := OutputForm.FormMouseDown;
     end;
   end;
 end;
 
 procedure TMainForm.SpeedLoadFormClick(Sender: TObject);
 var
   Str1: TFileStream;
   TempForm1: TOutputForm;
 begin
   if OpenDialog1.Execute then
   begin
     Str1 := TFileStream.Create (OpenDialog1.FileName,
       fmOpenRead);
     try
       TempForm1 := TOutputForm.Create (Application);
       Str1.ReadComponentRes (TempForm1);
       OutputForm.Free;
       OutputForm := TempForm1;
       OutputForm.Show;
       OutputForm.OnMouseDown := OutputForm.FormMouseDown;
     finally
       Str1.Free;
     end;
   end;
 end;
 
 procedure TMainForm.SpeedSavePasClick(Sender: TObject);
 var
   File1 : TextFile;
   FileName: string;
   I: Integer;
 begin
   // save the DFM file
   SpeedSaveFormClick (self);
   // change extension (using the proper VCL routine)
   FileName := SaveDialog1.FileName;
   FileName := ChangeFileExt (FileName, '.pas');
   AssignFile (File1, FileName);
   try
     // create the pascal file...
     Rewrite (File1);
     FileName := ChangeFileExt (FileName, '');
     Writeln (File1, 'unit ' + ExtractFileName (FileName) + ';');
     Writeln (File1, '');
     Writeln (File1, 'interface');
     Writeln (File1, '');
     Writeln (File1, 'uses');
     Writeln (File1, '  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,');
     Writeln (File1, '  StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,');
     Writeln (File1, '  Dbctrls, Dbgrids, Dblookup, Dbtables, Ddeman, Dialogs,');
     Writeln (File1, '  Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,');
     Writeln (File1, '  Olectrls, Outline, Tabnotbk, Tabs;');
     Writeln (File1, '');
     Writeln (File1, 'type');
     Writeln (File1, '  TOutputForm = class(TForm)');
     // add components declarations
     for I := 0 to OutputForm.ComponentCount - 1 do
     begin
       Writeln (File1, '    ' +
         OutputForm.Components[I].Name + ': ' +
         OutputForm.Components[I].ClassName + ';');
     end;
     Writeln (File1, '  private');
     Writeln (File1, '    { Private declarations }');
     Writeln (File1, '  public');
     Writeln (File1, '    { Public declarations }');
     Writeln (File1, '  end;');
     Writeln (File1, '');
     Writeln (File1, 'var');
     Writeln (File1, '  OutputForm: TOutputForm;');
     Writeln (File1, '');
     Writeln (File1, 'implementation');
     Writeln (File1, '');
     Writeln (File1, '{$R *.DFM}');
     Writeln (File1, '');
     Writeln (File1, 'end.');
   finally
     CloseFile (File1);
   end;
 end;
 
 procedure TMainForm.SpeedTextClick(Sender: TObject);
 var
   StrBin, StrTxt: TMemoryStream;
 begin
   StrBin := TMemoryStream.Create;
   StrTxt := TMemoryStream.Create;
   try
     OutputForm.OnMouseDown := nil;
     // write the form to a memory stream
     StrBin.WriteComponentRes (
       OutputForm.ClassName, OutputForm);
     // go back to the beginning
     StrBin.Seek (0, soFromBeginning);
     // convert the form to text
     ObjectResourceToText (StrBin, StrTxt);
     // go back to the beginning
     StrTxt.Seek (0, soFromBeginning);
     // load the text
     FormMemo.Memo1.Lines.LoadFromStream (StrTxt);
     FormMemo.ShowModal;
   finally
     StrBin.Free;
     StrTxt.Free;
     OutputForm.OnMouseDown := OutputForm.FormMouseDown;
   end;
 end;
 
 end.


 unit MemoF;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Buttons, ExtCtrls;
 
 type
   TFormMemo = class(TForm)
     Memo1: TMemo;
     BitBtn1: TBitBtn;
     Panel1: TPanel;
     BitBtn2: TBitBtn;
     procedure FormResize(Sender: TObject);
     procedure BitBtn2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   FormMemo: TFormMemo;
 
 implementation
 
 uses OutForm;
 
 {$R *.DFM}
 
 procedure TFormMemo.FormResize(Sender: TObject);
 begin
   // approximately in the middle
   BitBtn1.Left := Panel1.Width div 2 - BitBtn1.Width - 5;
   BitBtn2.Left := Panel1.Width div 2 + 5;
 end;
 
 procedure TFormMemo.BitBtn2Click(Sender: TObject);
 var
   StrBin, StrTxt: TMemoryStream;
   TempForm1: TOutputForm;
 begin
   StrBin := TMemoryStream.Create;
   StrTxt := TMemoryStream.Create;
   // copy the text of the memo
   Memo1.Lines.SaveToStream (StrTxt);
   // go back to the beginning
   StrTxt.Seek (0, soFromBeginning);
   try
     // convert to binary
     ObjectTextToResource (StrTxt, StrBin);
     // go back to the beginning
     StrBin.Seek (0, soFromBeginning);
     // loading code...
     TempForm1 := TOutputForm.Create (Application);
     StrBin.ReadComponentRes (TempForm1);
     OutputForm.Free;
     OutputForm := TempForm1;
     OutputForm.Show;
     // close the memo form
     ModalResult := mrOk;
   except
     on E: Exception do
     begin
       E.Message :=
         'Error converting form'#13#13 +
         '(' + E.MEssage + ')';
       Application.ShowException (E);
     end;
   end;
 end;
 
 end.


 unit OutForm;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 
 type
   TOutputForm = class(TForm)
     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   OutputForm: TOutputForm;
 
 implementation
 
 {$R *.DFM}
 
 uses
   InfoForm;
 
 procedure TOutputForm.FormMouseDown (
   Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 var
   MyClass: TComponentClass;
   MyComp: TComponent;
 begin
   MyClass := TComponentClass (
     GetClass (MainForm.ComboBox1.Text));
   if MyClass = nil then
     Beep
   else
   begin
     MyComp := MyClass.Create (self);
     MyComp.Name := MainForm.GetNextName (MyClass);
     if MyClass.InheritsFrom (TControl) then
     begin
       TControl (MyComp).Left := X;
       TControl (MyComp).Top := Y;
       TControl (MyComp).Parent := self;
     end;
   end;
   MainForm.UpdateList;
 end;
 
 initialization
   RegisterClass (TOutputForm);
 end.

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




Растягивание иконки

Автор: Bill

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

Пример кода:


 procedure TForm1.StringGrid1Click(Sender: TObject);
 begin
   Image1.Canvas.FillRect(Image1.Canvas.ClipRect);
   Image1.Canvas.Draw(0, 0,
   TIcon(StringGrid1.Objects
   [StringGrid1.Col, StringGrid1.Row]));
   Form2.Image1.Picture := Image1.Picture;
 end;
 {Примечание. Form2.Image1 имеет Stretch установленный
 в True и размер, бОльший размера иконки в 4 раза}
 

Дополнение

Андрей Бреслав пишет:

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Bmp: TBitMap;
 begin
   Bmp:= TBitMap.Create;
   Bmp.Height:= GetSystemMetrics(SM_CYICON);
   Bmp.Width:= GetSystemMetrics(SM_CXICON);
   Bmp.Canvas.Draw(0,0, Image1.Picture.Icon);
   Image1.Picture.Bitmap:= Bmp;
   Bmp.Free;
 end;
 

Есть более человечный способ, чем просто рисовать в Image: функция DrawIconEx Win32 API:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   DrawIconEx(Canvas.Handle, 5, 5, LoadIcon(0, IDI_APPLICATION),
     16, 32, 0, 0, DI_NORMAL);
 end;
 

Кстати, думаю, людям будет полезно знать по подробнее о DrawIconEx: Рисует иконку или курсор в соответствии с заданными занчениями.


 function DrawIconEx(hdc: HDC; xLeft, yTop: Integer; hIcon: HICON;
   cxWidth, cyWidth: Integer; istepIfAniCur: UINT;
   hbrFlickerFreeDraw: HBRUSH; diFlags: UINT): BOOL; stdcall;
 

hdc - контекст устройства (TCanvas.Handle)
   xLeft, yTop - координаты левого верхнего угла
   hIcon - дескриптор объекта Windows - Icon
   cxWidth, cyWidth - размеры
   istepIfAniCur - (!) номер отображаемого кадра в анимированном курсоре
   hbrFlickerFreeDraw - кисть
   diFlags - сумма след. занчений:
 
 DI_COMPAT - буду благодарен, если объясните
 DI_DEFAULTSIZE - если cxWidth, cyWidth равны 0, рисует в default размере
 DI_IMAGE - применяет одну часть кисти
 DI_MASK - применяет другую часть кисти
 DI_NORMAL = DI_IMAGE and DI_MASK - применяет обе части кисти



Растягивание изображения при печати

Я пишу программу, которая печатает изображение на принтере с помощью объекта TPrinter. Проблема происходит когда я пытаюсь "растянуть" изображение до требуемого размера на бумаге. Мой метод растяжения (bitblts и принтерном DC) приводит к белым кляксам, а само изображение получается практически серым. Конечно это не то, что мне хотелось. Кто-нибудь может мне помочь?

Попробуй это:


 procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap:
   TBitmap);
 var
   Header, Bits: Pointer;
   HeaderSize: Integer;
   BitsSize: Longint;
 begin
   GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
   Header := MemAlloc(HeaderSize);
   Bits := MemAlloc(BitsSize);
   try
     GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
     StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
       DestRect.Right, DestRect.Bottom,
       0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
       DIB_RGB_COLORS, SRCCOPY);
     { вам может понадобиться цветовой стандарт DIB_PAL_COLORS,
     но это уже выходит за рамки моих знаний. }
   finally
     MemFree(Header, HeaderSize);
     MemFree(Bits, BitsSize);
   end;
 end;
 
 { Печатаем изображение, растягивая его до целого листа }
 
 procedure PrintBitmap(ABitmap: TBitmap);
 var
   relheight, relwidth: integer;
 begin
   screen.cursor := crHourglass;
   Printer.BeginDoc;
   if ((ABitmap.width / ABitmap.height) > l(printer.pagewidth /
     printer.pageheight)) then
   begin
     { Растягиваем ширину изображения до ширины бумаги }
     relwidth := printer.pagewidth;
     relheight := MulDiv(ABitmap.height, printer.pagewidth, ABitmap.width);
   end
   else
   begin
     { Растягиваем высоту изображения до высоты бумаги }
     relwidth := MulDiv(ABitmap.width, printer.pageheight, ABitmap.height);
     relheight := printer.pageheight;
   end;
   DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), ABitmap);
   Printer.EndDoc;
   screen.cursor := crDefault;
 end;
 




Авторазмер для StringGrid

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


 var
   i, j, temp, max: integer;
 begin
   for i := 0 to grid.colcount - 1 do
   begin
     max := 0;
     for j := 0 to grid.rowcount - 1 do
     begin
       temp := grid.canvas.textWidth(grid.cells[i, j]);
       if temp > max then
         max := temp;
     end;
     grid.colWidths[i] := max + grid.gridLineWidth + 1;
   end;
 end;
 

Вероятно, вам необходимо будет добавить +1, чтобы текст не прилипал к границам ячеек.




В StringGrid ширина колонки подгоняется под длину самой длинной строки

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


 var
   x, y, w: integer;
   s: string;
   MaxWidth: integer;
 begin
   with StringGrid1 do
     ClientHeight := DefaultRowHeight * RowCount + 5;
     with StringGrid1 do
     begin
       for x := 0 to ColCount - 1 do
       begin
         MaxWidth := 0;
         for y := 0 to RowCount - 1 do
         begin
           w := Canvas.TextWidth(Cells[x,y]);
           if w > MaxWidth then
             MaxWidth := w;
         end;
         ColWidths[x] := MaxWidth + 5;
       end;
     end;
 end;
 




Выравнивание колонок StringGrid

Автор: Kurt

Два программиста едут в переполненном автобусе. Один - другому:
- Что то у меня с писюком! (толпа замирает)
- А что с ним?
- Да висит часто...
- Может вирус какой?
- Да проверял, все стерильно...
- А висит хорошо?
- Крепко, тремя пальцами не поможешь...

Организуйте обработчик события сетки OnDrawCell. Создайте код обработчика подобный этому:


 procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
   Rect: TRect; State: TGridDrawState);
 var
   Txt: array[0..255] of Char;
 begin
   StrPCopy(Txt, StringGrid1.Cells[Col, Row]);
   SetTextAlign(StringGrid1.Canvas.Handle,
     GetTextAlign(StringGrid1.Canvas.Handle)
     and not (TA_LEFT or TA_CENTER) or TA_RIGHT);
   ExtTextOut(StringGrid1.Canvas.Handle, Rect.Right - 2, Rect.Top + 2,
     ETO_CLIPPED or ETO_OPAQUE, @Rect, Txt, StrLen(Txt), nil);
 end;
 

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

Успехов.




Выравнивание колонок StringGrid 2

Нижеприведенный код выравняет данные компонента по правому краю:


 procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row:
   Longint; Rect: TRect; State: TGridDrawState);
 var
   lRow, lCol: Longint;
 begin
   lRow := Row;
   lCol := Col;
   with Sender as TStringGrid, Canvas do
   begin
     if (gdSelected in State) then
     begin
       Brush.Color := clHighlight;
     end
     else if (gdFixed in State) then
     begin
       Brush.Color := FixedColor;
     end
     else
     begin
       Brush.Color := Color;
     end;
     FillRect(Rect);
     SetBkMode(Handle, TRANSPARENT);
     SetTextAlign(Handle, TA_RIGHT);
     TextOut(Rect.Right - 2, Rect.Top + 2, Cells[lCol, lRow]);
   end;
 end;
 

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

Вы наверное уже обратили внимание на объявление локальных переменных lCol и lRow. На входе я присваиваю им значения параметров Col и Row (имя, которое дало мне Delphi IDE). Дело в том, что объект TStringGrid имеет свойства с именами Col и Row. Эти свойства будут доступны в теле блока "with Sender as TStringGrid", но они не являются параметрами для всех обявленных в шапке блока объектов ((речь идет об объекте Canvas, у которого нет свойств с именами Col и Row - В.О.)).




Выравнивание колонок StringGrid 3

Вот некоторый код, который делает то, что вы хотите:


 procedure WriteText(ACanvas: TCanvas; const ARect: TRect; DX, DY: Integer;
   const Text: string; Format: Word);
 var
   S: array[0..255] of Char;
   B, R: TRect;
 begin
   with ACanvas, ARect do
   begin
     case Format of
       DT_LEFT: ExtTextOut(Handle, Left + DX, Top + DY, ETO_OPAQUE or
         ETO_CLIPPED,
           @ARect, StrPCopy(S, Text), Length(Text), nil);
 
       DT_RIGHT: ExtTextOut(Handle, Right - TextWidth(Text) - 3, Top + DY,
           ETO_OPAQUE or ETO_CLIPPED, @ARect, StrPCopy(S, Text),
           Length(Text), nil);
 
       DT_CENTER: ExtTextOut(Handle, Left + (Right - Left - TextWidth(Text)) div
         2,
           Top + DY, ETO_OPAQUE or ETO_CLIPPED, @ARect,
           StrPCopy(S, Text), Length(Text), nil);
     end;
   end;
 end;
 
 procedure TBEFStringGrid.DrawCell(Col, Row: Longint; Rect: TRect; State:
   TGridDrawState);
 var
   procedure Display(const S: string; Alignment: TAlignment);
   const
     Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
   begin
     WriteText(Canvas, Rect, 2, 2, S, Formats[Alignment]);
   end;
 begin
   { здесь задаем аргументы Col и Row, и форматируем как угодно ячейки }
   case Row of
     0: { Центрирование заголовков колонок }
       if (Col < ColCount) then
         Display(Cells[Col, Row], taCenter)
       else
         { Все другие данные имеют правое центрирование }
         Display(Cells[Col, Row], taRight);
   end;
 end;
 




Выравнивание колонок StringGrid 4

Создайте ваш собственный метод drawcell на примере того, что приведен ниже:


 procedure Tsearchfrm.Grid1DrawCell(Sender: TObject; Col, Row: Longint;
   Rect: TRect; State: TGridDrawState);
 var
   l_oldalign: word;
 begin
   if (row = 0) or (col < 2) then
     {устанавливаем заголовок в жирном начертании}
     grid1.canvas.font.style := grid1.canvas.font.style + [fsbold];
 
   if col <> 1 then
   begin
     l_oldalign := settextalign(grid1.canvas.handle, ta_right);
     {NB использует для рисования правую сторону квадрата}
     grid1.canvas.textrect(rect, rect.right - 2, Rect.top + 2, grid1.cells[col,
       row]);
     settextalign(grid1.canvas.handle, l_oldalign);
   end
   else
   begin
     grid1.canvas.textrect(rect, rect.left + 2, rect.top + 2, grid1.cells[col,
       row]);
   end;
 
   grid1.canvas.font.style := grid1.canvas.font.style - [fsbold];
 end;
 




Выравнивание колонок StringGrid 5

Автор: Pavel Stont


 {
 Код компонента для Delphi на основе стандартного TStringGrid.
 
 Компонет позволяет переносить текст в TStringGrid.
 
 В качестве исходного текста был использован компонент TWrapGrid.
 Автор Luis J. de la Rosa.
 E-mail: delarosa@ix.netcom.com
 Вы свободны в использовании, распространении и улучшении кода.
 Пожалуйста шлите любые комментарии и пожелания на адрес delarosa@ix.netcom.com.
 
 Далее были внесены изменения в исходный код, а именно добавлены методы вывода
 текста:
 1. atLeft - Вывод текста по левой границе;
 2. atCenter - Вывод текста по центру ячейки (по горизонтали);
 3. atRight - Вывод текста по правой границе;
 4. atWrapTop - Вывод и перенос текста по словам относительно верхней границы
 ячейки;
 5. atWrapCenter - Вывод и перенос текста по словам относительно центра ячейки
 (по вертикали);
 6. atWrapBottom - Вывод и перенос текста по словам относительно нижней границы
 ячейки;
 
 Вносил изменения и тестировал в Delphi 3/4/5:
 Автор Pavel Stont.
 E-mail: pavel_stont@mail.ru.
 Никаких ограничений на использование, распростанение и улучшение кода не налогаются.
 Буду очень признателен, если о всех замеченных неполадках сообщите по e-mail.
 
 Для использования:
 Выберите в Delphi пункты меню 'Options' - 'Install Components'.
 Нажмите 'Add'.
 Найдите и выберите файл с именем 'NewStringGrid.pas'.
 Нажмите 'OK'.
 После этого вы увидете компонент во вкладке "Other" палитры компонентов
 Delphi.
 После этого вы можете использовать компонент вместо стандартного TStringGrid.
 
 Успехов!
 
 Несколько дополнительных замечаний по коду:
 1. Методы Create и DrawCell были перекрыты.
 2. Введены два новых свойства, а именно AlignText и AlignCaption соответсвенно методы
 выравнивания текста в ячейках данных (обычно - белого цвета) и в фиксированных ячейках
 (обычно - серого цвета).
 3. Свойство Center - центрация текста по горизонтали независимо от метода.
 }
 
 unit NewStringGrid;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   Grids;
 
 type
 
   TAlignText = (atLeft, atCenter, atRight, atWrapTop, atWrapCenter,
     atWrapBottom);
 
 type
 
   TNewStringGrid = class(TStringGrid)
   private
     { Private declarations }
     FAlignText: TAlignText;
     FAlignCaption: TAlignText;
     FCenter: Boolean;
     procedure SetAlignText(Value: TAlignText);
     procedure SetAlignCaption(Value: TAlignText);
     procedure SetCenter(Value: Boolean);
   protected
     { Protected declarations }
     procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
       AState: TGridDrawState); override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
   published
     { Published declarations }
     property AlignText: TAlignText read FAlignText write SetAlignText;
     property AlignCaption: TAlignText read FAlignCaption write SetAlignCaption;
     property Center: Boolean read FCenter write SetCenter;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
 
   RegisterComponents('Other', [TNewStringGrid]);
 end;
 
 { TNewStringGrid }
 
 constructor TNewStringGrid.Create(AOwner: TComponent);
 begin
 
   { Создаем TStringGrid }
   inherited Create(AOwner);
   { Задаем начальные параметры компонента }
   AlignText := atLeft;
   AlignCaption := atCenter;
   Center := False;
   DefaultColWidth := 80;
   DefaultRowHeight := 18;
   Height := 100;
   Width := 408;
   { Заставляем компонент перерисовываться нашей процедурой
   по умолчанию DrawCell }
   DefaultDrawing := FALSE;
 end;
 
 { Процедура DrawCell осуществляет перенос текста в ячейке }
 
 procedure TNewStringGrid.DrawCell(ACol, ARow: Integer; ARect: TRect;
 
   AState: TGridDrawState);
 var
 
   CountI, { Счетчик }
   CountWord: Integer; { Счетчик }
   Sentence, { Выводимый текст }
   CurWord: string; { Текущее выводимое слово }
   SpacePos, { Позиция первого пробела }
   CurXDef, { X-координата 'курсора' по умолчанию }
   CurYDef, { Y-координата 'курсора' по умолчанию }
   CurX, { Х-координата 'курсора' }
   CurY: Integer; { Y-координата 'курсора' }
   EndOfSentence: Boolean; { Величина, указывающая на заполненность ячейки }
   Alig: TAlignText; { Тип выравнивания текста }
   ColPen: TColor; { Цвет карандаша по умолчанию }
   MassWord: array[0..255] of string;
   MassCurX, MassCurY: array[0..255] of Integer;
   LengthText: Integer; { Длина текущей строки }
   MassCurYDef: Integer;
   MeanCurY: Integer;
 
   procedure VisualCanvas;
   begin
     { Прорисовываем ячейку и придаем ей 3D-вид }
     with Canvas do
     begin
       { Запоминаем цвет пера для последующего вывода текста }
       ColPen := Pen.Color;
       if gdFixed in AState then
       begin
         Pen.Color := clWhite;
         MoveTo(ARect.Left, ARect.Top);
         LineTo(ARect.Left, ARect.Bottom);
         MoveTo(ARect.Left, ARect.Top);
         LineTo(ARect.Right, ARect.Top);
         Pen.Color := clBlack;
         MoveTo(ARect.Left, ARect.Bottom);
         LineTo(ARect.Right, ARect.Bottom);
         MoveTo(ARect.Right, ARect.Top);
         LineTo(ARect.Right, ARect.Bottom);
       end;
       { Восстанавливаем цвет пера }
       Pen.Color := ColPen;
     end;
   end;
 
   procedure VisualBox;
   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;
   end;
 
   procedure VisualText(Alig: TAlignText);
   begin
     case Alig of
       atLeft:
         begin
           with Canvas do
             { выводим текст }
             TextOut(CurX, CurY, Sentence);
           VisualCanvas;
         end;
       atRight:
         begin
           with Canvas do
             { выводим текст }
             TextOut(ARect.Right - TextWidth(Sentence) - 2, CurY, Sentence);
           VisualCanvas;
         end;
       atCenter:
         begin
           with Canvas do
             { выводим текст }
             TextOut(ARect.Left + ((ARect.Right - ARect.Left -
               TextWidth(Sentence)) div 2), CurY, Sentence);
           VisualCanvas;
         end;
       atWrapTop:
         begin
           { для каждого слова ячейки }
           EndOfSentence := FALSE;
           CountI := 0;
           while CountI <= SpacePos do
           begin
             MassWord[CountI] := '';
             CountI := CountI + 1;
           end;
           CountI := 0;
           CountWord := CurY;
           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
               { если текст выходит за границы ячейки }
               LengthText := TextWidth(CurWord) + CurX + 2;
               if LengthText > ARect.Right then
               begin
                 { переносим на следующую строку }
                 CurY := CurY + TextHeight(CurWord);
                 CurX := CurXDef + 2;
               end;
               if CountWord <> CurY then
                 CountI := CountI + 1;
               MassWord[CountI] := MassWord[CountI] + CurWord;
               { увеличиваем X-координату курсора }
               CurX := CurX + TextWidth(CurWord);
               CountWord := CurY;
             end;
           end;
           with Canvas do
           begin
             CountWord := 0;
             CurY := CurYDef + 2;
             CurX := CurXDef + 2;
             while CountWord <= CountI do
             begin
               case Center of
                 True:
                   begin
                     CurWord := MassWord[CountWord];
                     if Copy(CurWord, Length(CurWord) - 1, 1) = ' ' then
                       MassWord[CountWord] := Copy(CurWord, 0, Length(CurWord) -
                         1);
                     MassCurX[CountWord] := ARect.Left + ((ARect.Right -
                       ARect.Left - TextWidth(MassWord[CountWord])) div 2);
                     MassWord[CountWord] := CurWord;
                   end;
                 False: MassCurX[CountWord] := CurX;
               end;
               MassCurY[CountWord] := CurY;
               { выводим слово }
               TextOut(MassCurX[CountWord], MassCurY[CountWord],
                 MassWord[CountWord]);
               CurY := CurY + TextHeight(MassWord[CountWord]);
               CountWord := CountWord + 1;
             end;
           end;
           VisualCanvas;
         end;
       atWrapCenter:
         begin
           { для каждого слова ячейки }
           EndOfSentence := FALSE;
           CountI := 0;
           while CountI <= SpacePos do
           begin
             MassWord[CountI] := '';
             CountI := CountI + 1;
           end;
           CountI := 0;
           CountWord := CurY;
           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
               { если текст выходит за границы ячейки }
               LengthText := TextWidth(CurWord) + CurX + 2;
               if LengthText > ARect.Right then
               begin
                 { переносим на следующую строку }
                 CurY := CurY + TextHeight(CurWord);
                 CurX := CurXDef + 2;
               end;
               if CountWord <> CurY then
                 CountI := CountI + 1;
               MassWord[CountI] := MassWord[CountI] + CurWord;
               { увеличиваем X-координату курсора }
               CurX := CurX + TextWidth(CurWord);
               CountWord := CurY;
             end;
           end;
           with Canvas do
           begin
             CountWord := 0;
             CurX := CurXDef + 2;
             while CountWord <= CountI do
             begin
               case Center of
                 True:
                   begin
                     CurWord := MassWord[CountWord];
                     if Copy(CurWord, Length(CurWord) - 1, 1) = ' ' then
                       MassWord[CountWord] := Copy(CurWord, 0, Length(CurWord) -
                         1);
                     MassCurX[CountWord] := ARect.Left + ((ARect.Right -
                       ARect.Left - TextWidth(MassWord[CountWord])) div 2);
                     MassWord[CountWord] := CurWord;
                   end;
                 False: MassCurX[CountWord] := CurX;
               end;
               MassCurY[CountWord] := TextHeight(MassWord[CountWord]);
               CountWord := CountWord + 1;
             end;
             CountWord := 0;
             MassCurYDef := 0;
             while CountWord <= CountI do
             begin
               MassCurYDef := MassCurYDef + MassCurY[CountWord];
               CountWord := CountWord + 1;
             end;
             MassCurYDef := (ARect.Bottom - ARect.Top - MassCurYDef) div 2;
             CountWord := 0;
             MeanCurY := 0;
             while CountWord <= CountI do
             begin
               MassCurY[CountWord] := ARect.Top + MeanCurY + MassCurYDef;
               MeanCurY := MeanCurY + TextHeight(MassWord[CountWord]);
               CountWord := CountWord + 1;
             end;
             CountWord := -1;
             while CountWord <= CountI do
             begin
               CountWord := CountWord + 1;
               if MassCurY[CountWord] < (ARect.Top + 2) then
                 Continue;
               { выводим слово }
               TextOut(MassCurX[CountWord], MassCurY[CountWord],
                 MassWord[CountWord]);
             end;
           end;
           VisualCanvas;
         end;
       atWrapBottom:
         begin
           { для каждого слова ячейки }
           EndOfSentence := FALSE;
           CountI := 0;
           while CountI <= SpacePos do
           begin
             MassWord[CountI] := '';
             CountI := CountI + 1;
           end;
           CountI := 0;
           CountWord := CurY;
           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
               { если текст выходит за границы ячейки }
               LengthText := TextWidth(CurWord) + CurX + 2;
               if LengthText > ARect.Right then
               begin
                 { переносим на следующую строку }
                 CurY := CurY + TextHeight(CurWord);
                 CurX := CurXDef + 2;
               end;
               if CountWord <> CurY then
                 CountI := CountI + 1;
               MassWord[CountI] := MassWord[CountI] + CurWord;
               { увеличиваем X-координату курсора }
               CurX := CurX + TextWidth(CurWord);
               CountWord := CurY;
             end;
           end;
           with Canvas do
           begin
             CountWord := 0;
             CurX := CurXDef + 2;
             while CountWord <= CountI do
             begin
               case Center of
                 True:
                   begin
                     CurWord := MassWord[CountWord];
                     if Copy(CurWord, Length(CurWord) - 1, 1) = ' ' then
                       MassWord[CountWord] := Copy(CurWord, 0, Length(CurWord) -
                         1);
                     MassCurX[CountWord] := ARect.Left + ((ARect.Right -
                       ARect.Left - TextWidth(MassWord[CountWord])) div 2);
                     MassWord[CountWord] := CurWord;
                   end;
                 False: MassCurX[CountWord] := CurX;
               end;
               MassCurY[CountWord] := TextHeight(MassWord[CountWord]);
               CountWord := CountWord + 1;
             end;
             CountWord := 0;
             MassCurYDef := 0;
             while CountWord <= CountI do
             begin
               MassCurYDef := MassCurYDef + MassCurY[CountWord];
               CountWord := CountWord + 1;
             end;
             MassCurYDef := ARect.Bottom - MassCurYDef - 2;
             CountWord := 0;
             MeanCurY := -MassCurY[CountWord];
             while CountWord <= CountI do
             begin
               MeanCurY := MeanCurY + MassCurY[CountWord];
               MassCurY[CountWord] := MassCurYDef + MeanCurY;
               CountWord := CountWord + 1;
             end;
             CountWord := -1;
             while CountWord <= CountI do
             begin
               CountWord := CountWord + 1;
               if MassCurY[CountWord] < (ARect.Top + 2) then
                 Continue;
               { выводим слово }
               TextOut(MassCurX[CountWord], MassCurY[CountWord],
                 MassWord[CountWord]);
             end;
           end;
           VisualCanvas;
         end;
     end;
   end;
 
 begin
 
   VisualBox;
   VisualCanvas;
   { Начинаем рисование с верхнего левого угла ячейки }
 
   CurXDef := ARect.Left;
   CurYDef := ARect.Top;
   CurX := CurXDef + 2;
   CurY := CurYDef + 2;
   { Здесь мы получаем содержание ячейки }
 
   Sentence := Cells[ACol, ARow];
   { Если ячейка пуста выходим из процедуры }
 
   if Sentence = '' then
     Exit;
   { Проверяем длину строки (не более 256 символов) }
 
   if Length(Sentence) > 256 then
   begin
     MessageBox(0, 'Число символов не должно быть более 256.',
       'Ошибка в таблице', mb_OK);
     Cells[ACol, ARow] := '';
     Exit;
   end;
   { Узнаем сколько в предложении слов и задаем размерность массивов }
 
   SpacePos := Pos(' ', Sentence);
   { Узнаем тип выравнивания текста }
 
   if gdFixed in AState then
     Alig := AlignCaption
   else
     Alig := AlignText;
   VisualText(Alig);
 end;
 
 procedure TNewStringGrid.SetAlignCaption(Value: TAlignText);
 begin
   if Value <> FAlignCaption then
     FAlignCaption := Value;
 end;
 
 procedure TNewStringGrid.SetAlignText(Value: TAlignText);
 begin
   if Value <> FAlignText then
     FAlignText := Value;
 end;
 
 procedure TNewStringGrid.SetCenter(Value: Boolean);
 begin
   if Value <> FCenter then
     FCenter := Value;
 end;
 
 end.
 




Авторазмер ширины колонок TStringGrid

Автор: Neil J. Rubenking

Я использую компонент StringGrid и хотел бы менять ширину его колонок в соответствии с расположенным в них текстом, другими словами я хочу чтобы весь текст в них был виден, но как это сделать?

Попробуйте это:


 procedure TForm1.StringGrid1SelectCell(Sender: TObject; vCol,
   vRow: Longint; var CanSelect: Boolean);
 var
   Wid: Integer;
 begin
   with Sender as TStringGrid do
   begin
     Wid := Canvas.TextWidth(Cells[Col, Row] + ' ');
     if Wid > ColWidths[Col] then
       ColWidths[Col] := Wid;
   end;
 end;
 
 procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
 var
   Wid: Integer;
 begin
   if Key = #13 then
     with Sender as TStringGrid do
     begin
       Wid := Canvas.TextWidth(Cells[Col, Row] + ' ');
       if Wid > ColWidths[Col] then
         ColWidths[Col] := Wid;
     end;
 end;
 

Имейте в виду, что в обработчике события OnSelectCell я переименовал параметры Col и Row на vCol и vRow, чтобы избежать путаницы со свойствами StringGrid, имеющими те же имена. StringGrid c данными методами всегда расширяет данную колонку, если вновь добавляемая строка имеет ширину большую чем текущая ширина колонки.




Как перетащить целую колонку из StringGrid в ListBox

В Object Inspector установите свойство dragmode у StringGrid в dmAutomatic.

Ниже приведён полный код:


 type
   TForm1 = class(TForm)
     StringGrid1: TStringGrid;
     ListBox1: TListBox;
     procedure ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
       State: TDragState; var Accept: Boolean);
     procedure ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
     procedure FormCreate(Sender: TObject);
     procedure StringGrid1DragOver(Sender, Source: TObject; X, Y: Integer;
       State: TDragState; var Accept: Boolean);
     procedure StringGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);
   private
     { Private declarations }
     XMouseCord: Integer;
     StartDrag: Boolean;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
   State: TDragState; var Accept: Boolean);
 begin
   Accept := Source is TStringGrid;
 end;
 
 procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
 var
   i: integer;
   ColumVal, CurrentCol: Integer;
 begin
   if Source is TStringGrid then
   begin
     //Вычисляем колонку
     ColumVal := 0;
     CurrentCol := 0;
     for i := 0 to TStringGrid(Source).ColCount - 1 do
     begin
       ColumVal := ColumVal + TStringGrid(Source).ColWidths[i];
       if XMouseCord <= ColumVal then
       begin
         CurrentCol := i;
         break;
       end;
     end;
     //Убеждаемся, что это не первая колонка, которая не содержит данных
     if CurrentCol <> 0 then
     begin
       for i := 1 to TStringGrid(Source).RowCount - 1 do
       begin
         ListBox1.items.Add(TStringGrid(Source).Cells[CurrentCol, i]);
       end;
     end;
     StartDrag := True;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 //Для демонстрационных целей
   with StringGrid1 do
   begin
     Cells[1, 1] := 'T1';
     Cells[1, 2] := 'T2';
     Cells[1, 3] := 'T3';
     Cells[1, 4] := 'T4';
     Cells[2, 1] := 'T5';
     Cells[2, 2] := 'T6';
     Cells[2, 3] := 'T7';
     Cells[2, 4] := 'T8';
     Cells[3, 1] := 'T9';
     Cells[3, 2] := 'T10';
     Cells[3, 3] := 'T11';
     Cells[3, 4] := 'T12';
     Cells[4, 1] := 'T13';
     Cells[4, 2] := 'T14';
     Cells[4, 3] := 'T15';
     Cells[4, 4] := 'T16';
   end;
   StartDrag := True;
 end;
 
 procedure TForm1.StringGrid1DragOver(Sender, Source: TObject; X,
   Y: Integer; State: TDragState; var Accept: Boolean);
 begin
   //Сохраняем колонку, когда начинается перетаскивание.
   if StartDrag then
   begin
     XMouseCord := X;
     StartDrag := False;
   end;
 end;
 
 procedure TForm1.StringGrid1DragDrop(Sender, Source: TObject; X,
   Y: Integer);
 begin
   //В данном случае помещаем е¸ на грид
   StartDrag := True;
 end;
 




Как удалить выделенную запись из TStringGrid

Автор: MBo


 procedure TForm1.Button3Click(Sender: TObject);
 var
   i,j: Integer;
 begin
   j:=SG1.Row; // строка с выделением
   SG1.Rows[j].Clear;
   for i:=j to SG1.RowCount-2 do
     SG1.Rows[i].Assign(SG1.Rows[i+1]);
   SG1.RowCount:=SG1.RowCount-1;
 end;
 




Цвет неактивной ячейки StringGrid

Автор: Neil J. Rubenking

...если я щелкаю на любой ячейке StringGrid2, последняя выбранная ячейка в StringGrid1 становится синей...

Создайте обработчик (если он отсутствует) события сетки OnDrawCell и включите в него следующий код:


 procedure TForm1.StringGrid3DrawCell(Sender: TObject; vCol,
   vRow: Longint; Rect: TRect; State: TGridDrawState);
 begin
   if Sender = ActiveControl then
     Exit;
   if not (gdSelected in State) then
     Exit;
   with Sender as TStringGrid do
   begin
     Canvas.Brush.Color := Color;
     Canvas.Font.Color := Font.Color;
     Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2,
       Cells[vCol, vRow]);
   end;
 end;
 

Имейте в виду, что в обработчике события OnDrawCell я переименовал параметры Col и Row на vCol и vRow, чтобы избежать путаницы со свойствами StringGrid, имеющими те же имена. Данный метод выполняется немедленно после того, как сетка становится неактивной, и после того как запрошенная ячейка становится НЕвыбранной. В любом из этих случаев вы должны нарисовать невыбранную ячейку для НЕАКТИВНОЙ сетки - т.е. в тех случаях, когда у вас получается "неправильный" цвет. Вы просто берете работу Delphi по закрашиванию ячеек на себя, пропуская defaultDrawing (отрисовку по умолчанию), для таких ячеек, но в то же время разрешая Delphi поработать за вас во всех остальных случаях.




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



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



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


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