А что, Delphi + Corel Draw даже очень ничего.
| Раздел Сокровищница | абец Олег, дата публикации 10 мая 2001г. |
Надеюсь, многие сталкивались с Corel Draw? А у многих слюнки текли, что это мощнейший графический редактор и хотелось бы под него свои программы писать, к примеру, чертежи выводить? Я один из вас :)
Формат файлов *.cdr конечно, не представлю, т.к. сам его не знаю :), но как с этим зверем работать расскажу. Вычитал, что с Corel Draw можно работать только через скрипт, причем изначально я готовил файлы скриптов *.csc, а затем их запускал в самом редакторе. Рабочий инструмент для освоения - Corel Script Editor. Если Вы хотите действительно что-то написать, то он вам просто необходим, хотя бы ради того, что смотреть как Corel Draw их сам создает, ну и самое главное - дока по языку и функциям. Все замечательно, только вот скрипты медленно работают т.к. они эмитируют работу человека - т.е. кнопочки сами нажимаются, панельки меняются и т.д.
А чертеж, к примеру на котором около 3000 объектов мог загружаться и исполнятся до часу! Нет, кода это утомляет, то можно и самому посидеть - глядишь за неделю сделаешь :)
И тут я "чисто случайно" наткнулся на статейку . Оказывается можно и через OLE этот Corel Draw дергать, и как оказывается, не так уж оно и сложно. Да, совершенно верно, нужно использовать CorelDraw.Automation.xx. Я возился с 8-й версией. Забегая на перед, скажу, что тот же чертеж выводился в течении 5-10 минут.
Ну что, начнем?
var CorelDraw: Variant; … CorelDraw := CreateOleObject('CorelDraw.Automation.8'); // цифирку можете свою поставить CorelDraw.FileNew; // или CorelDraw.FileOpen(FileName); CorelDraw.SetDocVisible(True); // можно и не показывать, что он там делает, но ведь интересно! :) // кстати, можно нарисовать, а потом показать - будет на 30% быстрее ... // ну и в конце CorelDraw.FileSave('NewName', 0, False, 0, False); CorelDraw.FileExit(False); // можно не писать, если не надо закрывать CorelDraw := Unassigned;
Формат функций доступным английским языком описан в draw_scr.hlp. Ну а дальше, чего душа (или начальство :) ) желает:
CorelDraw.SetPageOrientation(0); CorelDraw.SetPageSize(PageW, PageH); CorelDraw.NewLayer('NewLayer1'); CorelDraw.SelectLayer('NewLayer1'); CorelDraw.CreateEllipse(CalcY(Y1)), CalcX(X1), CalcY(Y2), CalcX(X2), 0, 0, 0); // ничего я не перепутал!!! именно так у них координаты! CorelDraw.CreateRectangle(CalcY(Y1)), CalcX(X1), CalcY(Y2), CalcX(X2), CalcX(Radius)); ...
А это Unit1.dfm
object Form1: TForm1 Left = 175 Top = 107 Width = 596 Height = 375 Caption = 'Form1' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False OnCreate = FormCreate PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 448 Top = 56 Width = 6 Height = 13 Caption = '[]' end object Label2: TLabel Left = 19 Top = 12 Width = 13 Height = 13 Caption = 'X=' end object Edit1: TEdit Left = 16 Top = 32 Width = 417 Height = 21 TabOrder = 0 Text = '((24/2)+3*(7-x))' OnChange = Edit1Change end object BitBtn1: TBitBtn Left = 448 Top = 32 Width = 75 Height = 22 TabOrder = 1 OnClick = BitBtn1Click Kind = bkOK end object Memo1: TMemo Left = 16 Top = 80 Width = 241 Height = 249 TabOrder = 2 end object Button1: TButton Left = 448 Top = 2 Width = 75 Height = 25 Caption = 'prepare' TabOrder = 3 OnClick = Button1Click end object Edit2: TEdit Left = 36 Top = 8 Width = 53 Height = 21 TabOrder = 4 Text = '2' end object Button2: TButton Left = 264 Top = 80 Width = 75 Height = 25 Caption = 'Speed test' TabOrder = 5 OnClick = Button2Click end end
Алгоритм проверки контрольного числа ИНН и страхового номера ПФ
Модуль содержит две функции для проверки контрольного числа ИНН и страхового номера ПФ CheckINN - Функция вычисляет контрольное число ИНН и возвращает True если ИНН введен правильно или False в противном случае
В качестве параметра передается проверяемый ИНН
Для справки: структура ИНН 10-ти разрядный ИНН - NNNNXXXXXC 12-ти разрядный ИНН - NNNNXXXXXXCC где: NNNN - номер налоговой инспекции XXXXX, XXXXXX - порядковый номер налогоплательщика (номер записи в госреестре) C - контрольное число в 10-ти разрядном ИНН CC - контрольное число в 12-ти разрядном ИНН (фактически, идущие подряд две контрольные цифры) CheckPFCertificate - Функция вычисляет контрольное число страхового номера ПФ и возвращает True если оно введено правильно или False в противном случае
В качестве параметра передается страховой номер ПФ без разделителей
Проверка контрольного числа Страхового номера проводится только для номеров больше номера 001-001-998.
Контрольное число Страхового номера рассчитывается следующим образом: каждая цифра Страхового номера умножается на номер своей позиции (позиции отсчитываются с конца), полученные произведения суммируются, сумма делится на 101, последние две цифры остатка от деления являются Контрольным числом.
Скачать архив (1.2K)
Алгоритм расчета контрольного числа ОГРН (основной государственный регистрационный номер)
Государственный регистрационный номер записи, вносимой в Единый государственный реестр юридических лиц (далее - государственный реестр), состоит из 13 цифр, расположенных в следующей последовательности: СГГККХХХХХХХЧ, где С (1-й знак) - признак отнесения государственного регистрационного номера записи: 1 - к основному государственному регистрационному номеру (ОГРН); 2 - к иному государственному регистрационному номеру записи; ГГ (со 2-го по 3-й знак) - две последние цифры года внесения записи в государственный реестр; КК (4-й, 5-й знаки) - порядковый номер субъекта Российской Федерации по перечню субъектов Российской Федерации, установленному статьей 65 Конституции Российской Федерации; ХХХХХХХ (с 6-го по 12-й знак) - номер записи, внесенной в государственный реестр в течение года; Ч (13-й знак) - контрольное число: младший разряд остатка от деления предыдущего 12-значного числа на 11.
| unit OGRN; interface function CheckOGRN(const OGRN: string): Boolean; implementation uses Sysutils; function CheckOGRN(const OGRN: string): Boolean; var VerifNumb: Int64; CheckNumb, ResultNumb: Byte; begin Result := Length(OGRN) = 13; if Not Result then Exit; VerifNumb := StrToInt64(Copy(OGRN, 1, 12)); CheckNumb := StrToInt(OGRN[13]); ResultNumb := VerifNumb mod 11; if ResultNumb > 9 then ResultNumb := ResultNumb - Round(ResultNumb/10)*10; Result := ResultNumb = CheckNumb; end; end. |
Автоматическое определение занятости приложения
| Раздел Сокровищница |
Компонент:TBusyDetector V0.1b Описание: Компонент для автоматического определения занятости приложения с целью развлечь пользователя при выполнении тяжелых операций, приводящих к зависанию GUI (пользовательского интерфейса). Интерфейс: property Enabled: Boolean; вкл/выкл слежения property Interval: Cardinal; интервал (в мсек) проверки занятости property Caption: TCaption; заголовок окна property Text: TCaption; текст окна property Stated: Boolean; вкл/выкл строки состояние property State: TCaption; текст сотсояние property Progressed: Boolean; вкл/выкл полосу прогресса property Min: Integer; property Max: Integer; property Position: Integer; позиция в полосе прогресса property Step: Integer; property OnGetWindowClass: TBusyWindowClassEvent; получение класса окна property OnBusyDetect: TNotifyEvent; событие на обнаружения занятости property OnIdleDetect: TNotifyEvent; конец занятости Показания: Delphi 3 и выше;
OS Win9X/WinNTX;
Руки2X;
Халява.
Комментарий:Очень часто, особенно в связи с одно-потоковой архитектурой приложения в Delphi, требуется вставлять хоть какие то предупреждения для пользователя перед и в процессе выполнения тяжелых операций таких как подключения к базе, массовые математические вычисления и т.п. но так как на это нет времени да и не во все влезешь я взялся в своем проекте решить эту проблему "глобально". Компонент сырой, требует серьезной доработки (например, если компилить в режиме рантайм пакетов - то ресурсы с анимацией недоступны), так что жду критики, пожеланий и конкретных предложений по email. Скачать компонент: (15.7K)
Митронов Станислав
Автоматизация создание BackUp-ов проектов
| Раздел Сокровищница |
Пробовал я много разного рода BackUp креаторов, и вот к чему я пришел: WinRAR + .BAT(CMD) - лучше нет (даже при разработке в команде)
пример использования:
Файл BackUp.CMD
| @echo Off echo --------------------------- echo RNZ prj. BackUp batch echo --------------------------- @echo On set tmpName=MyProject_src set backupDir=_BackUp\D6\Prj\MyProject start /w winrar a -r -y -ag_YYMMDD_HHMM -x.\Data\*.* -x@.\xlist.lst "%temp%\%tmpName%" %1 mkdir "..\_sources" mkdir C:\"%backupDir%" mkdir D:\"%backupDir%" mkdir E:\"%backupDir%" mkdir \\"MyNetDir\%backupDir%" copy /y "%temp%\%tmpName%*.rar" "..\_sources" copy /y "%temp%\%tmpName%*.rar" C:\"%backupDir%" copy /y "%temp%\%tmpName%*.rar" D:\"%backupDir%" copy /y "%temp%\%tmpName%*.rar" E:\"%backupDir%" copy /y "%temp%\%tmpName%*.rar" \\"MyNetDir\%backupDir%" del "%temp%\%tmpName%*.rar" rem start "..\_sources" rem start C:\"%backupDir%" rem start D:\"%backupDir%" rem start E:\"%backupDir%" rem start \\"MyNetDir\%backupDir%" set tmpName= set backupDir= |
BackUp.CMD и xlist.lst копируем в директорию(каталог, папку) с проектом, xlist.lst содержит список исключений и может иметь примерно следующий вид:
Файл xlist.lst
| ~*.* *.~* *.rar *.bak *.dcu *.res *.exe _qsq*.* |
Bat-файл в Группе проектов
| Раздел Сокровищница | амм на Delphi и объединении их в одну группу, в ту же группу можно добавить любой bat файл.
Он будет выполнятся при каждой компиляции группы. Это можно использовать для выполнения какого-либо действий, необходимого для корректной компиляции или для выполнения действий сразу после перекомпиляции. Как это сделать: File -> New -> Batch file Редактировать содержимое в Project -> Options (Shift+Ctrl+F11) Дальше - у кого какая фантазия... |
Bdetry
 | источник информации: |
| Использование EDBEngineError Exceptions Перевод с английского |
Перевод и адаптация - Елена Филиппова
Информация, которая описывает ошибки, возникающие при работе BDE, может быть получена приложением с помощью обработки исключения EDBENGINEERROR конструкцией try..except.
Когда возникает исключение EDBENGINEERROR, создается объект EDBEngineError и различные поля в этом объекте используются, чтобы программно определить какая именно некорректная ситуация произошла. Также, для данного исключения, может быть сгенерировано больше чем одно сообщение об ошибке. Таким образом необходимо выполнения итераций, чтобы получить всю необходимую информацию. Поля объекта, которые наиболее интересны в этом контексте: ErrorCount: type Integer; Определяет количество ошибок, которые содержит свойство Errors, отсчет начинается с нуля. Errors: type TDBError; Структура типа Record, которая содержит информацию о каждой сгенерированной специфической ошибке. Обращаться к каждой записи через нумерованный индекс. Errors.ErrorCode: type DBIResult; Определяет код ошибки, которая содержится в текущей записи. Errors.Category: type Byte; Категория ошибки. Errors.SubCode: type Byte; Дополнительный код для значения ErrorCode. Errors.NativeError: type LongInt; Код удаленной ошибки, возвращается сервером. Из он равен нулю, ошибка произошла не на сервере; в этом поле появляется код возврата SQL-выражения. Errors.Message: type TMessageStr; Если произошла ошибка на сервере, то это строка-сообщение сервера об ошибке в текущей записи Errors, если нет, то сообщение BDE. Объект EDBEngineError создается непосредственно в конструкции try..except в секции except. Однажды созданный, объект может передаваться другим процедурам для обработки ошибок.
Пример использования конструкции try..except для обработки исключения DBEngineError: procedure TForm1.Button1Click(Sender: TObject); var i: Integer; begin if Edit1.Text > ' ' then begin Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text); try Table1.Post; except on E: EDBEngineError do ShowError(E); end; end; end; В данной процедуре происходит попытка записать значение в поле таблице и при возникновении ошибки BDE, обработка ее перехватывается. Объект типа EDBEngineError передается как параметр процедуре ShowError. Обратите внимание, что в данном примере обрабатывается только ошибка BDE, что на самом деле недостаточно. В реальных условиях необходимо проверять все типы исключительных ситуаций.
Процедура ShowError, в свою очередь, отображает весь список сообщений, которые содержатся в переданной ей переменной: procedure TForm1.ShowError(AExc: EDBEngineError); var i: Integer; begin Memo1.Lines.Clear; Memo1.Lines.Add('Number of errors: ' + IntToStr(AExc.ErrorCount)); Memo1.Lines.Add(''); {Iterate through the Errors records} for i := 0 to AExc.ErrorCount - 1 do begin Memo1.Lines.Add('Message: ' + AExc.Errors[i].Message); Memo1.Lines.Add(' Category: ' + IntToStr(AExc.Errors[i].Category)); Memo1.Lines.Add(' Error Code: ' + IntToStr(AExc.Errors[i].ErrorCode)); Memo1.Lines.Add(' SubCode: ' + IntToStr(AExc.Errors[i].SubCode)); Memo1.Lines.Add(' Native Error: ' + IntToStr(AExc.Errors[i].NativeError)); Memo1.Lines.Add(''); end; end;
Библиотека для работы с LAN.
| Раздел Сокровищница | Alex, 09 апреля 2001г. |
unit NetProcs; interface uses Classes, Windows; type TAdapterStatus = record adapter_address: array [0..5] of Char; filler: array [1..4*SizeOf(Char)+19*SizeOf(Word) +3*SizeOf(DWORD)] of Byte; end; THostInfo = record username: PWideChar; logon_domain: PWideChar; oth_domains: PWideChar; logon_server: PWideChar; end;{record} function IsNetConnect : Boolean; {Возвращает TRUE если компьютер подключен к сети, иначе - FALSE} function AdapterToString(Adapter: TAdapterStatus): string; {Преобразует MAC адес в привычный xx-xx-xx-xx} function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer; {Заполняет Addresses MAC-адресами компьютера с сетевым именем Machine. Возвращает число МАС адресов на компьютере} function GetNetUser(HostName: WideString): THostInfo; {Возвращает LOGIN текущего пользователя на HOSTNAME компьютере} implementation uses NB30, SysUtils; function IsNetConnect : Boolean; begin if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then Result:= True else Result:= False; end;{function} function AdapterToString(Adapter: TAdapterStatus): string; begin with Adapter do Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [ Integer(adapter_address[0]), Integer(adapter_address[1]), Integer(adapter_address[2]), Integer(adapter_address[3]), Integer(adapter_address[4]), Integer(adapter_address[5])]); end;{function} function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer; const NCBNAMSZ = 16; // absolute length of a net name MAX_LANA = 254; // lana's in range 0 to MAX_LANA inclusive NRC_GOODRET = $00; // good return NCBASTAT = $33; // NCB ADAPTER STATUS NCBRESET = $32; // NCB RESET NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS type PNCB = ^TNCB; TNCBPostProc = procedure (P: PNCB); stdcall; TNCB = record ncb_command: Byte; ncb_retcode: Byte; ncb_lsn: Byte; ncb_num: Byte; ncb_buffer: PChar; ncb_length: Word; ncb_callname: array [0..NCBNAMSZ - 1] of Char; ncb_name: array [0..NCBNAMSZ - 1] of Char; ncb_rto: Byte; ncb_sto: Byte; ncb_post: TNCBPostProc; ncb_lana_num: Byte; ncb_cmd_cplt: Byte; ncb_reserve: array [0..9] of Char; ncb_event: THandle; end; PLanaEnum = ^TLanaEnum; TLanaEnum = record length: Byte; lana: array [0..MAX_LANA] of Byte; end; ASTAT = record adapt: TAdapterStatus; namebuf: array [0..29] of TNameBuffer; end; var NCB: TNCB; Enum: TLanaEnum; I: Integer; Adapter: ASTAT; MachineName: string; begin Result := -1; Addresses.Clear; MachineName := UpperCase(Machine); if MachineName = '' then MachineName := '*'; FillChar(NCB, SizeOf(NCB), #0); NCB.ncb_command := NCBENUM; NCB.ncb_buffer := Pointer(@Enum); NCB.ncb_length := SizeOf(Enum); if Word(NetBios(@NCB)) = NRC_GOODRET then begin Result := Enum.Length; for I := 0 to Ord(Enum.Length) - 1 do begin FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBRESET; NCB.ncb_lana_num := Enum.lana[I]; if Word(NetBios(@NCB)) = NRC_GOODRET then begin FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBASTAT; NCB.ncb_lana_num := Enum.lana[i]; StrLCopy(NCB.ncb_callname, PChar(MachineName),NCBNAMSZ); StrPCopy(@NCB.ncb_callname[Length(MachineName)], StringOfChar(' ', NCBNAMSZ - Length(MachineName))); NCB.ncb_buffer := PChar(@Adapter); NCB.ncb_length := SizeOf(Adapter); if Word(NetBios(@NCB)) = NRC_GOODRET then Addresses.Add(AdapterToString(Adapter.adapt)); end; end; end; end;{function} function NetWkstaUserEnum(servername: PWideChar; level : DWord; var bufptr: Pointer; prefmaxlen: DWord; var entriesread: PDWord; var totalentries: PDWord; var resumehandle: PDWord ): LongInt ; stdcall; external 'netapi32.dll' name 'NetWkstaUserEnum'; function GetNetUser(HostName: WideString): THostInfo; var Info: Pointer; ElTotal: PDWord; ElCount: PDWord; Resume: PDWord; Error: LongInt; begin Resume:=0; NetWkstaUserEnum(PWideChar(HostName),1, Info,0, ElCount,ElTotal,Resume); Error:=NetWkstaUserEnum(PWideChar(HostName),1,Info,256*Integer(ElTotal), ElCount,ElTotal,Resume); case Error of ERROR_ACCESS_DENIED: Result.UserName:= 'ERROR - ACCESS DENIED'; ERROR_MORE_DATA: Result.UserName:= 'ERROR - MORE DATA'; ERROR_INVALID_LEVEL: Result.UserName:= 'ERROR - INVALID LEVEL'; else if Info <> nil then Result:=THostInfo(info^) else begin Result.username:= '???'; Result.logon_domain:= '???'; Result.oth_domains:= '???'; Result.logon_server:= '???'; end;{if} end;{case} end; {function} end.
Библиотека, реализующая некоторые алгоритмы линейной алгебры
| в Александр Васильевич, дата публикации 30 октября 2003г. |
Основным ядром, значительной части вычислительных алгоритмов (решение систем линейных и нелинейных уравнений, оптимизация), является алгоритмы линейной алгебры. Вашему вниманию предлагается библиотека, реализующая некоторые алгоритмы линейной алгебры. Выбор алгоритмов был довольно субъективным, и отбор был нацелен на решение систем линейных уравнений.
Возможности библиотеки: Элементарные векторные и матричные операции с целыми, вещественными и комплексными числами, матрицы и вектора динамические. Оптимизация этих операций под FPU. Решение СЛАУ с квадратными матрицами: LU, LDL^{T} разложение, вычисление детерминантов, обращение квадратных матриц. Поддерживаются вещественные и комплексные числа. Решение СЛАУ с прямоугольными матрицами (задачи МНК): QR разложение преобразованием Хаусхолдера, SVD разложение, вычисление псевдообратных матриц. Библиотека написана на Delphi 6.
Архивные файлы: — исходные тексты (51K) — исходные тексты демонстрационной программы, она же и являлась отладочной. (43K) — описание библиотеки. (17K) Как альтернативу данной библиотеку могу рекомендовать: -- библиотека линейной алгебры + библиотека для работы с графами (Pascal). Пожалуй. самая богатая и хорошо отлаженная библиотека LAPACK, многие идеи из которой используется в коммерческих библиотеках NAG, IMSL. (Fortran), (С++).
Библиотеки пользовательских функций UDF для Interbase на Free Pascal.
| Раздел Сокровищница |
Всем известно, что возможности interbase можно расширить за счет написания пользовательских функций UDF. Но почему на Free Pascal?
Есть ряд веских причин.
1. При переносе Вашего сервера на другую платформу, например, с win32 на FreeBSD или Linux, возникает проблема переноса также и UDF. Как известно, есть дистрибутивы Free Pascal на эти платформы. 2. В Pascal имеется очень удачная концепция библиотеки (library). При переносе на другую платформу достаточно перекомпилировать библиотеку, и она будет работать. При написании аналогичной библиотеки на с приходится переделывать make файл. 3. Вы имеете возможность выбора: сделать или на с, или на паскале. 4. Free Pascal - хорошее подспорье для программиста на Delphi. Знакомый синтаксис, наверное, поможет многим сделать шаг в изучении Unix и использовании серверных возможностей платформ FreeBSD и Linux. Приведем небольшой пример такой библиотеки. Все примеры приведены не в отдельном файле, а на одной странице для удобства чтения.
library libosh; {$mode objfpc} {$PACKRECORDS C} const // Чтобы не было проблем с распознаванием кодировок на разных платформах rus_chars:pChar = #197#210#211#206#208#192#205#202#213#209 +#194#204#229#243#232#238#240#224#234#245#241#236 ; lat_chars:pChar = 'ETYOPAHKXCBMeyuopakxcm'; small_chars:pChar = #113#119#101#114#116#121#117#105#111#112#97#115#100#102#103 +#104#106#107#108#122#120#99#118#98#110#109#233#246#243#234 +#229#237#227#248#249#231#245#250#244#251#226#224#239#240#238 +#235#228#230#253#255#247#241#236#232#242#252#225#254#184 ; cap_chars:pChar = #81#87#69#82#84#89#85#73#79#80#65#83#68#70#71#72#74#75#76#90 +#88#67#86#66#78#77#201#214#211#202#197#205#195#216#217#199 +#213#218#212#219#194#192#207#208#206#203#196#198#221#223#215 +#209#204#200#210#220#193#222#168 ; cp1251:pChar = #233#246#243#234#229#237#227#248#249#231#245#250#244#251#226 +#224#239#240#238#235#228#230#253#255#247#241#236#232#242#252 +#225#254#184#201#214#211#202#197#205#195#216#217#199#213#218 +#212#219#194#192#207#208#206#203#196#198#221#223#215#209#204 +#200#210#220#193#222#168 ; cp866:pChar = #169#230#227#170#165#173#163#232#233#167#229#234#228#235#162 +#160#175#224#174#171#164#166#237#239#231#225#172#168#226#236 +#161#238#241#137#150#147#138#133#141#131#152#153#135#149#154 +#148#155#130#128#143#144#142#139#132#134#157#159#151#145#140 +#136#146#156#129#158#240 ; koi8:pChar = #202#195#213#203#197#206#199#219#221#218#200#223#198#217#215#193 +#208#210#207#204#196#214#220#209#222#211#205#201#212#216#194#192 +#163 +#234#227#245#235#229#238#231#251#253#250#232#255#230#249#247#225 +#240#242#239#236#228#246#252#241#254#243#237#233#244#248#226#224 +#179 ; function replace_it(CString: PChar;scr: PChar;dest: PChar):PChar; var i,j:integer; begin i:=0; while (CString[i]<>#0) do begin j:=0; while (scr[j]<>#0) do begin if CString[i]=scr[j] then begin CString[i]:=dest[j]; Break; end; inc(j); end; inc(i); end; result:=CString; end; function latrus(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,lat_chars,rus_chars); end; function rupper(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,small_chars,cap_chars); end; function rlower(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cap_chars,small_chars); end; function dos2win(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp866,cp1251); end; function win2dos(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp1251,cp866); end; function koi82win(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,koi8,cp1251); end; function koi82dos(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,koi8,cp866); end; function dos2koi8(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp866,koi8); end; function win2koi8(CString: PChar): PChar;stdcall;export; begin result:=replace_it(CString,cp1251,koi8); end; function UDF_strcat(dest,source : pchar) : pchar; stdcall;export; begin result:=strcat(dest,source); end; exports latrus name 'latrus', // преобразование латинских бук, похожих на кирилличесике // в кириллические 1251. Иногда надо при переделке существующих // баз данных, в которых некоторые русские буквы по ошибке // набраны латинницей rupper name 'rupper', // перевод русских в верхний и нижний регистры rlower name 'rlower', dos2win name 'dos2win', // перевод различных кодировок кириллицы win2dos name 'win2dos', koi82win name 'koi82win', koi82dos name 'koi82dos', dos2koi8 name 'dos2koi8', win2koi8 name 'win2koi8' ; end.
Откомпилированные библиотеки должны иметь названия libosh.dll для win32 и libosh.so для FreeBSD и Linux.
Для подключения этих функций используйте скрипт CONNECT 'mysvr:/db/test.gdb' USER 'UZVER' PASSWORD 'uzver'; DECLARE EXTERNAL FUNCTION LATRUS CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'latrus' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION RUPPER CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'rupper' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION RLOWER CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'rlower' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION DOS2WIN CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'dos2win' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION WIN2DOS CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'win2dos' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION KOI82WIN CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'koi82win' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION KOI82DOS CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'koi82dos' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION DOS2KOI8 CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'dos2koi8' MODULE_NAME 'libosh'; DECLARE EXTERNAL FUNCTION WIN2KOI8 CSTRING(255) RETURNS CSTRING(255) ENTRY_POINT 'win2koi8' MODULE_NAME 'libosh'; commit; В порте freepascal для freeBSD немного недоделан модуль sysutils, и вызов некоторых функций из него приводит к runtime error. Пример использования функций библиотеки SELECT WIN2KOI8(NAME) FROM PEOPLE и т.д.
Найти freepascal можно по адресу
Кубанычбек Тажмамат уулу,
03 мая 2001г
Специально для
Быстрая обработка спрайтов без применения DirectX
Каждый, кто пытался интенсивно работать со спрайтами при помощи WinAPI, или, что то же самое, методами TCanvas, убеждался в их чрезвычайно низкой производительности. Такова цена универсальности, ничего с этим не поделаешь. Кроме того, средства WinAPI не покрывают все типовые задачи, которые возникают при работе со спрайтовой графикой.
Многие ют переход к аппаратному ускорению — DirectX и OpenGL. Но для повседневных задач желательно не отрываться от привычных средств, к тому же самую главную функцию — вывод на экран — WinAPI выполняет вполне удовлетворительно.
По-моему, лучшим выходом может стать использование обычных, хранимых в памяти изображений (TBitmap), создание и вывод их при помощи обычных средств при замене промежуточного звена, а именно процедур обработки спрайтов. За счет применения низкоуровнего кода, жесткой привязки изображений к определенному формату удается достичь вполне приемлемой производительности. Ускорение в 5-10-20 раз далеко не предел, особенно в процедурах, использующих MMX.
Для лучшей совместимости и с VCL, и с KOL я решил не инкапсулировать код в виде объекта, а оставить его в виде отдельных процедур с осмысленными названиями.
Модуль SpriteUtils решает 5 типовых задач: простое копирование спрайта в спрайт [процедуры Get/Put]; отбрасывание (клиппирование) выходящих за границы областей [см. описание]; наложение с заданной прозрачностью [процедуры серии TransPaint]; наложение с заданным прозрачным цветом [процедуры серии TransPut]; снятие/наложение маски (определенного цвета) [процедуры серии MaskPut]; при наложении спрайта — автоматический его поворот вокруг вертикальной или горизонтальной осей [см. описание процедур Get/Put].
Не все функции можно достичь одной операцией и не все подходят для всех форматов. Более всего приветствуется формат 24 бита на пиксел, поэтому в прикладных задачах, скорее всего, понадобится комбинировать несколько процедур последовательно.
Для тех, кто заботится о совместимости со старым "железом", есть процедуры, не использующие MMX (и оттого более медленные).
Несколько примеров: Сложение спрайтов с заданной прозрачностью. Цвет источника умножается на прозрачность (0.0 — 1.0), цвет приемника на дополнение до 1, результат складывается
Наложение спрайта с одним маскированным цветом Копируются все пикселы источника кроме тех, которые равны выбранному прозрачному цвету
Наложение маски из спрайта Копируются только те пикселы источника, которые равны выбранному цвету
В архиве прилагаются:
описание всех процедур в виде HTML-каталога; тестовый проект для сравнения скорости процедур со стандартными; тестовые примеры для KOL и VCL. Скачать архив с документацией и примерами (83 Кб)
Михаил Рудаков,
Freeware, 2003.
Цели использования
В некоторых областях часто встречается ситуация, когда требуется вычислять значения функций, задаваемых непосредственно во время работы программы. Иногда для этого достаточно создания интерпретаторов, которые производят как анализ, так и вычисление выражения средствами языка высокого уровня.
Однако в случаях, когда на первое место среди качеств программы выходит ее быстродействие, такой вариант становится неприемлемым. Как раз для приложений, производящих длительные вычисления, и был создан данный модуль, анализ формулы в котором производится так же, как и в интерпретаторах (благодаря однократности действия оно не оказывает влияния на скорость), но ее расчет при конкретных значениях переменных происходит с той же (либо большей) скоростью, что и при вызове обычных функций Delphi.
Что это и зачем или Немного наглой саморекламы
Эта программа представляет собой простенький компилятор синтаксических выражений. "Ну опять", - скажет невнимательный читатель, но мы то с тобой внимательные, и понимаем что компилятор, это совсем не то что валяется на каждом программистском сайте. В отличие от парсера (или интерпретатора) такую штуку встретить можно несколько реже. Если честно, то когда она мне была нужна, я ее нигде не встретил. И поэтому родилась эта программа.
Что он может или Какие мы маленькие
Да в общем-то немного, и ценности в ней мало :). Она может вычислять выражения (тип - вещественное число с плавающей точкой (на момент написания это называлось Real)) с использованием операций (+,-,/,*). Мало... А разве сложно дописать пару строк чтобы обработать Y или экспоненту коли они будут нужны?
Д о п о л н е н и е
| Раздел Сокровищница | , дата публикации 04 апреля 2001г. |
В наше время крупных проектов на Васике и Яве, фантастического снижения цен на мегагерцы и мегабайты, скриптуемых языков, COM и супер технологии NET на вагончике сидюков, писать критичные по времени процедуры на ассемблере не модно, можно получить жалостливую усмешку. Все многозначительно обсуждают что <вот у си оптимизация>, а ассемблер это так не переносимо - вдруг Intel загнется ;-).
Где-то два года назад, я разрабатывал программу сервер для интенсивной круглосуточной работы, в том числе работы по забору и переформатированию почты. Одним из этапов форматирования являлось преобразования из koi8,iso,dos,mac в любимый win1251.
Поскольку это часто выполняемая для больших объемов данных операция, то был смысл её оптимизировать. Сразу отбрасывались вложенные циклы, кучи условий вида if (Ch>X) and (Ch<Y) then : в цикле for i:=1 to Length(S), и выбор падал на таблицы перекодировки. Я утешил себя тем, что при преобразования из одной кодировки в другу перемещаются не 66, а почти 128 символов (в худшем случае все 255). Табличка koi8-dos стандартна, её можно легко найти в интернете. Кроме того, она обладает редким достоинством - она взаимооднозначна (каждому символу в одной кодировке соответствует один и только один в другой). Таблички dos-win1251, win1251-dos сам бог велел брать у M$ (функции OemToChar, CharToOem), остальные я просто стянул из FAR'a (да простит меня Е. Рошал ;-). После этого я написал тривиальные процедуры перекодировки на ObjPas, посмотрел на получаемый в результате машинный код и переписал всё на асме (я не сторонник большого количества асма в программе, это показатель неправильно выбранного алгоритма, но в таких случаях он необходим). Через год, увидев обсуждение этого вопроса в КД, я с интересом стал ждать итоговый вариант чтобы стянуть его и приладить в своей программе. Уж год прошел, а такого всё нет
Поэтому шлю свой вариант (это не чудо оптимизации, но всё же лучше того что было в оригинале). TmcCodePageCharsetTable = array [Byte] of Byte; PmcCodePageCharsetTable =^TmcCodePageCharsetTable; // Из таблиц перекодировки A->B, B->C создать A->C // if SafeASCII then в позициях 0..127 будут байты 0..127 procedure mcCodePageCharsetGen (pS1,pS2,pDst: PmcCodePageCharsetTable; SafeASCII: Boolean); Asm//eax-pS1, edx-pS2, ecx-pDst push EBX push ESI push EDI mov ESI,EAX //pS1 mov EBX,EDX //pS2 mov EDI,ECX //pDst mov EDX,ECX //pDst - save xor ecx,ecx //index xor eax,eax @@R: lodsb //A[i] xlat //B[A[i]] stosb //C[i]:=B[A[i]] inc ecx test cl,cl jnz @@R //SafeAscii (0..127) cmp SafeASCII,cl //0 je @@q //FALSE xor ecx,ecx mov edi,edx //pDst @@Fill: mov al,cl stosb inc ecx cmp cl,$80 jb @@Fill @@q: pop EDI pop ESI pop EBX End;// {var i: LongInt; Begin FillChar(pDst^,SizeOf(TmcCodePageCharsetTable),0); for i:=0 to 255 do pDst^[i]:=pS2^[pS1^[i]]; End;//mcCodePageCharsetJoin} //Создать обратную таблицу перекодировки procedure mcCodePageCharsetGen (pSrc,pDst: PmcCodePageCharsetTable; SafeASCII: Boolean); const xBound = 32;//эвристический порог { Несколько слов об xBound: Поскольку в общем случае (пример dos<->win) одному символу одной таблицы может соотвествовать несколько символов другой, надо выбирать какой из них считать правильным. Я решил считать им первый помещаемый символ >=xBound, а само значение xBound выбрать = ' ' (поскольку все символы меньше пробела M$ не любит и вряд ли будет рассовывать по всей табличке) } Asm//eax-pSrc, edx-pDst, cl-1/0-boolean push EBX push ESI push EDI push ECX //push SafeASCII mov ESI,EAX //pSrc //Clear Dst Table xor eax,eax xor ecx,ecx //index mov cl,$40 mov EDI,EDX //pDst rep stosd //Create Reverse @@R: lodsb //A[i] lea ebx, [edx+eax] cmp byte ptr [ebx],xBound jae @@Already mov [ebx], cl //B[A[i]]:=i @@Already: inc ecx test cl,cl jnz @@R //SafeAscii (0..127) pop ECX //pop SafeASCII test cl,cl jz @@q //FALSE xor ecx,ecx mov edi,edx //pDst @@Fill: mov al,cl stosb inc ecx cmp cl,$80 jb @@Fill @@q: pop EDI pop ESI pop EBX End;// // по табличке преобразования pCPCT преобразовать данные из pSrc и записать их в pDst procedure mcCodePageCharsetConvert (pSrc,pDst: Pointer; DataLen: LongInt; pCPCT: PmcCodePageCharsetTable); Asm//eax-pSrc, edx-pDst, ecx-DataLen push ESI push EDI push EBX test ecx,ecx //DataLen jz @@q //=0 mov esi,eax test edx,edx jnz @@pDstAssigned mov edx,eax //pDst:=pSrc @@pDstAssigned: mov edi,edx //pDst mov ebx,pCPCT test ebx,ebx jnz @@pCPCTAssigned call Move //eax,edx,ecx jmp @@q @@pCPCTAssigned: xor eax,eax //??? @@R: lodsb xlat stosb dec ecx jnz @@R @@q: pop EBX pop EDI pop ESI End;//mcCodePageCharsetConvert
Специально для
DCOM permissions
| Раздел Сокровищница |
Технология DCOM основана на технологии COM и представляет собой ее продолжение. Основное назначение DCOM - организация взаимодействия клиента с удаленным сервером.
Как пользоваться DCOM
Чтобы воспользоваться возможностями DCOM должны быть соблюдены следующие требования: Наличие Клиент.exe, Сервер.exe. ("Каркасы" этих приложений прилагаются к документу см Samples\DCOMSvr). Наличие сети как минимум из двух компьютеров (платформы 9x, Me, NT, 2000). Компьютеры должны "видеть" друг друга. На клиентском и серверном компьютере должна быть установлена поддержка DCOM (на NT и 2000 поддержка DCOM есть по умолчанию, в 9x и Me поддержка отключена, ее можно получить по адресу ). Компьютеры должны быть в одном домене (на сколько критично это требование под вопросом, я не исследовал, информация из ). Сервер.exe должен быть зарегистрирован на клиентской машине и серверной машине (после регистрации на клиентской машине Сервер.exe можно удалить). Регистрация Сервер.exe производится из командной строки: сервер.exe regserver. Разрегистрация также из командной строки: сервер.exe unregserver Должен быть настроен DCOM (можно не задумываясь продублировать настройки, как на клиенте, так и на сервере) для запуска и доступа к Сервер.exe (настроить DCOM можно при помощи утилиты DCOMCNFG.EXE или программно, см. Samples\DcomPerm). Если DCOM настраивается для Win9x, то после настройки необходимо перезагрузить компьютер. Если изменяются настройки протоколов используемых в DCOM, то следует перезагрузить компьютер (действительно для любой платформы). Если Сервер.exe запускается на платформе 9x, то сервер должен быть предварительно загружен, можно поместить запуск сервера в StartUp.
Скачать исходные коды: (28 K)
| | "Knowledge itself is power" F.Bacon |
| Разное |
Раздел Сокровищница
(17.01.00)
(21.01.00)
(31.01.00)
(31.01.00)
(01.09.00)
Вариант №5 (01.09.00) Автор: Павленко Алексей
Я же делал несколько по-другому, вернее больше: Взял стандартные таблицы из FARа. Достаточно иметь iso2dos.tbl (двоичные файлы длиной 256 байт, сейчас их буду прилинковывать к exe, как это сделать, посоветуете?)
koi2dos.tbl
mac2dos.tbl
win2dos.tbl
При запуске программы читаю таблицы и запоминаю в массивах type ChTable=array [0..255] of byte; var iso2dos, koi2dos, mac2dos, win2dos: ChTable; После этого легко переводить из одной кодировки в другую. Для этого надо заполнить массив t: ChTable; Есть несколько вариантов: 1) Переводим в ДОС case fm.cbCharsetIn.ItemIndex of 1: t:=win2dos; 2: t:=koi2dos; 3: t:=iso2dos; 4: t:=mac2dos; end; 2) Переводим из ДОС case fm.cbCharsetOut.ItemIndex of 1: t2:=win2dos; 2: t2:=koi2dos; 3: t2:=iso2dos; 4: t2:=mac2dos; end; for i:=128 to 255 do t[t2[i]]:=i; for i:=0 to 127 do t[i]:=i; 3) Не ДОС-кодировки // из входной кодировки в ДОС case fm.cbCharsetIn.ItemIndex of 1: t1:=win2dos; 2: t1:=koi2dos; 3: t1:=iso2dos; 4: t1:=mac2dos; end; // таблица для ДОС->выходная case fm.cbCharsetOut.ItemIndex of 1: t2:=win2dos; 2: t2:=koi2dos; 3: t2:=iso2dos; 4: t2:=mac2dos; end; for i:=128 to 255 do t3[t2[i]]:=i; for i:=0 to 127 do t3[i]:=i; // теперь уже окончательная таблица для входной кодировки в выходную for i:=0 to 255 do t[i]:=t3[t1[i]]; Ну а сам перевод делается уже легко: while not eof(f) do begin readln(f, s); s2:=''; for i:=1 to Length(s) do s2:=s2+chr(t[byte(s[i])]); writeln(fout, s2); end; Вроде еще быстрее сделать невозможно. Но это только теоретически ;)
Готовую программу можно скачать с
Вариант №4 (31.01.00) Автор: Еремеев Алексей
const Koi = 'юабцдефгхийклмнопярстужвьызшэщчъЮАБЦДЕФГХИЙКЛМНОПЯРСТУЖВЬЫЗШЭЩЧЪ'; Win = 'бвчздецъйклмнопртуфхжигюыэящшьасБВЧЗДЕЦЪЙКЛМНОПРТУФХЖИГЮЫЭЯЩШЬАС'; SerH = 'АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ'; SerL = 'абвгдежзийклмнопрстуфхцчшщъыьэюя'; procedure ANSI2KOI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $B8 then Str[i] := char($A3) else if k = $A8 then Str[i] := char($B3) else if k > $BF then Str[i] := Win[k - $BF]; end; end; procedure KOI2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A3 then Str[i] := 'ё' else if k = $B3 then Str[i] := 'Ё' else if k > $BF then Str[i] := Koi[k - $BF]; end; end; procedure ANSI2IBM(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $B8 then Str[i] := char($F1) else if k = $A8 then Str[i] := char($F0) else if k > $EF then Str[i] := char(k - 16) else if (k > $BF) and (k < $F0) then Str[i] := char(k - 64); end; end; procedure IBM2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $F0 then Str[i] := 'Ё' else if k = $F1 then Str[i] := 'ё' else if (k > $7F) and (k < $A0) then Str[i] := SerH[k - $7F] else if (k > $9F) and (k < $B0) then Str[i] := SerL[k - $9F] else if (k > $DF) and (k < $F0) then Str[i] := SerL[k - $CF]; end; end; procedure ANSI2Mac(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A8 then Str[i] := char($DD) else if k = $B8 then Str[i] := char($DE) else if k = $FF then Str[i] := char($DF) else if (k > $BF) and (k < $E0) then Str[i] := char(k - 64); end; end; procedure Mac2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $DD then Str[i] := 'Ё' else if k = $DE then Str[i] := 'ё' else if k = $DF then Str[i] := 'я' else if (k > $7F) and (k < $A0) then Str[i] := SerH[k - $7F] else if (k > $DF) and (k < $FF) then Str[i] := SerL[k - $DF]; end; end; procedure ANSI2ISO(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A8 then Str[i] := char($A1) else if k = $B8 then Str[i] := char($F1) else if k > $BF then Str[i] := char(k - 16); end; end; procedure ISO2ANSI(var Str: string); var i: integer; k: byte; begin for i := 1 to Length(Str) do begin k := byte(Str[i]); if k = $A1 then Str[i] := 'Ё' else if k = $F1 then Str[i] := 'ё' else if k < $F0 then begin if k > $CF then Str[i] := SerL[k - $CF] else if k > $AF then Str[i] := SerH[k - $AF]; end; end; end;
Вариант №3 (31.01.00) Автор: Constantin G. Nekhoroshkov
Предлагаю всеобщему вниманию вот такой вот unit. Он решает проблемы конвертации не только Win1251->KOI8 но и конвертации в другие кодировки. //---Begin of Unit RusChar Unit RusChar; interface Function ALT2ISO(Ch1: byte): byte; Function ALT2KOI(Ch1: byte): byte; Function ALT2MAC(Ch1: byte): byte; Function ALT2WIN(Ch1: byte): byte; Function ISO2ALT(Ch1: byte): byte; Function ISO2KOI(Ch1: byte): byte; Function ISO2MAC(Ch1: byte): byte; Function ISO2WIN(Ch1: byte): byte; Function KOI2ALT(Ch1: byte): byte; Function KOI2ISO(Ch1: byte): byte; Function KOI2MAC(Ch1: byte): byte; Function KOI2WIN(Ch1: byte): byte; Function MAC2ALT(Ch1: byte): byte; Function MAC2ISO(Ch1: byte): byte; Function MAC2KOI(Ch1: byte): byte; Function MAC2WIN(Ch1: byte): byte; Function WIN2ALT(Ch1: byte): byte; Function WIN2ISO(Ch1: byte): byte; Function WIN2KOI(Ch1: byte): byte; Function WIN2MAC(Ch1: byte): byte; Function ConvertString(InputString: string; Convert_Flag: byte): string; implementation Const //Alt decode contants ALT_2_ISO=1; ALT_2_KOI=2; ALT_2_MAC=3; ALT_2_WIN=4; //Iso decode contants ISO_2_ALT=5; ISO_2_KOI=6; ISO_2_MAC=7; ISO_2_WIN=8; //Koi decode contants KOI_2_ALT=9; KOI_2_ISO=10; KOI_2_MAC=11; KOI_2_WIN=12; //Mac decode contants MAC_2_ALT=13; MAC_2_ISO=14; MAC_2_KOI=15; MAC_2_WIN=16; //Win decode contants WIN_2_ALT=17; WIN_2_ISO=18; WIN_2_KOI=19; WIN_2_MAC=20; ALTTable: array [1..64] of byte =( 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239 ); ISOTable: array [1..64] of byte =( 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239 ); KOITable: array [1..64] of byte =( 225, 226, 247, 231, 228, 229, 246, 250, 233, 234, 235, 236, 237, 238, 239, 240, 242, 243, 244, 245, 230, 232, 227, 254, 251, 253, 255, 249, 248, 252, 224, 241, 193, 194, 215, 199, 196, 197, 214, 218, 201, 202, 203, 204, 205, 206, 207, 208, 210, 211, 212, 213, 198, 200, 195, 222, 219, 221, 223, 217, 216, 220, 192, 209 ); MACTable: array [1..64] of byte =( 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 223 ); WINTable: array [1..64] of byte =( 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 ); Function ALT2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2ISO:=ISOtable[i]; exit; end; end; ALT2ISO:=ch1; end; Function ALT2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2KOI:=KOItable[i]; exit; end; end; ALT2KOI:=ch1; end; Function ALT2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2MAC:=MACtable[i]; exit; end; end; ALT2MAC:=ch1; end; Function ALT2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ALTTable[i]=ch1 then begin ALT2WIN:=WINtable[i]; exit; end; end; ALT2WIN:=ch1; end; Function ISO2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2ALT:=ALTtable[i]; exit; end; end; ISO2ALT:=ch1; end; Function ISO2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2KOI:=KOItable[i]; exit; end; end; ISO2KOI:=ch1; end; Function ISO2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2MAC:=MACtable[i]; exit; end; end; ISO2MAC:=ch1; end; Function ISO2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If ISOTable[i]=ch1 then begin ISO2WIN:=WINtable[i]; exit; end; end; ISO2WIN:=ch1; end; Function KOI2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2ALT:=ALTtable[i]; exit; end; end; KOI2ALT:=ch1; end; Function KOI2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2ISO:=ISOtable[i]; exit; end; end; KOI2ISO:=ch1; end; Function KOI2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2MAC:=MACtable[i]; exit; end; end; KOI2MAC:=ch1; end; Function KOI2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If KOITable[i]=ch1 then begin KOI2WIN:=WINtable[i]; exit; end; end; KOI2WIN:=ch1; end; Function MAC2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2ALT:=ALTtable[i]; exit; end; end; MAC2ALT:=ch1; end; Function MAC2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2ISO:=ISOtable[i]; exit; end; end; MAC2ISO:=ch1; end; Function MAC2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2KOI:=KOItable[i]; exit; end; end; MAC2KOI:=ch1; end; Function MAC2WIN(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If MACTable[i]=ch1 then begin MAC2WIN:=WINtable[i]; exit; end; end; MAC2WIN:=ch1; end; Function WIN2ALT(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2ALT:=ALTtable[i]; exit; end; end; WIN2ALT:=ch1; end; Function WIN2ISO(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2ISO:=ISOtable[i]; exit; end; end; WIN2ISO:=ch1; end; Function WIN2KOI(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2KOI:=KOItable[i]; exit; end; end; WIN2KOI:=ch1; end; Function WIN2MAC(Ch1: byte): byte; Var i: byte; begin For i:=1 to 64 do begin If WINTable[i]=ch1 then begin WIN2MAC:=MACtable[i]; exit; end; end; WIN2MAC:=ch1; end; Function ConvertString(InputString: string; Convert_Flag: byte): string; Var i: word; ConvertByte: byte; begin ConvertString:=''; If InputString='' then exit; for i:=1 to length(InputString) do begin ConvertByte:=ord(InputString[i]); Case Convert_Flag of ALT_2_ISO: ConvertByte:=Alt2Iso(ConvertByte); ALT_2_KOI: ConvertByte:=Alt2Koi(ConvertByte); ALT_2_MAC: ConvertByte:=Alt2Mac(ConvertByte); ALT_2_WIN: ConvertByte:=Alt2Win(ConvertByte); ISO_2_ALT: ConvertByte:=Iso2Alt(ConvertByte); ISO_2_KOI: ConvertByte:=Iso2Koi(ConvertByte); ISO_2_MAC: ConvertByte:=Iso2Mac(ConvertByte); ISO_2_WIN: ConvertByte:=Iso2Win(ConvertByte); KOI_2_ALT: ConvertByte:=Koi2Alt(ConvertByte); KOI_2_ISO: ConvertByte:=Koi2Iso(ConvertByte); KOI_2_MAC: ConvertByte:=Koi2Mac(ConvertByte); KOI_2_WIN: ConvertByte:=Koi2Win(ConvertByte); MAC_2_ALT: ConvertByte:=Mac2Alt(ConvertByte); MAC_2_ISO: ConvertByte:=Mac2Iso(ConvertByte); MAC_2_KOI: ConvertByte:=Mac2Koi(ConvertByte); MAC_2_WIN: ConvertByte:=Mac2Win(ConvertByte); WIN_2_ALT: ConvertByte:=Win2Alt(ConvertByte); WIN_2_ISO: ConvertByte:=Win2Iso(ConvertByte); WIN_2_KOI: ConvertByte:=Win2Koi(ConvertByte); WIN_2_MAC: ConvertByte:=Win2Mac(ConvertByte); end; InputString[i]:=chr(ConvertByte); end; ConvertString:=InputString; end; begin end. //---End of Unit RusChar
Вариант №2 (21.01.00) Автор: Алексей Вуколов
Этот вариант несколько более длинный (в плане размера таблиц перекодировки), но зато, как мне кажется, более универсальный (и, возможно, более быстрый). //--------------------------------------------------------------------------- type PCharRecodeTable = ^TCharRecodeTable; TCharRecodeTable = array[ #0..#255 ] of char; const WinToKOI8Table : TCharRecodeTable = (#$00, #$01, #$02, #$03, #$04, #$05, #$06, #$07, #$08, #$09, #$0A, #$0B, #$0C, #$0D, #$0E, #$0F, #$10, #$11, #$12, #$13, #$14, #$15, #$16, #$17, #$18, #$19, #$1A, #$1B, #$1C, #$1D, #$1E, #$1F, #$20, #$21, #$22, #$23, #$24, #$25, #$26, #$27, #$28, #$29, #$2A, #$2B, #$2C, #$2D, #$2E, #$2F, #$30, #$31, #$32, #$33, #$34, #$35, #$36, #$37, #$38, #$39, #$3A, #$3B, #$3C, #$3D, #$3E, #$3F, #$40, #$41, #$42, #$43, #$44, #$45, #$46, #$47, #$48, #$49, #$4A, #$4B, #$4C, #$4D, #$4E, #$4F, #$50, #$51, #$52, #$53, #$54, #$55, #$56, #$57, #$58, #$59, #$5A, #$5B, #$5C, #$5D, #$5E, #$5F, #$60, #$61, #$62, #$63, #$64, #$65, #$66, #$67, #$68, #$69, #$6A, #$6B, #$6C, #$6D, #$6E, #$6F, #$70, #$71, #$72, #$73, #$74, #$75, #$76, #$77, #$78, #$79, #$7A, #$7B, #$7C, #$7D, #$7E, #$7F, #$80, #$81, #$82, #$83, #$84, #$85, #$86, #$87, #$88, #$89, #$8A, #$8B, #$8C, #$8D, #$8E, #$8F, #$90, #$91, #$92, #$93, #$94, #$95, #$96, #$97, #$98, #$99, #$9A, #$9B, #$9C, #$9D, #$9E, #$9F, #$A0, #$A1, #$A2, #$A3, #$A4, #$A5, #$A6, #$A7, #$A8, #$A9, #$AA, #$AB, #$AC, #$AD, #$AE, #$AF, #$B0, #$B1, #$B2, #$B3, #$B4, #$B5, #$B6, #$B7, #$B8, #$B9, #$BA, #$BB, #$BC, #$BD, #$BE, #$BF, #$E1, #$E2, #$F7, #$E7, #$E4, #$E5, #$F6, #$FA, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF, #$F0, #$F2, #$F3, #$F4, #$F5, #$E6, #$E8, #$E3, #$FE, #$FB, #$FD, #$FF, #$F9, #$F8, #$FC, #$E0, #$F1, #$C1, #$C2, #$D7, #$C7, #$C4, #$C5, #$D6, #$DA, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF, #$D0, #$D2, #$D3, #$D4, #$D5, #$C6, #$C8, #$C3, #$DE, #$DB, #$DD, #$DF, #$D9, #$D8, #$DC, #$C0, #$D1); KOI8ToWinTable : TCharRecodeTable = (#$00, #$01, #$02, #$03, #$04, #$05, #$06, #$07, #$08, #$09, #$0A, #$0B, #$0C, #$0D, #$0E, #$0F, #$10, #$11, #$12, #$13, #$14, #$15, #$16, #$17, #$18, #$19, #$1A, #$1B, #$1C, #$1D, #$1E, #$1F, #$20, #$21, #$22, #$23, #$24, #$25, #$26, #$27, #$28, #$29, #$2A, #$2B, #$2C, #$2D, #$2E, #$2F, #$30, #$31, #$32, #$33, #$34, #$35, #$36, #$37, #$38, #$39, #$3A, #$3B, #$3C, #$3D, #$3E, #$3F, #$40, #$41, #$42, #$43, #$44, #$45, #$46, #$47, #$48, #$49, #$4A, #$4B, #$4C, #$4D, #$4E, #$4F, #$50, #$51, #$52, #$53, #$54, #$55, #$56, #$57, #$58, #$59, #$5A, #$5B, #$5C, #$5D, #$5E, #$5F, #$60, #$61, #$62, #$63, #$64, #$65, #$66, #$67, #$68, #$69, #$6A, #$6B, #$6C, #$6D, #$6E, #$6F, #$70, #$71, #$72, #$73, #$74, #$75, #$76, #$77, #$78, #$79, #$7A, #$7B, #$7C, #$7D, #$7E, #$7F, #$80, #$81, #$82, #$83, #$84, #$85, #$86, #$87, #$88, #$89, #$8A, #$8B, #$8C, #$8D, #$8E, #$8F, #$90, #$91, #$92, #$93, #$94, #$95, #$96, #$97, #$98, #$99, #$9A, #$9B, #$9C, #$9D, #$9E, #$9F, #$A0, #$A1, #$A2, #$A3, #$A4, #$A5, #$A6, #$A7, #$A8, #$A9, #$AA, #$AB, #$AC, #$AD, #$AE, #$AF, #$B0, #$B1, #$B2, #$B3, #$B4, #$B5, #$B6, #$B7, #$B8, #$B9, #$BA, #$BB, #$BC, #$BD, #$BE, #$BF, #$FE, #$E0, #$E1, #$F6, #$E4, #$E5, #$F4, #$E3, #$F5, #$E8, #$E9, #$EA, #$EB, #$EC, #$ED, #$EE, #$EF, #$FF, #$F0, #$F1, #$F2, #$F3, #$E6, #$E2, #$FC, #$FB, #$E7, #$F8, #$FD, #$F9, #$F7, #$FA, #$DE, #$C0, #$C1, #$D6, #$C4, #$C5, #$D4, #$C3, #$D5, #$C8, #$C9, #$CA, #$CB, #$CC, #$CD, #$CE, #$CF, #$DF, #$D0, #$D1, #$D2, #$D3, #$C6, #$C2, #$DC, #$DB, #$C7, #$D8, #$DD, #$D9, #$D7, #$DA); //--------------------------------------------------------------------------- function RecodeChar( Ch : char; const Table : TCharRecodeTable ) : char; begin Result := Table[ Ch ]; end; //--------------------------------------------------------------------------- function CharWinToKOI8( Ch : char ) : char; begin Result := WinToKOI8Table[ Ch ]; end; //--------------------------------------------------------------------------- function CharKOI8ToWin( Ch : char ) : char; begin Result := KOI8ToWinTable[ Ch ]; end; //--------------------------------------------------------------------------- function RecodeStr( Source : string; const Table : TCharRecodeTable ) : string; var i : integer; begin Result := ''; for i := 1 to length( Source ) do Result := Result + Table[ Source[i] ]; end; //---------------------------------------------------------------------------
Вариант №1 (17.01.00) Автор: Дмитрий В. Полщанов const Koi: Array[0..66] of Char = ('Ј', 'Ё', 'ё', 'А', 'Б', 'В', 'Г', 'Д', 'Е', 'Ж', 'З', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П', 'Р', 'С', 'Т', 'У', 'Ф', 'Х', 'Ц', 'Ч', 'Ш', 'Щ', 'Ъ', 'Ы', 'Ь', 'Э', 'Ю', 'Я', 'а', 'б', 'в', 'г', 'д', 'е', 'ж', 'з', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п', 'р', 'с', 'т', 'у', 'ф', 'х', 'ц', 'ч', 'ш', 'щ', 'ъ', 'ы', 'ь', 'э', 'ю', 'я'); Win: Array[0..66] of Char = ('ё', 'Ё', 'Ј', 'ю', 'а', 'б', 'ц', 'д', 'е', 'ф', 'г', 'х', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п', 'я', 'р', 'с', 'т', 'у', 'ж', 'в', 'ь', 'ы', 'з', 'ш', 'э', 'щ', 'ч', 'ъ', 'Ю', 'А', 'Б', 'Ц', 'Д', 'Е', 'Ф', 'Г', 'Х', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П', 'Я', 'Р', 'С', 'Т', 'У', 'Ж', 'В', 'Ь', 'Ы', 'З', 'Ш', 'Э', 'Щ', 'Ч', 'Ъ'); //--------------------------------------------------------------------------- function WinToKoi(Str: String): String; var i, j, Index: Integer; begin Result := ''; for i := 1 to Length(Str) do begin Index := -1; for j := Low(Win) to High(Win) do if Win[j] = Str[i] then begin Index := j; Break; end; if Index = -1 then Result := Result + Str[i] else Result := Result + Koi[Index]; end; end; //--------------------------------------------------------------------------- function KoiToWin(Str: String): String; var i, j, Index: Integer; begin Result := ''; for i := 1 to Length(Str) do begin Index := -1; for j := Low(Win) to High(Win) do if Koi[j] = Str[i] then begin Index := j; Break; end; if Index = -1 then Result := Result + Str[i] else Result := Result + Win[Index]; end; end; //--------------------------------------------------------------------------- procedure SendFileOnSMTP(Host: String; Port: Integer; Subject, FromAddress, ToAddress, Body, FileName: String); var NMSMTP: TNMSMTP; begin if DelSpace(ToAddress) = '' then Exit; if ToAddress[1] = ';' then Exit; if (DelSpace(FileName) <> '') and not FileExists(FileName) then raise Exception.Create('SendFileOnSMTP: file not exist: ' + FileName); NMSMTP := TNMSMTP.Create(nil); try NMSMTP.Host := Host; NMSMTP.Port := Port; NMSMTP.Charset := 'koi8-r'; NMSMTP.PostMessage.FromAddress := FromAddress; NMSMTP.PostMessage.ToAddress.Text := ToAddress; NMSMTP.PostMessage.Attachments.Text := FileName; NMSMTP.PostMessage.Subject := Subject; NMSMTP.PostMessage.Date := DateTimeToStr(Now); NMSMTP.UserID := 'netmaster'; NMSMTP.PostMessage.Body.Text := WinToKoi(Body); NMSMTP.FinalHeader.Clear; NMSMTP.TimeOut := 5000; NMSMTP.Connect; NMSMTP.SendMail; NMSMTP.Disconnect; finally NMSMTP.Free; end; end; //---------------------------------------------------------------------------
DelphiVCLFAQ
 | источник информации: |
| DELPHI VCL FAQ Перевод с английского |
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи.
Скачать (38 K) для просмотра в off-line.
Вернуться к разделу
Вопрос: Как разместить прозрачную надпись на TBitmap? Пример: procedure TForm1.Button1Click(Sender: TObject); var OldBkMode : integer; begin Image1.Picture.Bitmap.Canvas.Font.Color := clBlue; OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT); Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello'); SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode); end; Вопрос: Можно ли обратиться к колонке или строке grid'а по заголовку? Ответ: В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).
Пример: procedure TForm1.FormCreate(Sender: TObject); begin StringGrid1.Rows[1].Strings[0] := 'This Row'; StringGrid1.Cols[1].Strings[0] := 'This Column'; end; function GetGridColumnByName(Grid : TStringGrid; ColName : string): integer; var i : integer; begin for i := 0 to Grid.ColCount - 1 do if Grid.Rows[0].Strings[i] = ColName then begin Result := i; exit; end; Result := -1; end; function GetGridRowByName(Grid : TStringGrid; RowName : string): integer; var i : integer; begin for i := 0 to Grid.RowCount - 1 do if Grid.Cols[0].Strings[i] = RowName then begin Result := i; exit; end; Result := -1; end; procedure TForm1.Button1Click(Sender: TObject); var Column : integer; Row : integer; begin Column := GetGridColumnByName(StringGrid1, 'This Column'); if Column = -1 then ShowMessage('Column not found') else ShowMessage('Column found at ' + IntToStr(Column)); Row := GetGridRowByName(StringGrid1, 'This Row'); if Row = -1 then ShowMessage('Row not found') else ShowMessage('Row found at ' + IntToStr(Row)); end; Вопрос: Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.
Ответ: Можно перехватить сообщение CM_DIALOGCHAR. Пример: type TForm1 = class(TForm) PageControl1: TPageControl; TabSheet1: TTabSheet; TabSheet2: TTabSheet; TabSheet3: TTabSheet; private {Private declarations} procedure CMDialogChar(var Msg:TCMDialogChar); message CM_DIALOGCHAR; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.CMDialogChar(var Msg:TCMDialogChar); var i : integer; begin with PageControl1 do begin if Enabled then for i := 0 to PageControl1.PageCount - 1 do if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and (Pages[i].TabVisible)) then begin Msg.Result:=1; ActivePage := Pages[i]; exit; end; end; inherited; end; Вопрос: При использованиии компонента TRegistry под NT пользователь с права доступа ниже чем "администратор" не может получить доступа к информации реестра в ключе HKEY_LOCAL_MACHINE. Как это обойти?
Ответ: Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра.
Вопрос: Можно ли изменить число колонок и их ширину в компоненте TFileListBox? Ответ: В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.
Пример: with TDirectoryListBox(FileListBox1) do begin Columns := 2; SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0); end; Вопрос: Как настроить табуляцию в компоненте TMemo? Ответ: Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию табуляции на 20-й пиксел.
Пример: procedure TForm1.FormCreate(Sender: TObject); var DialogUnitsX : LongInt; PixelsX : LongInt; i : integer; TabArray : array[0..4] of integer; begin Memo1.WantTabs := true; DialogUnitsX := LoWord(GetDialogBaseUnits); PixelsX := 20; for i := 1 to 5 do begin TabArray[i - 1] :=((PixelsX * i ) * 4) div DialogUnitsX; end; SendMessage(Memo1.Handle, EM_SETTABSTOPS,5,LongInt(@TabArray)); Memo1.Refresh; end; Вопрос: Как перехватить нажатия функциональных клавиш и стрелок? Ответ: Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы.
Пример: procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_RIGHT then Form1.Caption := 'Right'; if Key = VK_F1 then Form1.Caption := 'F1'; end; Вопрос: При обработке события DrawCell компонента DrawGrid я пишу Font.Color := clRed; и получаю бесконечный цикл мерцаний. Почему?
Ответ: Правильно укажите границы используемого канваса. Пример: If (Row = 0) then begin DrawGrid1.Canvas.Font.Color := clRed; DrawGrid1.Canvas.TextOut(Rect.Left,Rect.Top, IntToStr(Col)); end; Вопрос: При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему? Ответ: Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.
Пример: var bm : TBitmap; OldBkMode : integer; begin bm := TBitmap.Create; bm.Width := BitBtn1.Glyph.Width; bm.Height := BitBtn1.Glyph.Height; bm.Canvas.Draw(0, 0, BitBtn1.Glyph); OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent); bm.Canvas.TextOut(0, 0, 'The Caption'); SetBkMode(bm.Canvas.Handle, OldBkMode); BitBtn1.Glyph.Assign(bm); end; Вопрос: Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента управления Windows? Ответ: Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.
Пример: unit caret1; interface {$IFDEF WIN32} uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; {$ELSE} uses WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; {$ENDIF} type TForm1 = class(TForm) Edit1: TEdit; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private {Private declarations} public {Public declarations} CaretBm : TBitmap; CaretBmBk : TBitmap; OldEditsWindowProc : Pointer; end; var Form1: TForm1; implementation {$R *.DFM} type {$IFDEF WIN32} WParameter = LongInt; {$ELSE} WParameter = Word; {$ENDIF} LParameter = LongInt; {New windows procedure for the edit control} function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} begin {Call the old edit controls windows procedure} NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle, TheMessage, ParamW, ParamL); if TheMessage = WM_SETFOCUS then begin CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0); ShowCaret(WindowHandle); end; if TheMessage = WM_KILLFOCUS then begin HideCaret(WindowHandle); DestroyCaret; end; if TheMessage = WM_KEYDOWN then begin if ParamW = VK_BACK then CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0) else CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0); ShowCaret(WindowHandle); end; end; procedure TForm1.FormCreate(Sender: TObject); begin {Create a smiling bitmap using the wingdings font} CaretBm := TBitmap.Create; CaretBm.Canvas.Font.Name := 'WingDings'; CaretBm.Canvas.Font.Height := Edit1.Font.Height; CaretBm.Canvas.Font.Color := clWhite; CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2; CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2; CaretBm.Canvas.Brush.Color := clBlue; CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height)); CaretBm.Canvas.TextOut(1, 1, 'J'); {Create a frowming bitmap using the wingdings font} CaretBmBk := TBitmap.Create; CaretBmBk.Canvas.Font.Name := 'WingDings'; CaretBmBk.Canvas.Font.Height := Edit1.Font.Height; CaretBmBk.Canvas.Font.Color := clWhite; CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2; CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2; CaretBmBk.Canvas.Brush.Color := clBlue; CaretBmBk.Canvas.FillRect(Rect(0,0, CaretBmBk.Width, CaretBmBk.Height)); CaretBmBk.Canvas.TextOut(1, 1, 'L'); {Hook the edit controls window procedure} OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(@NewWindowProc))); end; procedure TForm1.FormDestroy(Sender: TObject); begin {Unhook the edit controls window procedure and clean up} SetWindowLong(Edit1.Handle,GWL_WNDPROC, LongInt(OldEditsWindowProc)); CaretBm.Free; CaretBmBk.Free; end; Вопрос: При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "Statement expected, but expression of type 'Integer' found". Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти ошибку?
Ответ: Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены в Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля DBE находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна константа ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом процедуры Abort.
Пример: SysUtils.Abort; Вопрос: Почему при изменении цвета букв StatusBar'а ничего не происходит? Ответ: Status bar - стандартный элемент управления Windows, и соответственно цвет его букв - значение clBtnText которое изменяется с помощью настроек в Control Panel. Этот цвет черный по умолчанию и может изменяться в зависимости от выбранной цветовой схемы. Другие стандартные элемент управления Windows, например кнопки, также имеют цвет букв, настраиваемый из ControlPanel. StatusBar и его панели имеют свойство "owner-draw", позволяющее Вам использовать любой цвет букв.
Пример: procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin if Panel = StatusBar.Panels[0] then begin StatusBar.Canvas.Font.Color := clRed; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0') end else begin StatusBar.Canvas.Font.Color := clGreen; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1'); end; end; Вопрос: Как сделать многострочную надпись на TBitBtn? Ответ: Выводите текст надписи непосредственно на "glyph" TBitBtn'а. См. пример. Пример: procedure TForm1.FormCreate(Sender: TObject); var R : TRect; N : Integer; Buff : array[0..255] of Char; begin with BitBtn1 do begin Caption := 'A really really long caption'; Glyph.Canvas.Font := Self.Font; Glyph.Width := Width - 6; Glyph.Height := Height - 6; R := Bounds(0, 0, Glyph.Width, 0); StrPCopy(Buff, Caption); Caption := ''; DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R, DT_CENTER or DT_WORDBREAK or DT_CALCRECT); OffsetRect(R,(Glyph.Width - R.Right) div 2, (Glyph.Height - R.Bottom) div 2); DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R, DT_CENTER or DT_WORDBREAK); end; end; Вопрос: Как изменить стиль шрифта RichEdit нажатиями соответствующих комбинаций клавиш? (например включить курсив по нажатию Ctrl + I)
Ответ: В примере стили шрифта меняются по нажатию след. комбинаций клавиш Ctrl + B - вкл/выкл жирного шрифта Ctrl + I - вкл/выкл наклонного шрифта Ctrl + S - вкл/выкл зачеркнутого шрифта Ctrl + U - вкл/выкл подчеркнутого шрифта Пример: const KEY_CTRL_B = 02; KEY_CTRL_I = 9; KEY_CTRL_S = 19; KEY_CTRL_U = 21; procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char); begin case Ord(Key) of KEY_CTRL_B: begin Key := #0; if fsBold in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsBold] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsBold]; end; KEY_CTRL_I: begin Key := #0; if fsItalic in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style - [fsItalic] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style + [fsItalic]; end; KEY_CTRL_S: begin Key := #0; if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style-[fsStrikeout] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style+[fsStrikeout]; end; KEY_CTRL_U: begin Key := #0; if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style-[fsUnderline] else (Sender as TRichEdit).SelAttributes.Style := (Sender as TRichEdit).SelAttributes.Style+[fsUnderline]; end; end; end; Вопрос: В документации компонента TRegIniFile говорится, что можно изменять корневой ключ (root key). Я пытаюсь это сделать но ничего не получается.
Ответ: См. пример. Пример: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var WinIni : TRegIniFile; begin WinIni := TRegIniFile.Create(''); WinIni.RootKey := HKEY_LOCAL_MACHINE; WinIni.WriteString('Frank','Borland','Writes Fast Code!'); WinIni.Free; end; Вопрос: Можно ли динамически изменять свойство "owner" компонента во время выполнения программы? Ответ: Вы можете менять свойство "owner" и после создания компонента с помощью методов InsertComponent() и RemoveComponent().
Вопрос: Как очистить содержимое Canvas'а? Ответ: Просто нарисуйте прямоугольник любого цвета. Пример: Canvas.Brush.Color := ClWhite; Canvas.FillRect(Canvas.ClipRect); Вопрос: Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
Ответ: Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы. begin Application.Initialize; if then begin Application.CreateForm(TForm1, Form1); Application.CreateForm(TForm2, Form2); end else begin Application.CreateForm(TForm2, Form2); Application.CreateForm(TForm1, Form1); end; end. Application.Run; Вопрос: Как программно "щелкнуть" по компоненту speed button? Я пытался использовать SendMessage но у Speedbuttons нет "handle".
Наверх к содержанию Вопрос: Можно ли отключить определенный элемент в RadioGroup? Ответ: В примере показано как получить доступ к отдельным элементам компонента TRadioGroup. Пример: procedure TForm1.Button1Click(Sender: TObject); begin TRadioButton(RadioGroup1.Controls[1]). Enabled := False; end; Вопрос: Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче? Ответ: Так работает большинство графических систем, включая Windows. Библиотека VCL просто передает вызовы в функции GDI. Если Вы хотите нарисовать линию с последним пикселом включительно просто добавте единицу к координатам.
Вопрос: Как показать подсказки "hints" для элементов меню? Ответ: В примере создается обработчик события Application.Hint - подсказки меню изображаются на status panel. Пример: type TForm1 = class(TForm) Panel1: TPanel; MainMenu1: TMainMenu; MenuItemFile: TMenuItem; MenuItemOpen: TMenuItem; MenuItemClose: TMenuItem; OpenDialog1: TOpenDialog; procedure FormCreate(Sender: TObject); procedure MenuItemCloseClick(Sender: TObject); procedure MenuItemOpenClick(Sender: TObject); private {Private declarations} procedure HintHandler(Sender: TObject); public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Panel1.Align := alBottom; MenuItemFile.Hint := 'File Menu'; MenuItemOpen.Hint := 'Opens A File'; MenuItemClose.Hint := 'Closes the Application'; Application.OnHint := HintHandler; end; procedure TForm1.HintHandler(Sender: TObject); begin Panel1.Caption := Application.Hint; end; procedure TForm1.MenuItemCloseClick(Sender: TObject); begin Application.Terminate; end; procedure TForm1.MenuItemOpenClick(Sender: TObject); begin if OpenDialog1.Execute then Form1.Caption := OpenDialog1.FileName; end; Вопрос: Как опеделить состояние списка ComboBox, выпал/скрыт? Ответ: Пошлите ComboBox сообщение CB_GETDROPPEDSTATE. Пример: if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE,0,0) = 1 then begin {список ComboBox выпал} end; Вопрос: Как удалить каталог вместе со всеми содержащимися в нем файлами? Ответ: В примере стираются все файлы в каталоге и сам каталог. Чтобы удалить файл, помечанные только для чтения (read only) и занятые другими программами в момент удаления - напишите дополнительную процедуру.
procedure TForm1.Button1Click(Sender: TObject); var DirInfo: TSearchRec; r: integer; begin r := FindFirst('C:\Download\*.*', FaAnyfile, DirInfo); while r = 0 do begin if ((DirInfo.Attr and FaDirectory <> FaDirectory) and (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then if DeleteFile(pChar('C:\Download\' + DirInfo.Name))= false then ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name); r := FindNext(DirInfo); end; SysUtils.FindClose(DirInfo); if RemoveDirectory('C:\Download\') = false then ShowMessage('Unable to delete directory: C:\Download\'); end; Вопрос: Как отключить системное меню формы и кнопки Minimize, Maximize, and Close во время выполнения(Runtime)?
Ответ: В приведенном примере показано как это сделать Пример: procedure TForm1.Button1Click(Sender: TObject); begin {Disable} Form1.BorderIcons := Form1.BorderIcons - [biSystemMenu, biMinimize, biMaximize]; end; procedure TForm1.Button2Click(Sender: TObject); begin {Enable} Form1.BorderIcons := Form1.BorderIcons + [biSystemMenu, biMinimize, biMaximize]; end; Вопрос: Как извлечь Red, Green, и Blue компонент из определенного цвета? Ответ: Используйте функции Window API Get RValue(), GetGValue(), и GetBValue(). Пример: procedure TForm1.Button1Click(Sender: TObject); begin Form1.Canvas.Pen.Color := clRed; Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color))); Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color))); end; Вопрос: Как определить номер текущей строки в TMemo? Ответ: Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение EM_LINEFROMCHAR
Пример: procedure TForm1.Button1Click(Sender: TObject); var LineNumber : integer; begin LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0); ShowMessage(IntToStr(LineNumber)); end; Вопрос: Как проигрываеть MPEG файл в Delphi-программе? Ответ: Если в системе Windows MMSystem установлен декодер MPEG - используя компонент TMediaPlayer Пример: procedure TForm1.Button1Click(Sender: TObject); begin MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg'; MediaPlayer1.Open; MediaPlayer1.Display := Panel1; MediaPlayer1.DisplayRect := Panel1.ClientRect; MediaPlayer1.Play; end; Вопрос: Как использовать анимированный курсор? Ответ: Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.
Пример: procedure TForm1.Button1Click(Sender: TObject); var h : THandle; begin h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE); if h = 0 then ShowMessage('Cursor not loaded') else begin Screen.Cursors[1] := h; Form1.Cursor := 1; end; end; Вопрос: Как узнать о нажатии "non-menu" клавиши в момент когда меню показано? Ответ: Создайте обработчик сообщения WM_MENUCHAR. Пример: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus; type TForm1 = class(TForm) MainMenu1: TMainMenu; One1: TMenuItem; Two1: TMenuItem; THree1: TMenuItem; private {Private declarations} procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WmMenuChar(var m : TMessage); begin Form1.Caption := 'Non standard menu key pressed'; m.Result := 1; end; end. Вопрос: Как определить наличие сопроцессора? Ответ: В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.
Пример: {$IFDEF WIN32} uses Registry; {$ENDIF} function HasCoProcesser : bool; {$IFDEF WIN32} var TheKey : hKey; {$ENDIF} begin Result := true; {$IFNDEF WIN32} if GetWinFlags and Wf_80x87 = 0 then Result := false; {$ELSE} if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0, KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result := false; RegCloseKey(TheKey); {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); begin if HasCoProcesser then ShowMessage('Has CoProcessor') else ShowMessage('No CoProcessor - Windows Emulation Mode'); end; Вопрос: Как узнать серийный номер аудио CD? Ответ: CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.
Пример: uses MMSystem, MPlayer; procedure TForm1.Button1Click(Sender: TObject); var mp : TMediaPlayer; msp : TMCI_INFO_PARMS; MediaString : array[0..255] of char; ret : longint; begin mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := 'D:'; mp.Open; Application.ProcessMessages; FillChar(MediaString, sizeof(MediaString), #0); FillChar(msp, sizeof(msp), #0); msp.lpstrReturn := @MediaString; msp.dwRetSize := 255; ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, longint(@msp)); if Ret <> 0 then begin MciGetErrorString(ret, @MediaString, sizeof(MediaString)); Memo1.Lines.Add(StrPas(MediaString)); end else Memo1.Lines.Add(StrPas(MediaString)); mp.Close; Application.ProcessMessages; mp.free; end; end. Вопрос: Как вывести на элемент управления (Window control) текст, содержащий амперсанд - & ? Ответ: Используя два амперсанда подряд. Windows интерпритирует одиночный амперсанд как указание на то, что следующий символ - горячая клавиша (и поддчеркивает следующий символ вместо излбражения аперсанда).
Пример: Button1.Caption := 'Черное && Белое'; Вопрос: Как поместить bitmap в Metafile? Ответ: см. пример Пример: procedure TForm1.Button1Click(Sender: TObject); var m : TmetaFile; mc : TmetaFileCanvas; b : tbitmap; begin m := TMetaFile.Create; b := TBitmap.create; b.LoadFromFile('C:\SomePath\SomeBitmap.BMP'); m.Height := b.Height; m.Width := b.Width; mc := TMetafileCanvas.Create(m, 0); mc.Draw(0, 0, b); mc.Free; b.Free; m.SaveToFile('C:\SomePath\Test.emf'); m.Free; Image1.Picture.LoadFromFile('C:\SomePath\Test.emf'); end; Вопрос: Как узнать, что курсор мыши над моей формой? Ответ: Можно использовать функцию GetCapture() из Windows API. Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture. Пример: procedure TForm1.FormDeactivate(Sender: TObject); begin ReleaseCapture; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin If GetCapture = 0 then SetCapture(Form1.Handle); if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width, Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then Form1.Caption := 'Мышка над формой!' else Form1.Caption := 'Мышка вне формы...'; end; Вопрос: Как программно определить, что приложение работает под Windows NT? Ответ:см. пример Пример: function IsNT : bool; var osv : TOSVERSIONINFO; begin result := true; GetVersionEx(osv); if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit; result := false; end; procedure TForm1.Button1Click(Sender: TObject); begin if IsNt then ShowMessage('Running on NT') else ShowMessage('Not Running on NT'); end; Вопрос: Как создать bitmap из пиктогрммы (icon)? Ответ: Используя Bitmap.Canvas.Draw нарисуйте пиктограмму на Bitmap'е. Пример: procedure TForm1.Button1Click(Sender: TObject); var TheIcon : TIcon; TheBitmap : TBitmap; begin TheIcon := TIcon.Create; TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO'); TheBitmap := TBitmap.Create; TheBitmap.Height := TheIcon.Height; TheBitmap.Width := TheIcon.Width; TheBitmap.Canvas.Draw(0, 0, TheIcon); Form1.Canvas.Draw(10, 10, TheBitmap); TheBitmap.Free; TheIcon.Free; end; Вопрос: Как создать отдельную подсказку (hint) для каждой ячейки StringGrid? Ответ: В приведенном примере отслеживается движение курсора мыши - при перемещении между ячейками StringGrid'а - появляется окно подсказки(hint), показываеющее номер текущей строки и колонки.
Пример: type TForm1 = class(TForm) StringGrid1: TStringGrid; procedure StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure FormCreate(Sender: TObject); private {Private declarations} Col : integer; Row : integer; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin StringGrid1.Hint := '0 0'; StringGrid1.ShowHint := True; end; procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var r : integer; c : integer; begin StringGrid1.MouseToCell(X, Y, C, R); with StringGrid1 do begin if ((Row <> r) or(Col <> c)) then begin Row := r; Col := c; Application.CancelHint; StringGrid1.Hint :=IntToStr(r)+#32+IntToStr(c); end; end; end; Вопрос: Как внести изменения в код VCL? Ответ: Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support.
-Но если Вы решили сделать это...
Изменеия в код VCL никогда не должны вносится в секцию "interface" модуля - только в секцию "implimentation". Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "library path" можно изменить в меню:
Delphi 1 : Options | Environment | Library Delphi 2 : Tools | Options | Library Delphi 3 : Tools | Environment Options | Library Delphi 4 : Tools | Environment Options | Library C++ Builder : Options | Environment | Library Вопрос: Как в Delphi реализовать функцию - эквивалент TwipsPerPixel из VisualBasic? Ответ: Функции TwipsPerPixelX и TwipsPerPixelY, приведенные в примере реализуют ту же функциональность в Delphi. Пример: function TwipsPerPixelX(Canvas : TCanvas) : Extended; begin result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSX); end; function TwipsPerPixelY(Canvas : TCanvas) : Extended; begin result := 1440 / GetDeviceCaps(Canvas.Handle, LOGPIXELSY); end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(FloatToStr(TwipsPerPixelX(Form1.Canvas))); ShowMessage(FloatToStr(TwipsPerPixelY(Form1.Canvas))); end; Вопрос: Как вставить содержимое файла в текущую позицию курсора в компонете TMemo? Ответ: Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf() для вставки текста;
var TheMStream : TMemoryStream; Zero : char; begin TheMStream := TMemoryStream.Create; TheMStream.LoadFromFile('C:\AUTOEXEC.BAT'); TheMStream.Seek(0, soFromEnd); //Null terminate the buffer! Zero := #0; TheMStream.Write(Zero, 1); TheMStream.Seek(0, soFromBeginning); Memo1.SetSelTextBuf(TheMStream.Memory); TheMStream.Free; end; Вопрос: Как в компоненте TMemo перехватить нажатие Ctrl-V и вставить специальный текст не из буфера обмена (clipboard)?
Ответ: См. пример. Пример: uses ClipBrd; procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if ((Key = ord('V')) and (ssCtrl in Shift)) then begin if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear; Memo1.SelText := 'Delphi is RAD!'; key := 0; end; end; Вопрос: Как создать эквивалент TEdit но только с выравниваением вводимого текста по центру или по правой стороне?
Ответ: TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
Пример: procedure TForm1.FormCreate(Sender: TObject); begin Memo1.Alignment := taRightJustify; Memo1.MaxLength := 24; Memo1.WantReturns := false; Memo1.WordWrap := false; end; procedure MultiLineMemoToSingleLine(Memo : TMemo); var t : string; begin t := Memo.Text; if Pos(#13, t) > 0 then begin while Pos(#13, t) > 0 do delete(t, Pos(#13, t), 1); while Pos(#10, t) > 0 do delete(t, Pos(#10, t), 1); Memo.Text := t; end; end; procedure TForm1.Memo1Change(Sender: TObject); begin MultiLineMemoToSingleLine(Memo1); end; procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); begin MultiLineMemoToSingleLine(Memo1); end; Вопрос: Как запрограммировать undo? Ответ:См. пример Memo1.Perform(EM_UNDO, 0, 0); Если Вы хотите узнать, возможно ли выполнить операцию "Undo", проверьте "Undo status": If Memo1.Perform(EM_CANUNDO, 0, 0) <> 0 then begin {Undo is possible} end; Для выполнения "Redo" выполните "Undo" еще раз. Вопрос: Можно ли создать форму, которая получает дополнительные параметры в методе Сreate? Ответ: Просто замените конструктор Create класса Вашей формы. Пример: unit Unit2; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm2 = class(TForm) private {Private declarations} public constructor CreateWithCaption(aOwner: TComponent; aCaption: string); {Public declarations} end; var Form2: TForm2; implementation {$R *.DFM} constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string); begin Create(aOwner); Caption := aCaption; end; uses Unit2; procedure TForm1.Button1Click(Sender: TObject); begin Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption'); Unit2.Form2.Show; end; Вопрос: Почему при изменении цвета шрифта в StatusBar's он (шрифт) не меняется? Ответ: Status bar (строка состояния) - стандартный элемент управления Windows и цвет его шрифта задается через Control Panel (константа clBtnText). Этот цвет по умолчанию черный и может меняться при выборе пользователем той или иной цветовой схемы. У компонента ТStatusBar и его панелей есть возможность "owner-draw" - программной перерисовки, которая позволяет выводить на панель текст любого цвета. Измените свойство Style компонента TStatusBar.Panels на OwnerDraw.
Пример: procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin if Panel = StatusBar.Panels[0] then begin StatusBar.Canvas.Font.Color := clRed; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0') end else begin StatusBar.Canvas.Font.Color := clGreen; StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1'); end; end; Вопрос: Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?
Ответ: В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.
Пример: uses CommCtrl, ComCtrls; type TMyTrackBar = class(TTrackBar) procedure CreateParams(var Params: TCreateParams); override; end; procedure TMyTrackBar.CreateParams(var Params: TCreateParams); begin inherited; Params.Style := Params.Style and not TBS_ENABLESELRANGE; end; var MyTrackbar : TMyTrackbar; procedure TForm1.Button1Click(Sender: TObject); begin MyTrackBar := TMyTrackbar.Create(Form1); MyTrackbar.Parent := Form1; MyTrackbar.Left := 100; MyTrackbar.Top := 100; MyTrackbar.Width := 150; MyTrackbar.Height := 45; MyTrackBar.Visible := true; end; Вопрос: Мне нужен временный canvas, но когда я пытаюсь его создать получаю сообщения об ошибках. Как создать TCanvas?
Ответ: Создайте Bitmap и используйте свойство canvas класса TBitmap. Пример создает Bitmap, рисует на его canvas'е, выводит этот canvas на форму и освобождает bitmap.
Пример: procedure TForm1.Button1Click(Sender: TObject); var bm : TBitmap; begin bm := TBitmap.Create; bm.Width := 100; bm.Height := 100; bm.Canvas.Brush.Color := clRed; bm.Canvas.FillRect(Rect(0, 0, 100, 100)); bm.Canvas.MoveTo(0, 0); bm.Canvas.LineTo(100, 100); Form1.Canvas.StretchDraw(Form1.ClientRect,Bm); bm.Free; end; Вопрос: В некоторых видео режимах прозрачная часть glyph'а стандартного TBitBtn становится видной. Как этого избежать?
Ответ: В примере используется техника закраски прозрачной части glyph'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.
Пример: function InitStdBitBtn(BitBtn : TBitBtn; kind : TBitBtnKind) : bool; var Bm1 : TBitmap; Bm2 : TBitmap; begin Result := false; if Kind = bkCustom then exit; Bm1 := TBitmap.Create; case Kind of bkOK : Bm1.Handle := LoadBitmap(hInstance, 'BBOK'); bkCancel : Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL'); bkHelp : Bm1.Handle := LoadBitmap(hInstance, 'BBHELP'); bkYes : Bm1.Handle := LoadBitmap(hInstance, 'BBYES'); bkNo : Bm1.Handle := LoadBitmap(hInstance, 'BBNO'); bkClose : Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE'); bkAbort : Bm1.Handle := LoadBitmap(hInstance, 'BBABORT'); bkRetry : Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY'); bkIgnore : Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE'); bkAll : Bm1.Handle := LoadBitmap(hInstance, 'BBALL'); end; Bm2 := TBitmap.Create; Bm2.Width := Bm1.Width; Bm2.Height := Bm1.Height; Bm2.Canvas.Brush.Color := ClBtnFace; Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), Bm1.canvas.pixels[0,0]); Bm1.Free; LockWindowUpdate(BitBtn.Parent.Handle); BitBtn.Kind := kind; BitBtn.Glyph.Assign(bm2); LockWindowUpdate(0); Bm2.Free; Result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin InitStdBitBtn(BitBtn1, bkOk); end; Вопрос: Создание PolyPolygon используя массив точек? Ответ: Polygon - метод компонента TCanvas получает в качестве параметра динамический массив точек. Функция PolyPolygon() из Windows GDI получает указатель на массив точек.
Пример: procedure TForm1.Button1Click(Sender: TObject); var ptArray : array[0..9] of TPOINT; PtCounts : array[0..1] of integer; begin PtArray[0] := Point(0, 0); PtArray[1] := Point(0, 100); PtArray[2] := Point(100, 100); PtArray[3] := Point(100, 0); PtArray[4] := Point(0, 0); PtCounts[0] := 5; PtArray[5] := Point(25, 25); PtArray[6] := Point(25, 75); PtArray[7] := Point(75, 75); PtArray[8] := Point(75, 25); PtArray[9] := Point(25, 25); PtCounts[1] := 5; PolyPolygon(Form1.Canvas.Handle, PtArray,PtCounts,2); end; Вопрос: Как создать невизуальный компонент без иконоки, которая изображается в палитре компонентов в "design-time" (вроде TField)?
Ответ: Невизуальные компоненты без иконоки удобны для субкомпонентов, связанных с какими-то другими компонентами. Создайте компонент как обычно, но используйте RegisterNoIcon вместо RegisterComponent.
Вопрос: Как показывать нестандартный встроенный редактор (inplace editor) в ячейке stringgrid (например combobox).
Ответ: См. пример Пример: procedure TForm1.FormCreate(Sender: TObject); begin {Высоту combobox'а не изменишь, так что вместо combobox'а будем изменять высоту строки grid'а !} StringGrid1.DefaultRowHeight := ComboBox1.Height; {Спрятать combobox} ComboBox1.Visible := False; ComboBox1.Items.Add('Delphi Kingdom'); ComboBox1.Items.Add('Королевство Дельфи'); end; procedure TForm1.ComboBox1Change(Sender: TObject); begin {Перебросим выбранное в значение из ComboBox в grid} StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex]; ComboBox1.Visible := False; StringGrid1.SetFocus; end; procedure TForm1.ComboBox1Exit(Sender: TObject); begin {Перебросим выбранное в значение из ComboBox в grid} StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] :=ComboBox1.Items[ComboBox1.ItemIndex]; ComboBox1.Visible := False; StringGrid1.SetFocus; end; procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); var R: TRect; begin if ((ACol = 3) AND (ARow <> 0)) then begin {Ширина и положение ComboBox должно соответствовать ячейке StringGrid} R := StringGrid1.CellRect(ACol, ARow); R.Left := R.Left + StringGrid1.Left; R.Right := R.Right + StringGrid1.Left; R.Top := R.Top + StringGrid1.Top; R.Bottom := R.Bottom + StringGrid1.Top; ComboBox1.Left := R.Left + 1; ComboBox1.Top := R.Top + 1; ComboBox1.Width := (R.Right + 1) - R.Left; ComboBox1.Height := (R.Bottom + 1) - R.Top; {Покажем combobox} ComboBox1.Visible := True; ComboBox1.SetFocus; end; CanSelect := True; end; Вопрос: Как узнать есть ли в заданном CD-ROM'е Audio CD? Ответ: Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.
Пример: function IsAudioCD(Drive : char) : bool; var DrivePath : string; MaximumComponentLength : DWORD; FileSystemFlags : DWORD; VolumeName : string; Begin sult := false; DrivePath := Drive + ':\'; if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then exit; SetLength(VolumeName, 64); GetVolumeInformation(PChar(DrivePath),PChar(VolumeName), Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0); if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then result := true; end; function PlayAudioCD(Drive : char) : bool; var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; if not IsAudioCD(Drive) then exit; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Shareable := true; mp.Open; Application.ProcessMessages; mp.Play; Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin if not PlayAudioCD('D') then ShowMessage('Not an Audio CD'); end; Вопрос: Как узнать есть ли у мыши колесико? Ответ: Свойство "WheelPresent" глобального обьекта "mouse". Вопрос: События KeyPress и KeyDown не вызываются для клавиши Tab - как определить, что она была нажата?
Ответ: На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается обработчик события CM_Dialog для перехвата Dialog keys.
Пример: type TForm1 = class(TForm) private procedure CMDialogKey( Var msg: TCMDialogKey ); message CM_DIALOGKEY; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.CMDialogKey(var msg: TCMDialogKey); begin if msg.Charcode <> VK_TAB then inherited; end; procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_TAB then Form1.Caption := 'Tab Key Down!'; end; Вопрос: В чем отличие между Create(Self) и Create(Application)? Ответ: Self может быть использовано только в методе класса, и ссылается на текущий экземпляр класса. Таким образом "Self" в методе класса TForm1 ссылается на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца (owner) в конструктор. При уничтожении формы или компонента автоматически уничтожаются и все компоненты владельцем которого она является. Таким образом если при создании формы передать в качестве владельца Application эта форма будет автоматически уничтожена при уничтожении Application. Если же при создании формы передать в качестве владельца другую форму, вновь созданная форма будет автоматически уничтоженна при уничтожении формы-владельца.
Вопрос: Как во время выполнения определить поддерживает ли обьект заданное свойство? Ответ: function HasProperty(Obj : TObject; Prop : string) : PPropInfo; begin Result := GetPropInfo(Obj.ClassInfo, Prop); end; procedure TForm1.Button1Click(Sender: TObject); var p : pointer; begin p := HasProperty(Button1, 'Color'); if p <> nil then SetOrdProp(Button1, p, clRed) else ShowMessage('Button has no color property'); p := HasProperty(Label1, 'Color'); if p <> nil then SetOrdProp(Label1, p, clRed) else ShowMessage('Label has no color property'); p := HasProperty(Label1.Font, 'Color'); if p <> nil then SetOrdProp(Label1.Font.Color, p, clBlue) else ShowMessage('Label.Font has no color property'); end; Вопрос: Как при проигрывании музыки с Audio CD показывать сколько прошло минут и секунд? Ответ: В примере время выводится по таймеру. Пример: uses MMSystem; procedure TForm1.Timer1Timer(Sender: TObject); var Trk : Word; Min : Word; Sec : Word; begin with MediaPlayer1 do begin Trk := MCI_TMSF_TRACK(Position); Min := MCI_TMSF_MINUTE(Position); Sec := MCI_TMSF_SECOND(Position); Label1.Caption := Format('%.2d',[Trk]); Label2.Caption := Format('%.2d:%.2d',[Min,Sec]); end; end; Вопрос: Можно ли рисовать на рамке формы? Ответ: Обрабатывайте событие WM_NCPAINT. В примере рамка обводится красной линией толщиной в 1 пиксел. Пример: type TForm1 = class(TForm) private {Private declarations} procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCPaint(var Msg: TWMNCPaint); var dc : hDc; Pen : hPen; OldPen : hPen; OldBrush : hBrush; begin inherited; dc := GetWindowDC(Handle); msg.Result := 1; Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0)); OldPen := SelectObject(dc, Pen); OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH)); Rectangle(dc, 0,0, Form1.Width, Form1.Height); SelectObject(dc, OldBrush); SelectObject(dc, OldPen); DeleteObject(Pen); ReleaseDC(Handle, Canvas.Handle); end; Вопрос: Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением? Ответ: Создайте процедуру, которая будет вызываться при событии Application.OnIdle. Обьявим процедуру: {Private declarations} procedure IdleEventHandler(Sender: TObject; var Done: Boolean); В разделе implementation опишем поцедуру: procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean); begin {Do a small bit of work here} Done := false; end; В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии Application.OnIdle. Application.OnIdle := IdleEventHandler; Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной Done присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной Done не присвоенно значение True.
Вопрос: При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup логичным?
Ответ: Установка свойства RadioGroup'ы TabStop в false должна решить эту проблему - поскольку клавиша tab будет продолжать работать - перемещаясь сразу на выделенный пункт RadioGroup.
Вопрос: Как разместить маленькие картинки в компоненте TPopUpMenu? Ответ: В приведенном примере показано как это сделать с использованием функции Windows API SetMenuItemBitmaps(). Эта функция получает handle popup menu, позицию строчки меню куда будет помещена картинка, и два дескриптора(handles) на две картинки (одна из них - картинка которая будет показана когда строка меню доступна, вторая - когда строка меню недоступна).
type TForm1 = class(TForm) PopupMenu1: TPopupMenu; Pop11: TMenuItem; Pop21: TMenuItem; Pop31: TMenuItem; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private {Private declarations} bmUnChecked : TBitmap; bmChecked : TBitmap; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin bmUnChecked := TBitmap.Create; bmUnChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\ALARMRNG.BMP'); bmChecked := TBitmap.Create; bmChecked.LoadFromFile('C:\Program Files\Borland\BitBtns\CHECK.BMP'); {Add the bitmaps to the item at index 1 in PopUpMenu} SetMenuItemBitmaps(PopUpMenu1.Handle,1,MF_BYPOSITION,BmUnChecked.Handle, BmChecked.Handle); end; procedure TForm1.FormDestroy(Sender: TObject); begin bmUnChecked.Free; bmChecked.Free; end; procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var pt : TPoint; begin pt := ClientToScreen(Point(x, y)); PopUpMenu1.Popup(pt.x, pt.y); end; Вопрос: Как узнать число кадров AVI файла, и выяснить как долго будет проигрывться этот файл? Ответ: В приведенном примере указано как получить эту информацию. Пример: procedure TForm1.Button1Click(Sender: TObject); begin MediaPlayer1.TimeFormat := tfFrames; ShowMessage('Number of frames = ' + IntToStr(MediaPlayer1.Length)); MediaPlayer1.TimeFormat := tfMilliseconds; ShowMessage('Number of milliseconds = ' + IntToStr(MediaPlayer1.Length)); end; Вопрос: Как изменить число фиксированных колонок в TDbGrid? Пример: procedure TForm1.Button1Click(Sender: TObject); begin TStringGrid(DbGrid1).FixedCols := 2; end; Вопрос: Некоторые компоненты баз данных (и среди них TDBGrid) никак не меняют визуальных свойств, когда к ним отключен доступ (disabled). Как это изменить програмно?
Ответ: Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу управления (в данном случае TDBGrid) запрещен (disabled).
procedure TForm1.Button1Click(Sender: TObject); begin DbGrid1.Enabled := false; DbGrid1.Font.Color := clGray; end; procedure TForm1.Button2Click(Sender: TObject); begin DbGrid1.Enabled := true; DbGrid1.Font.Color := clBlack; end; Вопрос: Как определить нажаты ли клавиши Shift, Alt, or Ctrl в какой-либо момент времени? Ответ: В приведенном примере показано как определить нажата ли клавиша Shift при выборе строчки меню. Пример также содержит функции проверки состояния клавиш Alt, Ctrl.
Пример: function CtrlDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Control] And 128) <> 0); end; function ShiftDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Shift] and 128) <> 0); end; function AltDown : Boolean; var State : TKeyboardState; begin GetKeyboardState(State); Result := ((State[vk_Menu] and 128) <> 0); end; procedure TForm1.MenuItem12Click(Sender: TObject); begin if ShiftDown then Form1.Caption := 'Shift' else Form1.Caption := ''; end; Вопрос: Как изменить шрифта hint'а? Ответ: В примере перехватывается событие Application.OnShowHint и изменяется шрифт Hint'а. Пример: type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private {Private declarations} public procedure MyShowHint(var HintStr: string; var CanShow: Boolean;var HintInfo: THintInfo); {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); var i : integer; begin for i := 0 to Application.ComponentCount - 1 do if Application.Components[i] is THintWindow then with THintWindow(Application.Components[i]).Canvas do begin Font.Name:= 'Arial'; Font.Size:= 18; Font.Style:= [fsBold]; HintInfo.HintColor:= clWhite; end; end; procedure TForm1.FormCreate(Sender: TObject); begin Application.OnShowHint := MyShowHint; end; Вопрос: Есть ли в Delphi эквивалент функции SendKeys Visual Basic'а? Ответ: Ниже приведена процедура, позволяющаю отправлять нажатия в любой элемент управления (window control), способный принимать ввод с клавиатуры. Вы можете использовать эту технику чтобы включать клавиши NumLock, CapsLock и ScrollLock под Windows NT. Та же техника работает и под Windows 95 для CapsLock и ScrollLock но не работает для клавиши NumLock.
Обратите внимание, что приведены четыре поцедуры: SimulateKeyDown() - эмулировать нажатие клавиши (без отпускания) SimulateKeyUp() - эмулировать отпускание клавиши SimulateKeystroke() - эмулировать удар по клавише (нажатие и отпускание) и SendKeys(), позволяющие Вам гибко контролировать посылаемые сообщения клавиатуры.
SimulateKeyDown(), SimulateKeyUp() и SimulateKeystroke() получают коды виртуальных клавиш (virtural key) (вроде VK_F1). Процедура SimulateKeystroke() получает дополнительный параметр, полезный при эмуляции нажатия PrintScreen. Когда этот параметр равен нулю весь экран будет скопирован в буфер обмена (clipboard). Если дополнительный параметр равен 1 будет скопированно только активное окно.
Четыре метода "button click" демонстрируют использование: ButtonClick1 - включает capslock ButtonClick2 - перехватывает весь экран в буфер обмена (clipboard). ButtonClick3 - перехватывает активное окно в буфер обмена (clipboard). ButtonClick4 - устанавливает фокус в Edit и отправляет в него строку.
Пример: procedure SimulateKeyDown(Key : byte); begin keybd_event(Key, 0, 0, 0); end; procedure SimulateKeyUp(Key : byte); begin keybd_event(Key, 0, KEYEVENTF_KEYUP, 0); end; procedure SimulateKeystroke(Key : byte; extra : DWORD); begin keybd_event(Key,extra,0,0); keybd_event(Key,extra,KEYEVENTF_KEYUP,0); end; procedure SendKeys(s : string); var i : integer; flag : bool; w : word; begin {Get the state of the caps lock key} flag := not GetKeyState(VK_CAPITAL) and 1 = 0; {If the caps lock key is on then turn it off} if flag then SimulateKeystroke(VK_CAPITAL, 0); for i := 1 to Length(s) do begin w := VkKeyScan(s[i]); {If there is not an error in the key translation} if ((HiByte(w) <> $FF) and (LoByte(w) <> $FF)) then begin {If the key requires the shift key down - hold it down} if HiByte(w) and 1 = 1 then SimulateKeyDown(VK_SHIFT); {Send the VK_KEY} SimulateKeystroke(LoByte(w), 0); {If the key required the shift key down - release it} if HiByte(w) and 1 = 1 then SimulateKeyUp(VK_SHIFT); end; end; {if the caps lock key was on at start, turn it back on} if flag then SimulateKeystroke(VK_CAPITAL, 0); end; procedure TForm1.Button1Click(Sender: TObject); begin {Toggle the cap lock} SimulateKeystroke(VK_CAPITAL, 0); end; procedure TForm1.Button2Click(Sender: TObject); begin {Capture the entire screen to the clipboard} {by simulating pressing the PrintScreen key} SimulateKeystroke(VK_SNAPSHOT, 0); end; procedure TForm1.Button3Click(Sender: TObject); begin {Capture the active window to the clipboard} {by simulating pressing the PrintScreen key} SimulateKeystroke(VK_SNAPSHOT, 1); end; procedure TForm1.Button4Click(Sender: TObject); begin {Set the focus to a window (edit control) and send it a string} Application.ProcessMessages; Edit1.SetFocus; SendKeys('Delphi Is RAD!'); end; Вопрос: Я загружаю TImageList динамически. Как сделать картинки из TImageList прозрачными? Ответ: См. ответ. Пример: procedure TForm1.Button1Click(Sender: TObject); var bm : TBitmap; il : TImageList; begin bm := TBitmap.Create; bm.LoadFromFile('C:\DownLoad\TEST.BMP'); il := TImageList.CreateSize(bm.Width,bm.Height); il.DrawingStyle := dsTransparent; il.Masked := true; il.AddMasked(bm, clRed); il.Draw(Form1.Canvas, 0, 0, 0); bm.Free; il.Free; end; Вопрос: Как заставить TMediaPlayer проигрывать одно и тоже бесконечно? AVI например? Ответ: В примере AVI файл проигрывается снова и снова - используем событие MediaPlayer'а Notify Пример: procedure TForm1.MediaPlayer1Notify(Sender: TObject); begin with MediaPlayer1 do if NotifyValue = nvSuccessful then begin Notify := True; Play; end; end; Вопрос: При выполнении диалога FontDialog со свойством Device равным fdBoth or fdPrinter, появляется ошибка "There are no fonts installed".
Ответ: Эти установки должны показать шрифты совместимые либо с принтером либо с экраном. В примере диалог Windows ChooseFont вызывается напрямую чтобы показать список шрифтов, совместимых одновременно и с экраном и с принтером.
Пример: uses Printers, CommDlg; procedure TForm1.Button1Click(Sender: TObject); var cf : TChooseFont; lf : TLogFont; tf : TFont; begin if PrintDialog1.Execute then begin GetObject(Form1.Canvas.Font.Handle, sizeof(lf),@lf); FillChar(cf, sizeof(cf), #0); cf.lStructSize := sizeof(cf); cf.hWndOwner := Form1.Handle; cf.hdc := Printer.Handle; cf.lpLogFont := @lf; cf.iPointSize := Form1.Canvas.Font.Size * 10; cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG; cf.rgbColors := Form1.Canvas.Font.Color; if ChooseFont(cf) <> false then begin tf := TFont.Create; tf.Handle := CreateFontIndirect(lf); tf.COlor := cf.RgbColors; Form1.Canvas.Font.Assign(tf); tf.Free; Form1.Canvas.TextOut(10, 10, 'Test'); end; end; end; Вопрос: Как сменить дисковод, откуда MediaPlayer проигрывает аудио CD? Ответ: См. пример. Пример: MediaPlayer1.FileName := 'E:'; Вопрос: Как убрать кнопку с названием моей программы из Панели Задач(Taskbar)? Ответ: Отредактируйте файл-проекта (View -> Project Source) Добавьте модуль Windows в раздел uses. Application.ShowMainForm := False; в строку после "Application.Initialize;". Добавьте ShowWindow(Application.Handle, SW_HIDE); в строку перед "Application.Run;"
Ваш файл проекта должен выглядеть приблизительно так: program Project1; uses Windows, Forms, Unit1 in 'Unit1.pas' {Form1}, Unit2 in 'Unit2.pas' {Form2}; {$R *.RES} begin Application.Initialize; Application.ShowMainForm := False; Application.CreateForm(TForm1, Form1); Application.CreateForm(TForm2, Form2); ShowWindow(Application.Handle, SW_HIDE); Application.Run; end. В разделе "initialization" (в самом низу) каждого unit'а добавьте begin ShowWindow(Application.Handle, SW_HIDE); end. Вопрос: Как преобразовать цвета в строку - название цвета VCL? Ответ: Модуль graphics.pas содержит функцию ColorToString() которое преобразует допустимое значение TColor в его строковое представление используя либо константу-название цвета (по возможности) либо шестнадцатиричную строку. Обратная функция - StringToColor()
Пример: procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Lines.Add(ColorToString(clRed)); Memo1.Lines.Add(IntToStr(StringToColor('clRed'))); end; Вопрос: При показе максимизированное формы она перекрывает task bar и не выравнивается по верху экрана. В чем тут дело? Ответ: Это может произойти когда свойство position формы установленно в poScreenCenter. Установите position = poDefault. Вопрос: Как заставить TEdit не 'пикать' при нажатии недопустимых клавиш? Ответ: Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш. Пример: procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then Key := #0; end; Вопрос: Как получить число и список всех компонентов, расположенных на TNoteBook? Ответ: В примере список выводится на Listbox. Пример: procedure TForm1.Button1Click(Sender: TObject); var n: integer; p: integer; begin ListBox1.Clear; with Notebook1 do begin for n := 0 to ControlCount - 1 do begin with TPage(Controls[n]) do begin ListBox1.Items.Add('Notebook Page: ' + TPage(Notebook1.Controls[n]).Caption); for p := 0 to ControlCount - 1 do ListBox1.Items.Add(Controls[p].Name); ListBox1.Items.Add(EmptyStr); end; end; end; end; Вопрос: Я хочу вставить escape code в строку при использовании функции Format(). Например, я хочу создать строку, содержащую символ табуляции. В "C" я бы написал что-то вроде sprintf(buffer, "%s\t%s", str);. А как это будет на Pascal'e?
Ответ: Функция Format Pascal'я не использует escape codes. Вместо этого нужно вставить в строку действительное значение символа в кодировке ASCII.
Пример: Buffer := Format('%s'#9'%s', [Str1, Str2]); ShowMessage(Format('%s'#9'%s', ['Column1', 'Column2'])); Вопрос: Как показать первый кадр AVI-файла? Ответ: См. пример. Пример: procedure TForm1.Button1Click(Sender: TObject); begin Application.ProcessMessages; MediaPlayer1.Open; Application.ProcessMessages; MediaPlayer1.Step; Application.ProcessMessages; MediaPlayer1.Previous; end; Вопрос: Когда пользователь щелкает по listview, он переходит в режим редактирования. Как перевисти его в редим редактирования по нажатию клавиши (например F2)? Ответ: Перехватите F2 на событии keydown. Пример: procedure TForm1.ListView1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Ord(Key) = VK_F2 then ListView1.Selected.EditCaption; end; Вопрос: Когда я добавляю обьект в список TStrings как мне его потом уничтожить? Ответ: Просто вызовите метод free этого обьекта. Пример: procedure TForm1.FormCreate(Sender: TObject); var Icon: TIcon; begin Icon := TIcon.Create; Icon.LoadFromFile('C:\Program Files\BorlandImages\CONSTRUC.ICO'); ListBox1.Items.AddObject('Item 0', Icon); end; procedure TForm1.FormDestroy(Sender: TObject); begin ListBox1.Items.Objects[0].Free; end; Вопрос: Вместо печати графики я хочу использовать резидентный шрифт принтера. Как? Ответ: Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.
Пример: uses Printers; procedure TForm1.Button1Click(Sender: TObject); var tm : TTextMetric; i : integer; begin if PrintDialog1.Execute then begin Printer.BeginDoc; Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT); GetTextMetrics(Printer.Canvas.Handle, tm); for i := 1 to 10 do begin Printer.Canvas.TextOut(100,i * tm.tmHeight + tm.tmExternalLeading,'Test'); end; Printer.EndDoc; end; end; Вопрос: Мне нужно программно установить некоторые файлы с установочного диска Windows. На многих компьютерах CAB-файлы установки Windows находятся в каком-то каталоге на жестком диске, на других - Windows был установлен с CD. Как узнать откуда была установленна Windows?
Ответ: Эту информацию можно получить из реестра. Пример: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false); ShowMessage(reg.ReadString('SourcePath')); reg.CloseKey; reg.free; end; Вопрос: Как получить строку сообщения об ошибке Windows код которой получен функцией GetLastError? Ответ: Функция RTL SysErrorMessage(GetLastError). Пример: procedure TForm1.Button1Click(Sender: TObject); begin {Cause a Windows system error message to be logged} ShowMessage(IntToStr(lStrLen(nil))); ShowMessage(SysErrorMessage(GetLastError)); end; Вопрос: Как заставить Delphi выполнять еще более строгую проверка типов? Напрмер - я создаю пользовательский тип, унаследованный от double и могу передавать его любым функциям, принимающим параметр типа double. Как заставить компилятор проводить более строгую проверку типов и выдавать предупреждение в таких случаях?
Ответ: См. ответ. Пример: type TStrongType = type Double; type TWeakType = Double; procedure AddWeakType(var d : TWeakType); begin d := d + 1; end; procedure AddStrongType(var d : TStrongType); begin d := d + 1; end; procedure AddDoubleType(var d : Double); begin d := d + 1; end; procedure TForm1.Button1Click(Sender: TObject); var d : Double; s : TStrongType; w : TWeakType; begin AddDoubleType(d); {compiles fine} AddDoubleType(w); {compiles fine} AddDoubleType(s); { Вопрос: Где в Delphi обьявленны VK_Key для A-Z и 0-9? Ответ: Они не обьявлены в Delphi поскольку они просто могуть быть заменены буквами. VK_0 до VK_9 то же что и ASCII '0' до '9' ($30 - $39), VK_A до VK_Z то же что и ASCII 'A' до 'Z' ($41 - $5A). Вопрос: Как изменить оконную процедуру для TForm? Ответ: Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.
Пример: type TForm1 = class(TForm) Button1: TButton; procedure WndProc (var Message: TMessage); override; procedure Button1Click(Sender: TObject); private {Private declarations} public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WndProc (var Message: TMessage); begin if Message.Msg = WM_CANCELMODE then begin Form1.Caption := 'A dialog or message box has popped up'; end else inherited // Вопрос: Как узнать размеры TComboBox с показанным выпадающим списком до показа списка? Ответ: На событии FormShow пошлите сообщение CB_SHOWDROPDOWN в ComboBox дважды - один раз чтобы заставить список выпасть, второй - чтобы убрать его. Затем пошлите сообщение CB_GETDROPPEDCONTROLRECT, передав в качестве параметра адрес TRect. TRect будет содержать экранные кординаты прямоугольника описывающего ComboBox вместе с выпавшим списком. Затем Вы можете вызвать ScreenToClient чтобы преобразовать экранные кординаты в координаты клиентской области окна.
Пример: var R : TRect; procedure TForm1.FormShow(Sender: TObject); var T : TPoint; begin SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 1, 0); SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, 0, 0); SendMessage(ComboBox1.Handle, CB_GETDROPPEDCONTROLRECT, 0, LongInt(@r)); t := ScreenToClient(Point(r.Left, r.Top)); r.Left := t.x; r.Top := t.y; t := ScreenToClient(Point(r.Right, r.Bottom)); r.Right := t.x; r.Bottom := t.y; end; procedure TForm1.Button1Click(Sender: TObject); begin Form1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom ); end; Вопрос: Я хочу создать в своей программе меню "а ля Дельфи 4". Как это сделать? Ответ: 1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client. 2. Разместите TToolBar (закладка Win32) внутри TControlBar. 3. Установите в True свойства Flat и ShowCaptions этого TToolBar. 4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar правой кнопкой и выбрав NewButton) 5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать при перемещении курсора между главными пунктами меню (если меню уже показано). 6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной формы. (посмотрите свойство Menu формы). 7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer) 8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu. Вопрос: Как добится того чтобы TMemo и TEdit имели работали не только в режиме вставки символов, но и в режиме замены? Ответ: Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".
Пример: type TForm1 = class(TForm) Memo1: TMemo; procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Memo1KeyPress(Sender: TObject; var Key: Char); private {Private declarations} InsertOn : bool; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key = VK_INSERT) and (Shift = []) then InsertOn := not InsertOn; end; procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); begin if ((Memo1.SelLength = 0) and (not InsertOn)) then Memo1.SelLength := 1; end; Вопрос: Как отправить сообщение сразу всем элементам управления формы? Ответ: Можно использовать Screen.Forms[i].BroadCast(msg); где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается.
Вопрос: При попытке присвоить значение свойству "selected" ListBox'а вырабатывается exception "Index is out of bounds". В чем тут дело и как присвоить значение свойству selected? Ответ: Свойство "selected" компонента ТListBox может быть использованно только если свойство MultiSelect установленно в True. Если Вы работаете с ListBox'ом у которого MultiSelect=false то используйте свойство ItemIndex. Пример: procedure TForm1.Button1Click(Sender: TObject); begin ListBox1.Items.Add('1'); ListBox1.Items.Add('2'); {This will fail on a single selection ListBox} // ListBox1.Selected[1] := true; ListBox1.ItemIndex := 1; {This is ok} end; Вопрос: Как ограничить длинну текста, вводимого в TEdit, так чтобы ширина текста не превышала ширину TEdit'а? Ответ: В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.
Пример: procedure TForm1.FormCreate(Sender: TObject); var cRect : TRect; bm : TBitmap; s : string; begin Windows.GetClientRect(Edit1.Handle, cRect); bm := TBitmap.Create; bm.Width := cRect.Right; bm.Height := cRect.Bottom; bm.Canvas.Font := Edit1.Font; s := 'W'; while bm.Canvas.TextWidth(s) < CRect.Right do s := s + 'W'; if length(s) > 1 then begin Delete(s, 1, 1); Edit1.MaxLength := Length(s); end; end; {Другой вариант} procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); var cRect : TRect; bm : TBitmap; begin if ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and (Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then begin Windows.GetClientRect(Edit1.Handle, cRect); bm := TBitmap.Create; bm.Width := cRect.Right; bm.Height := cRect.Bottom; bm.Canvas.Font := Edit1.Font; if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then begin Key := #0; MessageBeep(-1); end; bm.Free; end; end; Вопрос: Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных? Ответ: Нужно сохранять атрибуты шрифта (имя, размер и т.п.) а не сам обьект TFont. После считывания этой информации следует проверить существует ли такой шрифт, прежде чем его использовать. Чтобы не показаться голословным дополню ответ Borland'а своим примером сохранения/чтения шрифта в/из реестра
Uses ... Registry; procedure SaveFontToRegistry(Font : TFont; SubKey : String); Var R : TRegistry; FontStyleInt : byte; FS : TFontStyles; begin R:=TRegistry.Create; try FS:=Font.Style; Move(FS,FontStyleInt,1); R.OpenKey(SubKey,True); R.WriteString('Font Name',Font.Name); R.WriteInteger('Color',Font.Color); R.WriteInteger('CharSet',Font.Charset); R.WriteInteger('Size',Font.Size); R.WriteInteger('Style',FontStyleInt); finally R.Free; end; end; function ReadFontFromRegistry(Font : TFont; SubKey : String) : boolean; Var R : TRegistry; FontStyleInt : byte; FS : TFontStyles; begin R:=TRegistry.Create; try result:=R.OpenKey(SubKey,false); if not result then exit; Font.Name:=R.ReadString('Font Name'); Font.Color:=R.ReadInteger('Color'); Font.Charset:=R.ReadInteger('CharSet'); Font.Size:=R.ReadInteger('Size'); FontStyleInt:=R.ReadInteger('Style'); Move(FontStyleInt,FS,1); Font.Style:=FS; finally R.Free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin If FontDialog1.Execute then begin SaveFontToRegistry(FontDialog1.Font,'Delphi Kingdom\Fonts'); end; end; procedure TForm1.Button2Click(Sender: TObject); var NFont : TFont; begin NFont:=TFont.Create; if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then begin //здесь добавить проверку - существует ли шрифт Label1.Font.Assign(NFont); NFont.Free; end; end; Вопрос: Как перемещать компонент мышкой во время работы программы "runtime"? Ответ: Перехватить событие OnMouseDown, запомнить x и y координты курсора мыши. Отслеживать движение мыши по событию OnMouseMove и перемещать компонент вслед за курсором мыши до тех пор пока не произойдет событие OnMouseUp. В примере показано перемещение компонента TButton. Перемещение начинается, когда пользователь "берет" TButton мышью, удерживая нажатой клавишу "Сontrol".
Пример: type TForm1 = class(TForm) Button1: TButton; procedure Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private {Private declarations} public {Public declarations} MouseDownSpot : TPoint; Capturing : bool; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if ssCtrl in Shift then begin SetCapture(Button1.Handle); Capturing := true; MouseDownSpot.X := x; MouseDownSpot.Y := Y; end; end; procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if Capturing then begin Button1.Left := Button1.Left - (MouseDownSpot.x - x); Button1.Top := Button1.Top - (MouseDownSpot.y - y); end; end; procedure TForm1.Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Capturing then begin ReleaseCapture; Capturing := false; Button1.Left := Button1.Left - (MouseDownSpot.x - x); Button1.Top := Button1.Top - (MouseDownSpot.y - y); end; end; Вопрос: При попытке создать обьект класса TPrinter (TPrinter.Create) я получаю exception. Почему? Ответ: В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости, так как обьект класса TPrinter (называемый Printer) автоматически создается при использовании модуля Printers. Пример: uses Printers; procedure TForm1.Button1Click(Sender: TObject); begin Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Hello World!'); Printer.EndDoc; end; Вопрос: Как перехватить события в неклиентской области формы, в заголовке окна, например? Ответ: Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей неклиенстской области окна (рамка и заголовок). Пример: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) private {Private declarations} procedure WMNCMOUSEMOVE(var Message: TMessage); message WM_NCMOUSEMOVE; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage); var s : string; begin case Message.wParam of HTERROR: s:= 'HTERROR'; HTTRANSPARENT: s:= 'HTTRANSPARENT'; HTNOWHERE: s:= 'HTNOWHERE'; HTCLIENT: s:= 'HTCLIENT'; HTCAPTION: s:= 'HTCAPTION'; HTSYSMENU: s:= 'HTSYSMENU'; HTSIZE: s:= 'HTSIZE'; HTMENU: s:= 'HTMENU'; HTHSCROLL: s:= 'HTHSCROLL'; HTVSCROLL: s:= 'HTVSCROLL'; HTMINBUTTON: s:= 'HTMINBUTTON'; HTMAXBUTTON: s:= 'HTMAXBUTTON'; HTLEFT: s:= 'HTLEFT'; HTRIGHT: s:= 'HTRIGHT'; HTTOP: s := 'HTTOP'; HTTOPLEFT: s:= 'HTTOPLEFT'; HTTOPRIGHT: s:= 'HTTOPRIGHT'; HTBOTTOM: s:= 'HTBOTTOM'; HTBOTTOMLEFT: s:= 'HTBOTTOMLEFT'; HTBOTTOMRIGHT: s:= 'HTBOTTOMRIGHT'; HTBORDER: s:= 'HTBORDER'; HTOBJECT: s:= 'HTOBJECT'; HTCLOSE: s:= 'HTCLOSE'; HTHELP: s:= 'HTHELP'; else s:= ''; end; Form1.Caption := s; Message.Result := 0; end; end. Вопрос: При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку увеличенной ее размер не изменяется. Что делать? Ответ: Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод TCanvas.StretchDraw. Пример: procedure TForm1.Button1Click(Sender: TObject); var TheBitmap : TBitmap; begin TheBitmap := TBitmap.Create; TheBitmap.Width := Application.Icon.Width; TheBitmap.Height := Application.Icon.Height; TheBitmap.Canvas.Draw(0, 0, Application.Icon); Form1.Canvas.StretchDraw(Rect(0,0,TheBitmap.Width * 3,TheBitmap.Height * 3), TheBitmap); TheBitmap.Free; end; Вопрос: Можно ли сделать так чтобы TStringGrid автоматически изменял ширину колонок, чтобы вместить самую длинную строчку в колонке? Ответ: См. пример. Пример: procedure AutoSizeGridColumn(Grid : TStringGrid; column : integer); var i : integer; temp : integer; max : integer; begin max := 0; for i := 0 to (Grid.RowCount - 1) do begin temp := Grid.Canvas.TextWidth(grid.cells[column, i]); if temp > max then max := temp; end; Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3; end; procedure TForm1.Button1Click(Sender: TObject); begin AutoSizeGridColumn(StringGrid1, 1); end; Вопрос: TTimer работает не достаточно точно. Как получить более высокую точность? Ответ: Таймер Windows не был создан с целью получения сверхточного хронометра. :-( Другими словами, когда Вы устанавливаете таймер на срабатывания каждые 1000 миллисекунд, он может срабатывать через интервал несколько больший чем 1000 миллисекунд. Значения меньше 55 миллисекунд никогда не будут срабатывать вовремя в Windows, поскольку это минимальная точность таймера. Можно проверять системное время и сравнивать его со временем предыдущего события таймера чтобы повысить точность.
Вопрос: Как поместить JPEG-картинку в exe-файл и потом загрузить ее? Ответ: 1) Создайте текстовый файл с расширением ".rc". Имя этого файла должно отличаться от имени файла-пректа или любого модуля проекта. Файл должен содержать строку вроде: MYJPEG JPEG C:\DownLoad\MY.JPG где: "MYJPEG" имя ресурса "JPEG" пользовательский тип ресурса "C:\DownLoad\MY.JPG" руть к JPEG файлу. Пусть например rc-файл называется "foo.rc" Запустите BRCC32.exe (Borland Resource CommandLine Compiler) - программа находится в каталоге Bin Delphi/C++ Builder'а - передав ей в качестве параметра полный путь к rc-файлу. В нашем примере: C:\DelphiPath\BIN\BRCC32.EXE C:\ProjectPath\FOO.RC Вы получите откомпилированный ресурс - файл с расширением ".res". (в нашем случает foo.res). Далее добавте ресурс к своему приложению. {Грузим ресурс} {$R FOO.RES} uses Jpeg; procedure LoadJPEGFromRes(TheJPEG : string; ThePicture : TPicture); var ResHandle : THandle; MemHandle : THandle; MemStream : TMemoryStream; ResPtr : PByte; ResSize : Longint; JPEGImage : TJPEGImage; begin ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG'); MemHandle := LoadResource(hInstance, ResHandle); ResPtr := LockResource(MemHandle); MemStream := TMemoryStream.Create; JPEGImage := TJPEGImage.Create; ResSize := SizeOfResource(hInstance, ResHandle); MemStream.SetSize(ResSize); MemStream.Write(ResPtr^, ResSize); FreeResource(MemHandle); MemStream.Seek(0, 0); JPEGImage.LoadFromStream(MemStream); ThePicture.Assign(JPEGImage); JPEGImage.Free; MemStream.Free; end; procedure TForm1.Button1Click(Sender: TObject); begin LoadJPEGFromRes('MYJPEG', Image1.Picture); end; Вопрос: Как перехватить сообщения прокрутки в TScrollBox? Ответ: Следующий пример перехватывает сообщения о прокрутке компонента TScrollBox и синхронизирует обе линейки прокрутки. Сообщения прокрутки перехватываются с помощью переопределения окнной процедуры (WinProc) ScrollBox'а. Пример: type {$IFDEF WIN32} WParameter = LongInt; {$ELSE} WParameter = Word; {$ENDIF} LParameter = LongInt; {Declare a variable to hold the window procedure we are replacing} var OldWindowProc : Pointer; function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} var TheRangeMin : integer; TheRangeMax : integer; TheRange : integer; begin if TheMessage = WM_VSCROLL then begin {Get the min and max range of the horizontal scroll box} GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax); {Get the vertical scroll box position} TheRange := GetScrollPos(WindowHandle, SB_VERT); {Make sure we wont exceed the range} if TheRange < TheRangeMin then TheRange := TheRangeMin else if TheRange > TheRangeMax then TheRange := TheRangeMax; {Set the horizontal scroll bar} SetScrollPos(WindowHandle, SB_HORZ, TheRange, true); end; if TheMessage = WM_HSCROLL then begin {Get the min and max range of the horizontal scroll box} GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax); {Get the horizontal scroll box position} TheRange := GetScrollPos(WindowHandle, SB_HORZ); {Make sure we wont exceed the range} if TheRange < TheRangeMin then TheRange := TheRangeMin else if TheRange > TheRangeMax then TheRange := TheRangeMax; {Set the vertical scroll bar} SetScrollPos(WindowHandle, SB_VERT, TheRange, true); end; {Call the old Window procedure to allow processing of the message.} NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage, ParamW, ParamL); end; procedure TForm1.FormCreate(Sender: TObject); begin {Set the new window procedure for the control and remember the old window procedure.} OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc))); end; procedure TForm1.FormDestroy(Sender: TObject); begin {Set the window procedure back to the old window procedure.} SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc)); end; Вопрос: Как сделать прямоугольник для выделения части картинки для редактирования? Ответ: Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.
Пример: type TForm1 = class(TForm) procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private {Private declarations} Capturing : bool; Captured : bool; StartPlace : TPoint; EndPlace : TPoint; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} function MakeRect(Pt1 : TPoint; Pt2 : TPoint) : TRect; begin if pt1.x < pt2.x then begin Result.Left := pt1.x; Result.Right := pt2.x; end else begin Result.Left := pt2.x; Result.Right := pt1.x; end; if pt1.y < pt2.y then begin Result.Top := pt1.y; Result.Bottom := pt2.y; end else begin Result.Top := pt2.y; Result.Bottom := pt1.y; end; end; procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Captured then DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); StartPlace.x := X; StartPlace.y := Y; EndPlace.x := X; EndPlace.y := Y; DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); Capturing := true; Captured := true; end; procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if Capturing then begin DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); EndPlace.x := X; EndPlace.y := Y; DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace)); end; end; procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Capturing := false; end; Вопрос: Можно ли использовать иконку как картинку на кнопке TSpeedButton? Ответ: Можно. См. пример. Пример: uses ShellApi; procedure TForm1.FormShow(Sender: TObject); var Icon: TIcon; begin Icon := TIcon.Create; Icon.Handle := ExtractIcon(0,'C:\WINDOWS\NOTEPAD.EXE',1); SpeedButton1.Glyph.Width := Icon.Width; SpeedButton1.Glyph.Height := Icon.Height; SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon); Icon.Free; end; Вопрос: Как поместить прозрачную фоновую каринку на компонент CoolBar? Ответ: procedure TForm1.Button1Click(Sender: TObject); var Bm1 : TBitmap; Bm2 : TBitmap; begin Bm1 := TBitmap.Create; Bm2 := TBitmap.Create; Bm1.LoadFromFile('c:\download\test.bmp'); Bm2.Width := Bm1.Width; Bm2.Height := Bm1.Height; bm2.Canvas.Brush.Color := CoolBar1.Color; bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), ClWhite); bm1.Free; CoolBar1.Bitmap.Assign(bm2); bm2.Free; end; Вопрос: Ползунок компонента TScrollBar все время мигает. Как это отключить? Ответ: Установите свойтсво ScrollBar.TabStop в False. Вопрос: Как программно перевести DBgrid в реим редактирования и установить курсор в окошке редактирования в требуемую позицию? Ответ: Переведите таблицу в режим редактирования, затем получите дескриптор (handle) окна редактирования и перешлите ей сообщение EM_SETSEL. В качестве параметров вы должны переслать начальную позицию курсора, и конечную позицию, определяющую конец выделения текста цветом. В приведенном примере курсор помещается во вторую позицию, текст внутри ячейки не выделяется.
Пример: procedure TForm1.Button1Click(Sender: TObject); var h : THandle; begin Application.ProcessMessages; DbGrid1.SetFocus; DbGrid1.EditorMode := true; Application.ProcessMessages; h:= Windows.GetFocus; SendMessage(h, EM_SETSEL, 2, 2); end; Вопрос: Как поместить курсор в определенную позицию edit'а и подобных ему элементов управления? Ответ: Можно использовать методы Delphi SelStart() и SelectLength(). Пример: procedure TForm1.Button1Click(Sender: TObject); begin Edit1.SetFocus; {переводим курсор во вторую позицию} Edit1.SelStart := 2; {не выделяем никакого текста} Edit1.SelLength := 0; end; Вопрос: Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение размера формы? Ответ: В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о минимизации или максимизации формы - пищит динамик. Пример: type TForm1 = class(TForm) private {Private declarations} procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMSysCommand; begin if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then MessageBeep(0) else inherited; end; Вопрос: Можно ли сделать так - одна форма показывает другую и остается позади нее, но фокус ввода не переходит к новой форме, а остается у старой? Ответ: В примере показывается не автосоздаваемая (non auto-created) форма, но фокус ввода ей не передается. Пример: uses Unit2; procedure TForm1.Button1Click(Sender: TObject); begin Form2 := TForm2.Create(Application); Form2.Visible := FALSE; ShowWindow(Form2.Handle, SW_SHOWNA); end; Вопрос: На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены? Ответ: В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play флоппи дисковода. Пример: procedure TForm1.FormCreate(Sender: TObject); var i : integer; OldErrorMode : Word; OldDirectory : string; begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); i := 0; while i 0 then DriveComboBox1.Items.Delete(i) else inc(i); end; ChDir(OldDirectory); SetErrorMode(OldErrorMode); end; Вопрос: Как сообщить всем формам моего приложения (в том числе и не видимым в данный момент) об изминении каких-то глобальных значений? Ответ: Один из способов - создать пользовательское сообщение и использовать метод preform чтобы разослать его всем формам из массива Screen.Forms. Пример: {Code for Unit1} const UM_MyGlobalMessage = WM_USER + 1; type TForm1 = class(TForm) Label1: TLabel; Button1: TButton; procedure FormShow(Sender: TObject); procedure Button1Click(Sender: TObject); private {Private declarations} procedure UMMyGlobalMessage(var AMessage: TMessage); message UM_MyGlobalMessage; public {Public declarations} end; var Form1: TForm1; implementation {$R *.DFM} uses Unit2; procedure TForm1.FormShow(Sender: TObject); begin Form2.Show; end; procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage); begin Label1.Left := AMessage.WParam; Label1.Top := AMessage.LParam; Form1.Caption := 'Got It!'; end; procedure TForm1.Button1Click(Sender: TObject); var f: integer; begin for f := 0 to Screen.FormCount - 1 do Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42); end; {Code for Unit2} const UM_MyGlobalMessage = WM_USER + 1; type TForm2 = class(TForm) Label1: TLabel; private {Private declarations} procedure UMMyGlobalMessage(var AMessage: TMessage); message UM_MyGlobalMessage; public {Public declarations} end; var Form2: TForm2; implementation {$R *.DFM} procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage); begin Label1.Left := AMessage.WParam; Label1.Top := AMessage.LParam; Form2.Caption := 'Got It!'; end; Вопрос: Как обновить список дисков компонента TDriveComboBox, учитывая, что могуд быть подключены/отключены сетевые диски и произведена "горячая замена" plug&play дисков? Ответ: Следующий пример вызывает защищенный (protected) метод класса TDriveComboBox BuildList() для регеирации списка дисков. (использовая так наз. "class cracer") Пример: type TNewDriveComboBox = class(TDriveComboBox) //это наш "class cracer" end; procedure TForm1.Button1Click(Sender: TObject); var Drive : char; begin Drive := DriveComboBox1.Drive; TNewDriveComboBox(DriveComboBox1).BuildList; //вызываем защищенный метод родительского класса DriveComboBox1.Drive := Drive; end; Вопрос: Как программно заставить выпасть меню? Ответ: В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.
Пример: procedure TForm1.Button1Click(Sender: TObject); begin //Allow button to finish painting in response to the click Application.ProcessMessages; {Alt Key Down} keybd_Event(VK_MENU, 0, 0, 0); {F Key Down - Drops the menu down} keybd_Event(ord('F'), 0, 0, 0); {F Key Up} keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0); {Alt Key Up} keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0); {F Key Down} keybd_Event(ord('S'), 0, 0, 0); {F Key Up} keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0); end; Вопрос: Как сделать клавишу-акселератор (keyboard shortcut) компонету у которого нет заголовка? Ответ: Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "быстрой" клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонет TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, перевидите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo.
Пример: procedure TForm1.FormCreate(Sender: TObject); begin Label1.Visible := false; Label1.Caption := '&M'; Label1.FocusControl := Memo1; end; Вопрос: Можно ли как-то уменьшить мерцание при перерисовке компонента? Ответ: Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента - то фон компонента перерисовываться не будет. Пример: constructor TMyControl.Create; begin inherited; ControlStyle := ControlStyle + [csOpaque]; end; Вопрос: Как запретить изменение размера моего компонента в design-time? Ответ: Поместите в конструктор компонента код, устанавливающий размеры по умолчанию. Переопределите метод SetBounds и проверяйте в нем "componentstate". Если компонет находится режиме "design-time" (csDesigning in ComponentState) просто передавайте значения ширины и высоты (width и heights) компонента по умолчанию (в нашем примере 50) методу класса-предка. Пример: procedure TVu.SetBounds(ALeft : integer; ATop : integer; AWidth : integer; AHeight : integer); begin if csdesigning in componentstate then begin AWidth := 50; AHeight := 50; inherited; //вызываем унаследованный от предка метод end; end; Вопрос: Можно ли уменьшить потребляемые компонентами TNotebook и TTabbedNotebook ресурсы? Ответ: Да. Можно уничтожать обьекты, расположенные не на текущей странице TNotebook или TTabbedNotebook. В примере вызывается защищенный (Protected) метод путем создания так называемый "class cracer'ов". type TMyTabbedNotebook = class(TTabbedNotebook); //это наш "class cracer" type TMyNotebook = class(TNotebook); procedure TForm1.TabbedNotebook1Change(Sender: TObject; NewTab: Integer; var AllowChange: Boolean); begin with TabbedNotebook1 do //вызываем защищенный метод родительского класса TMyTabbedNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle; end; procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer; var AllowChange: Boolean); begin with Notebook1 do //вызываем защищенный метод родительского класса TMyNotebook(TWinControl(Pages.Objects[PageIndex])).DestroyHandle; NoteBook1.PageIndex := NewTab; AllowChange := true end; Вопрос: Функция keybd_event() принимает значения до 244 - как мне отправить нажатие клавиши с кодом #255 в элемент управления Windows? Ответ: Это может понадобится для иностранных языков или для специальных символов. (например, в русских шрифтах символ с кодом #255 - я прописное). Приведенный в примере метод, не стоит использовать в случае если символ может быть передан обычным способом (функцией keybd_event()). procedure TForm1.Button1Click(Sender: TObject); var KeyData : packed record RepeatCount : word; ScanCode : byte; Bits : byte; end; begin {Let the button repaint} Application.ProcessMessages; {Set the focus to the window} Edit1.SetFocus; {Send a right so the char is added to the end of the line} // SimulateKeyStroke(VK_RIGHT, 0); keybd_event(VK_RIGHT, 0,0,0); {Let the app get the message} Application.ProcessMessages; FillChar(KeyData, sizeof(KeyData), #0); KeyData.ScanCode := 255; KeyData.RepeatCount := 1; SendMessage(Edit1.Handle, WM_KEYDOWN, 255,LongInt(KeyData)); KeyData.Bits := KeyData.Bits or (1 shl 30); KeyData.Bits := KeyData.Bits or (1 shl 31); SendMessage(Edit1.Handle, WM_KEYUP, 255, LongInt(KeyData)); KeyData.Bits := KeyData.Bits and not (1 shl 30); KeyData.Bits := KeyData.Bits and not (1 shl 31); SendMessage(Edit1.Handle, WM_CHAR, 255, LongInt(KeyData)); Application.ProcessMessages; end; Вопрос: Некоторые компоненты не меняют курсор мыши до тех пор пока пользователь не сдвинет мышь. Как эмулировать движение мыши? Ответ: В примере мышка слегка "подталкивается" без участия пользователя. procedure TForm1.Button1Click(Sender: TObject); var pt : TPoint; begin Application.ProcessMessages; Screen.Cursor := CrHourglass; GetCursorPos(pt); SetCursorPos(pt.x + 1, pt.y + 1); Application.ProcessMessages; SetCursorPos(pt.x - 1, pt.y - 1); end; Вопрос: Как зарегистрировать расширение файла за своим приложением и контекстное меню, связанное с этим типом? Ответ: Пример регистрирует расширение файла(.myext) - файлы этого типа будут открываться приложением MyApp.Exe. Также регнстрируется одно действие (action) по умолчанию для файлов этого типа и два дополнительных пункта контекстного меню, связанного с этим типом файлов. Возможно, потребуется перезайти в систему чтобы изменения вступили в силу. Пример: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var R : TRegIniFile; begin R := TRegIniFile.Create(''); with R do begin RootKey := HKEY_CLASSES_ROOT; WriteString('.myext','','MyExt'); WriteString('MyExt','','Some description of MyExt files'); WriteString('MyExt\DefaultIcon','','C:\MyApp.Exe,0'); WriteString('MyExt\Shell','','This_Is_Our_Default_Action'); WriteString('MyExt\Shell\First_Action', '','This is our first action'); WriteString('MyExt\Shell\First_Action\command','', 'C:\MyApp.Exe /LotsOfParamaters %1'); WriteString('MyExt\Shell\This_Is_Our_Default_Action','', 'This is our default action'); WriteString('MyExt\Shell\This_Is_Our_Default_Action\command', '','C:\MyApp.Exe %1'); WriteString('MyExt\Shell\Second_Action', '','This is our second action'); WriteString('MyExt\Shell\Second_Action\command', '','C:\MyApp.Exe /TonsOfParameters %1'); Free; end; end;
© 1999 Inprise Corp.
Last Modified Friday, 06-Aug-99 11:12:04 PST.
Translated & Adapted by
19-Sep-1999
Директива компилятора - $INCLUDE
| Раздел Сокровищница |
В своей статье я писал про проблему, возникающую в Object Pascal в связи с только явным подключением заголовочных файлов. Благодаря одному человеку, подсказавшему решение, для меня эта проблема в основом снята. Хочу поделиться решением.
Существует такая директива компилятора - {$INCLUDE filename} и её более короткий аналог {$I filename}. Раньше я недооценивал её значение, т. к. в чужих программах с помощью неё к коду программы подключались либо файлы с процедурами, либо списки ассемблерных команд. Выяснилось, что с помощью этой директивы можно подключать и ссылки на другие файлы программы. Поясню на примере.
В IDE Delphi 5 при создании нового проекта в интерфейсной секции автоматически формируется список uses такого вида:
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
Начинающие ещё не усматривают никакого подвоха в этом (как не замечал этого и я, когда только осваивал программирование), но постепенно с ростом программ список uses, помимо ссылок на стандартные файлы среды, начинает пополняться десятками собственных и грозит распухнуть до гигинтских размеров. Частично её можно решить, если весь код собрать в нескольких файлах, но это неудобно.
Выход один - можно создать отдельный файл - назовём его, например, vcl.pas. После этого модернизируем его так:
| //------------------------------------------------------------------ // Файл: vcl.pas // Описание: Список ссылок на стандартные модули VCL //------------------------------------------------------------------ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs |
Замечу, здесь нет ошибки! Именно так, без всех зарезервированных слов языка, должен выглядеть этот файл. После Dialogs точка с запятой отсутствует.
Теперь в модуле Unit1.pas удаляем все ссылки и пишем:
| uses Activex, // для наглядности {$i vcl}; |
Т. к. расширение по умолчанию - *.pas, его можно не указывать. Что же произошло? Директивой {$i} мы указали компилятору подставить список ссылок в текст модуля Unit1.pas. Получилось
| uses Activex, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; |
Данная директива не решает всех проблем, это ведь не аналог директивы #include из языка С. Например, С позволяет организовать видимость модулей на нескольких уровнях - например, если модуль B включает модуль С, то модуль А, подключив модуль В, получит в своё распоряжение также и данные из модуля С. В нашем случае это недоступно, однако часто это и не требуется. А вот сократить список uses в каждом файле проекта - это может быть полезно.
Диспетчер кучи для объектов одного размера
| й Парунов, дата публикации 23 декабря 02 |
Модуль содержит класс psnFixSzMemMgr, реализующий диспетчер кучи для объектов одного размера.
Динамическое размещение объектов (не только экземпляров классов, а вообще) в куче имеет неоспоримые преимущества: гибкость, простота... Но у такого подхода есть недостаток, проистекающий от всеядности стандартного диспетчера кучи языка (Delphi), который и выбирает, откуда "отщипнуть" кусочек памяти. Уж очень много самых разных блоков выделяется-освобождается в куче, и она превращается в швейцарский сыр. Отсюда вытекают две неприятности. Во-первых, когда выделяется блок памяти, диспетчер вынужден запомнить его размер и прочие параметры в пропадающем зря 4-байтном (чаще всего) заголовке (для освобождения). Во-вторых, уж очень медленен этот процесс - надо перестроить дерево... в общем, тактов 200 на одно выделение/освобождение на процессоре Пентиум 3 обеспечено.
Все эти недостатки проявляются особенно сильно при работе с маленькими динамическими переменными, которые часто так заманчиво применять для различных списков, деревьев, графов... И самое обидное, что вся эта возня - впустую: так как размер переменных нам-то известен, нет необходимости ни в мудрёном отслеживании блоков (можно обойтись простым списком неиспользуемых), ни тем более в запоминании размера каждого выделенного блока. Эти соображения ведут к применению массивов, с которыми нередко достигается наибольшая скорость, но есть и свои сложности: сложность (простите за каламбур) и негибкость. К тому же частое применение индексов в массиве всё же медленнее использования указателей.
Данный класс реализует упрощенный диспетчер кучи для объектов одного размера (назовём его экземпляр кучей), который можно применять вместо стандартного, получая с маленькими объектами существенно большую скорость, а часто и экономию памяти, за счёт реализации старого татаро-монгольского принципа: "меньше чем по десять тысяч мы даже в гости не ходим" ((c) Александр Борянский, Сергей Козлов).
Его применение в основном подобно стандартному:
| type psnFixSzMemMgr = class private FLastCommit, { указатель на последний выделенный массив, в начале которого - указатель на предпоследний...} FEmptyBlock : Pointer; {указатель на последний пустой блок из списка, в начале которого - указатель на предпоследний...} FBlockSize, FCommitSize, FFillCycles: Integer; public constructor Create( const BlockSize: Integer; {Размер выделяемых блоков памяти. Реально округляется в большую сторону до величины, кратной 4.} const CommitBlocks: Integer = 127 {Количество блоков в выделяемых массивах. Должно быть больше 1 (иначе зачем огород городить?), а для скорости желательно не меньше 31. Реально увеличивается до ближайшего сверху нечётного значения (алгоритм требует это для высокой скорости).} ); function FixNew: Pointer; {Выделяет блок памяти размера BlockSize и возвращает ссылку на эту память. Выполнено в виде функции во избежание обязательного преобразования типов параметра, передаваемого по ссылке.} procedure FixDsp(const Ptr: Pointer); {Освобождает блок памяти, выделенный ранее в данном экземпляре класса, указуемый параметром Ptr.} destructor Destroy; override; end; implementation constructor psnFixSzMemMgr.Create(const BlockSize, CommitBlocks: Integer); begin FBlockSize:= (BlockSize + 3) and $7FFFFFFC; FCommitSize:= (CommitBlocks and $7FFFFFFE + 1) * FBlockSize + 4; FFillCycles:= CommitBlocks shr 1 - 1; {заполняем в один присест два блока, и цикл оформим от нуля: for I:= 0 to FFillCycles, быстрее будет} end; function psnFixSzMemMgr.FixNew: Pointer; var P, P2: Pointer; I, DBlockSize: Integer; begin if not Assigned (FEmptyBlock) then begin {выделим массив} GetMem(P, FCommitSize); Pointer(P^):= FLastCommit; FLastCommit:= P; Inc(PChar(P), 4); Pointer(P^):= Nil; P2:= Pointer(Integer(P) + FBlockSize); DBlockSize:= FBlockSize shl 1; for I:= 0 to FFillCycles do begin {надо сделать список пустых блоков} Pointer(P2^):= P; Inc(PChar(P), DBlockSize); Pointer(P^):= P2; Inc(PChar(P2), DBlockSize); end; FEmptyBlock:= P; end; Result:= FEmptyBlock; FEmptyBlock:= Pointer(Result^); end; procedure psnFixSzMemMgr.FixDsp(const Ptr: Pointer); begin Pointer(Ptr^):= FEmptyBlock; FEmptyBlock:= Ptr; end; destructor psnFixSzMemMgr.Destroy; var P: Pointer; begin while Assigned(FLastCommit) do begin P:= FLastCommit; FLastCommit:= Pointer(P^); FreeMem(P, FCommitSize); end; inherited; end; |
Дополнение
й Жолоб (Донецк)
01 августа 2002г.
Я до сих пор работаю с Delphi 4, поскольку моего домашнего компьютера как раз хватает для этой версии. Иногда я встречаю интересные проекты, предназначенные для Delphi 5, в которых DFM-файлы имеют текстовый формат. Однако Delphi 4, в отличие от Delphi 5, еще не имеет встроенного распознавателя форматов. Поэтому приходится либо переходить в Delphi 5 (я могу сделать это на работе), либо создавать форму в текстовом режиме (тогда получаются накладки с событиями). Есть, правда утилита convert.exe для преобразования файлов, но она не дает возможности просмотреть содержание DFM файла в текстовом виде. Вот я и решил написать собственную программу для этой цели.
Предлагаю ее всем желающим для свободного использования. Приношу благодарность разработчикам RX Library за возможность использования кода из модуля StrUtils. В "прицепе" - полный исходный код программы.
Проверка текстового DFM-файла проводится согласно алгоритму, использованному Markus Stephan
Скачать исходные коды проекта: (4.8K)
| Раздел Сокровищница |
(начало)
Эта статья о том, что в компоненте ListView существенно нехватает одного свойства и о все той же программе для редактирования файлов с убранными ошибками и более грамотным интерфейсом.
| символа является фиксированной величиной. То есть, ширина задана создателем шрифта для каждого конкретного символа и не зависит от его положения в тексте.
Это неизбежно порождает эффект неравномерности при выводе текста на экран, которое не замечает большинство рядовых пользователей, но хорошо известный дизайнерам. Введите, например, в Word-е следующий текст: "AVALLOOOOOLTLTLTL" Обратите внимание, что видимое расстояние между буквами A и V заметно больше, чем между соседними O. С точки зрения компьютера все в порядке - грубо говоря, Windows считает межсимвольным расстоянием разницу между самой правой точкой предыдущего символа и самой левой текущего. Но с точки зрения дизайна - это помарка, которую стандартными средствами исправить невозможно или очень сложно (вручную регулировать межсимвольный интервал в Word-e). |
| Как решить |
В прикладных задачах неровности шрифта можно исправить хотя бы частично, если рассчитывать и запоминать расстояния между каждыми парами символов.
Предлагаемый невизуальный компонент позволяет это делать для символов из одного шрифта, запоминая межсимвольные расстояния при инициализации. При настройке объекта на конкретный шрифт, а точнее, канву, задается минимальное межсимвольное расстояние и строка, представляющая собой набор символов, для которых будет производиться дополнительное выравнивание. После того, как настройка произведена, печать текста производится с помощью процедуры, аналогичной TextOut.
Примечание: компонент написан под библиотеку KOL (1.55), но может быть легко портирован и под VCL, так как разницы в их работе в данном случае немного.
Пример работы компонента:
Две верхние строчки напечатаны с дополнительны выравниванием, две нижние - стандартными средствами. Очевидно, что видимые расстояния между символами стали выглядеть гораздо лучше.
| Объекты и процедуры модуля FineFont |
TFineFont- объект, в котором хранятся данные о межсимвольных расстояниях. Он же производит расчет расстояний и печать выравненного текста. Объект статический SetMinDistance- процедура установки межсимвольного расстояния. Может и должна вызываться перед инициализацией шрифта. AssignFont - настройка компонента на готовую канву. Шрифт канвы должен быть заранее проинициализирован. Внимание - шрифт канвы не должен быть растровым!
Надо заметить, что настройка компонента на новый шрифт происходит довольно медленно, несмотря на все оптимизации. Для символьного набора из 52 символов (английские заглавные + строчные буквы) инициализация идет 5 секунд на PII-233. Также очень сильно влияет и размер символов. Для ускорения работы следует как можно сильнее сжать символьный набор, исключить символы c вертикальными линиями по бокам - O, M, N, W и так далее.
Но есть и другой способ: AssignFontEx - настройка компонента с помощью сохраненных заранее параметров. Естественно, следует следить, чтобы настройки канвы в момент инициализации компонента совпадали с теми, которые вы сохранили когда-то с помощью процедуры SaveSettings. SaveSettings - сохраняет данные о символьном наборе и межсимвольных расстояниях в файл на диске. TextOut - печатает текст на заданной при вызове AssignFont канве. Аналог соответствующей функции TCanvas. Отличие в том, что эта функция не очищает фон перед печатью. В передаваемой строке могут содержаться символы, не входящие в символьный набор, заданный при вызове AssignFont. Они будут выводиться стандартным способом. CloseFont - освобождение занятой памяти. Процедура должна быть вызвана перед следующим вызовом AssignFont.
P.S.
Что касается развития компонента. Можно подумать о том, чтобы при настройке отсеивать несколько крайних точек символа, поскольку засечки на буквах в шрифтах типа Times "мешаются под ногами" и увеличивают видимое расстояние между символами.
Скачать пример: (35K) © Михаил Рудаков aka Miek, 11/2002
Доступ к реестру Win9x/ME без WinAPI
Думаю, каждый пользователь Windows хоть раз сталкивался с необходимостью чтения данных из неактивных файлов реестра. Существует, как минимум, 2 варианта решения данной задачи: воспользоваться стандартной утилитой regedit, которая может экспортировать и импортировать данные из файлов реестра. Второй вариант: использовать очень добротную и аккуратно написанную программу regview (для MSDOS), с отличным пользовательским интерфейсом ( - там же описание формата файлов реестра Win9x на русском).
К сожалению, для работы в пакетном режиме подходит лишь regedit. При этом, скорость оставляет желать лучшего...
Хочется поделиться с Вами, уважаемые, небольшим компонентом TRawRegistry для доступа к информации неактивных и активных файлов реестра формата Win9x/ME. Сразу оговорюсь: я не программист, и не собираюсь таковым быть, поэтому качество реализации оставляет желать лучшего (за неимением гербовой пишут на почтовой =)
TRawRegistry - реализует все методы и свойства класса TRegistry, необходимые для чтения ключей и значений параметров из реестра. На данный момент существуют, минимум, две основные проблемы: работа с бинарными данными и общая скорость доступа к файлам. Из-за использования динамических массивов (что легко исправимо), компилируется, начиная с D4.
В качестве примера прилагаю программу, использующую данный класс. Это аналог утилиты regedit, но без возможности записи какой бы то ни было информации в реестр.
Скачать архив (18K)
Искренне Ваш.
Илья Маляренко
Еще один комментарий к статье по поводу wsprintf
Предполагаемая история появления статьи "Использование функции wsprintf".
Будущий ю, это в данном случае не так важно, лишь бы она поддерживала переменное число параметров), пытается использовать в Delphi - а она не работает. Нет бы подумать, разобраться, почему в windows.pas функция объявлена так странно? Неужели в Borland при переводе заголовочных файлов допустили такую явную ошибку?
Но нет, сразу объявляется главный враг - это конечно Delphi и принятый в ней способ передачи параметров (кстати наиболее надежный, представьте что будет если процедура ожидает всего два параметра, а вы передадите три) и все дальнейшее обсуждение сводится к опусканию Delphi в контексте "как в C все просто, как в Delphi сложно и некрасиво" (уточняю, это мое личное впечатление от данной заметки и от некоторых статей обсуждаемого е же параметры, которые нужно подставить в исходную строку? Если подумать, то единственный разумный ответ: они уже должны быть в стеке. Теперь осталось еще совсем немного подумать и написать такую простенькую процедуру-обертку:
procedure cdecl_(Output: PChar; Format: PChar; args: array of integer); begin wsprintf(Output, Format) end; А теперь сравните данную процедуру (всего одна строчка) с теми монстрами, которые приведены в обсуждении статьи. И кто сказал что программа на Delphi не может быть красивой? Проверяем: var i: integer; mes: PChar; begin GetMem(mes, 255); i := 2; cdecl_(mes, PChar('%d+%d=%d'), [i, i, i + i]); ShowMessage(mes); FreeMem(mes) end;
Работает. Что неудивительно (достаточно посмотреть получившийся ассемблерный код во встроенном отладчике). Следовательно, единственный вывод, который можно сделать - недостаточное знакомство автора заметки с темой обсуждения. Не верите? - откройте статью "Open array parameters" во встроенной справке Delphi (5.0) и прочитайте: "When you pass an array as an open array value parameter, the compiler creates a local copy of the array within the routine's stack frame".
Еще раз о нечетком сравнении строк
По мотивам обсуждения статьи
Второй вариант поиска : (359 K)
Отличия от первого, по моим субъективным наблюдениям, в следующем: 1.Лучше находит похожие слова лежащие в одной плоскости Соха - Сноха - совпадение 88 при том что в первом алгоритме составило 66 при длине фразы = 3 2.Хуже находит похожие (даже идентичные), но перевернутые слова Тихий Дон - Дон Тихий - в первом способе совпадение 79 во втором 55 - очень существено.
Так что первый способ я рекомендовал для сравнения, например, полей двух баз данных. Второй способ, по моему убеждению, лучше использовать в поиске по словарю или в тех местах, где надо найти фразу.
Вообще-то, существуют еще, кроме этих, алгоритмы поиска. Я бы выделил SoundEx для сравнения, но у него есть свои недостатки — он языкозависим, но отлично подходит для сравнения английских фраз.
Если вас это заинтересует то могу прислать в оригинале (написан он на C), но перевести в Pascal для людей которых это заинтересует, не составит труда.
И, напоследок, предлагаю вам архив с примерами алгоритмов анализа строк. К сожалению страницы указанные в архиве, как начальные, где можно найти информацию, не работают - поэтому высылаю слепок с сайта. Скачать (185 К)
На данных страницах лежит очень много алгоритмов касающихся анализа строк, приведу список причем очень хорошо документированных и математически обоснованных.
3. ОБЗОР АЛГОРИТМОВ 3. 1 Сопоставления строк 3. 2 Расстояния между строками 3. 2.1 Обобщенные задачи 3. 3 Нечеткое сопоставление строк 3. 3.1 Специальные устройства 3. 4 Максимальная повторяющаяся подстрока 4. АЛГОРИТМЫ 4. 1 Поиск образцов 4. 1.1 Наивный подход 4. 1.2 Кнут-Моррис-Пратт 4. 1.3 Бойер-Мур 4. 1.4 Бойер-Мур-Хорспул 4. 1.5 Сандей: Быстрый поиск, Максимальный сдвиг, Оптимальное несовпадение 4. 1.6 Хьюм и Сандей. Улучшенные алгоритмы Бойера-Мура и Наименьшая цена 4. 1.7 Харрисон 4. 1.8 Карп-Рабин 4. 2 Расстояние между строками и самая длинная общая подпоследовательность 4. 2.1 Вагнер-Фишер 4. 2.2 Хиршберг 4. 2.3 Хант-Шиманский 4. 2.4 Машек-Патерсон 4. 2.5 Укконен 4. 2.6 Самая тяжелая общая подпоследовательность 4. 3 НЕЧЕТКОЕ СОПОСТАВЛЕНИЕ СТРОК 4. 3.1 k несовпадений - Ландау-Вишкин 4. 3.2 k различий - Ландау-Вишкин 4. 4 Самая длинная повторяющаяся подстрока 4. 4.1 Наивный подход 4. 4.2 Суффиксные деревья Кузан Дмитрий
Flexible Frame - механизм добавления
| й Перовский, дата публикации 02 января 2003г. |
Часто встречаются задачи, в которых все объекты могут отличаться друг от друга по структуре и алгоритмам. Описывать для каждого экземпляра отдельный тип неэффективно. Алгоритмические особенности отдельного экземпляра могут быть реализованы при помощи обработчиков событий. А как быть с полями? Для решения этой задачи предлагается механизм Flexible Frame (гибкий каркас). Что же стоит за таким парадоксальным названием. Просто у объекта, кроме стандартных полей, имеется список дополнительных именованных атрибутов различного типа.
В прилагаемых модулях список реализован на основе TStrings. Естественно, для использования в качестве атрибутов, все элементарные типы данных должны быть "упакованы" в соответствующие объекты.
Модуль uFFbase содержит описание следующих классов: TFF- класс Flexible Frame список именованных атрибутов различных типов; TFFI-базовый абстрактный класс элементов списка(Flexible Frame Item); TFFITypeForm-диалог определения названия и типа для нового атрибута. Модуль uFF предоставляет простейшие типы элементов списка: TFFIinteger - целое число; TFFReal - вещественное число; TFFIstring - строка; TFFIFileName - имя файла.
Модуль uFFform описывает FormFF - диалог для редактирования значений атрибутов простейших типов. Более сложные типы могут иметь собственные формы для редактирования, как это сделано в ObjectInspector-е.
Модуль uFFDic - пример расширения стандартного набора типов. TFFSlovar - класс атрибутов с перечислимым значением, хранит код строки в словаре и код словаря.
Описан список для регистрации словарей. TFFDicForm - диалог для редактирования значений.
Скачать (10K)
FloatSpinEdit. Компонент для ввода целых и дробных чисел
| Раздел Сокровищница |
В своих приложениях часто сталкиваюсь с необходимостью обеспечить удобный ввод дробных чисел. Для этого разработал компонент TFloatSpinEdit. Более чем уверен что подобных компонент разработано немало, но в силу лени и прочего, не искал оного в Internet, а написал своё.
Компонент FloatSpinEdit предназначен для ввода чисел целых и дробных чисел.
Вводить число можно как непосредственно с клавиатуры в поле ввода, так и увеличивая/уменьшая его значение при помощи компонента типа TUpDown или клавиш Up/Down. Кроме этого осуществляется контроль допустимого диапазона вводимого числа и корректности ввода. Существует так же возможность отображения суффикса (например "А/м"), после числа.
Компонент представляет собой контейнер (TWinControl), содержащий два компонента FEdit(TFloatEdit - потомок TEdit) и FUpDown(TUpDown)."
В компоненте введены следующие новые свойства, доступные как на стадии разработки, так и на стадии выполнения: UpDownPosition - определяет положение компонента FUpDown относительно, компонента FEdit (слева/справа), значение по умолчанию справа; Precision(0..15) - определяет отображаемое количество значащих цифр, введённого числа Значение по умолчанию равно 2; Sufix(string) - строка длинною не более 20 символов, определяющая суффикс (например "см") выводимый после введённого числа через пробел. По умолчанию - пустая строка; Min(Extended) - определяет минимально допустимое значение вводимого числа. По умолчанию равно 100; Max(Extended) - определяет максимально допустимое значение вводимого числа. По умолчанию равно -100; Step(Extended) - определяет шаг изменения значения вводимого числа, при изменении его значения посредством клавиш Up/Down или компонента UpDown. По умолчанию равно 0.25; NumberValue(Extended) - определяет значение введённого числа, если введеноn некорректное число, свойство принимает значение DefNumberValue; DefNumberValue(Extended) - определяет значение числа, при вводе некорректного значения. По умолчанию равно 0; ArrowKeys(Boolean) - определяет можно ли использовать клавиши Up/Down для изменения значения вводимого числа. По умолчанию True; CheckOnExit(Boolean) - определяет, будет ли контролироваться значение введённого числа, при потере компонентом фокуса. Контроль допустимого диапазона введённого значения осуществляется, следующим образом. Если введено некорректное значение (например "0..2."), то значение числа будет равным свойству DefNumberValue, если значение больше Max, то оно устанавливается равным Max, если значене менее Min, то то оно устанавливается равным Min. Контролируемое значение числа можно получить, прочитав свойство NumberValue или обратившись к методу DefineValue.
В определенных случаях будет так же проконтролировано символьное представление числа в свойстве Text, после чего свойство Text будет отформатировано в соответствии со свойствами Precision и Sufix: изменение значения вводимого числа клавишами Up/Down или посредством компонента FUpDown; при потере компонентом фокуса (событие OnExit), если задан флаг CheckOnExit; Более подробное описание в прилагаемом файле FloatSpinEdit.txt.
Скачать (35 К)
Функции для работы с модулем
Все операции с формулами обрабатывает объект класса TDataEditor. У этого класса есть ряд методов для регистрации новых функций, типов, превода формул в сценарии и выполнения этих сценариев. Объект класса TDataEditor может хранить в себе одну формулу и один сценарий. Если Вы не собираетесь создавать новые функции, то можно просмотреть только описание функций преобразования строки в сценарий, думаю этого будет вполне достаточно, в противном случае я советую особое внимание уделить описанию методов регистрации новых функций и событию OnIntFunction. function RegisterIntFunction(const FunctionName: string; RequireValue1, RequireValue2: Boolean): Integer; Регистрирует математическую функцию с именем FunctionName. Параметры RequireValue1 и RequireValue2 означают, требуются ли этой функции параметры стоящие перед ней или после нее соответственно. Возвращает идентификатор зарегистрированной функции. Если Вы зарегистрировали новую функцию, то на Вас ложится ответственность за проведение расчета этой функции. Расчет функции придется делать каждый раз при расчете сценария. Этот расчет будет происходить в пределах события OnIntFunction (он описывается ниже), в котором Вам будет передан индекс Вашей новой функции и параметры, если необходимость их наличия была указана в функции, которую мы сейчас обсуждаем (RequireValue1 и RequireValue2). function UnRegisterIntFunction; Удаляет ранее зарегистрированную функцию по ее имени или ее идентификатору. function RegisterBoolFunction(const FunctionName: string; RequireValue1, RequireValue2: Boolean): Integer; По смыслу тоже что и функция RegisterIntFunction. function RegisterType(const TypeName: string; TypeID: Integer): Integer; Регистрирует тип с именем TypeName и присваивает ему идентификатор TypeID. Возвращает идентификатор зарегистрированного типа. function UnRegisterType: Удаляет ранее зарегистрированный тип по имени или по его идентификатору function StringToIntScript(const S: string; out Script: TScript; OpenedBracket: Char = '('; ClosedBracket: Char = ')'); Переводит строку S в сценарий Script. В параметрах OpenedBracket и ClosedBracket содержится символы начала и конца вложенной формулы function StringToBoolScript(const S: string; out Script: TScript; OpenedBracket: Char = '('; ClosedBracket: Char = ')'); По смыслу тоже, что и функция StringToIntScript. function ExecuteIntScript(P: Pointer): Double; Выполняет математический сценарий с адресом P и возвращает результат сценария function ExecuteInt: Double; Выполняет математический сценарий, содержащийся в свойстве Script. function ExecuteBoolScript(P: Pointer): Boolean: По смыслу то же, что и функция ExecuteIntScript. function ExecuteBool: Boolean; По смыслу то же, что и функция ExecuteInt. property Script: TScript; содержит сценарий property Formula: string; содержит формулу property Accuracy: TRoundToRange; Точность вычисления операций. Проще говоря, это второй параметр функции RoundTo - см. справку Delphi property OnIntFunction: TIntFunctionEvent; TIntFunctionEvent = function(FunctionID: Integer; TypeID: Integer; var Value1: Double; Value2, Value3: Double): Boolean; Эта событие должно обрабатываться в том случае, если зарегистрированы новые функции. Параметр FunctionID возвращает идентификатор функции, которая должна быть вычислена. Параметр TypeID указывает идентификатор типа (который, например, мог быть создан функцией RegisterType). Это событие будет возникать каждый раз при вычислении каждой функции в сценарии, даже если это стандартная функция. Если Вы хотите передать управление подпрограмме, которая обрабатывает стандартные функции в сценарии, то результат функции должен быть истина. Таким образом можно перекрыть стандартные функции, т.е. изменить их метематику. Результат выполнения функции нужно поместить в параметр Value1. Параметры Value2 и Value3 возвращают параметры функции, но только в том случае, если они требуются (это указывается при создании новой функции, см. RegisterIntFunction и RegisterBoolFunction). property OnBoolFunction: TBoolFunctionEvent; TBoolFunctionEvent = function(FunctionID: Integer; TypeID: Integer; var Value1: Boolean; Value2, Value3: Double): Boolean of object; По смыслу то же, что и событие OnIntFunction.
Функции для работы со строками
| Раздел Сокровищница |
Несколько функций для работы со строками. Они довольно простые, но может кому-нибудь пригодятся.
| Разбивка строки в список и слияние списка строк |
1. Разбивка строки на подстроки с учетом заданного символа(строки) разделителя
Str - исходная строка, R - символ(строка) разделитель, в результате получается список TStrings найденных строк. function StrToArrays(str, r: string; out Temp: TStrings): Boolean; var j: integer; begin IF temp <> Nil then Begin temp.Clear; while str <> '' do Begin j := Pos(r,str); if j=0 then j := Length(str) + 1; temp.Add(Copy(Str,1,j-1)); Delete(Str,1,j+length(r)-1); End; Result:=True; End else Result:=False; end;
2. Слияние списка строк в одну строку с вставкой символа(строки)-разделителя
function ArrayToStr(str: TStrings; r: string): string; var i: integer; begin Result:=''; IF str = nil Then Exit; for i:= 0 to Str.Count-1 do Result := Result+Str.Strings[i]+r; end;
Дополнителльно по этой же теме
Cмотрите реализацию функций TStrings.GetCommaText и TStrings.SetTextStr в модуле Classes
Коллективное творчество нескольких авторов
Функция копирования части строки
При работе со строками часто возникает необходимость копировать кусок строки от одного символа (или нескольких) до другого (других). Каждый раз использовать copy или delete нерационально, поэтому я написал небольшую функцию:
| function GetBetween(first,second,line:string):string; var posF,posS,i:integer; st:string; index:boolean; begin st:=''; posF:=pos(first,line)+length(first);//начало копирования posS:=pos(second,line);//конец копирования index:=true; i:=1; while (i<=length(line))and(index) do begin if (i>=posF)and(i<posS) then st:=st+line[i]; if i=posS then index:=false; inc(i); end; GetBetween:=st; end. |
Есть правда одно ограничение: если в строке встречается несколько одинаковых кусков и такой кусок выбран в роли first или second, то результат не всегда будет корректным.
Функция посылает окну строку синхронно через WM_COPYDATA
Функция посылает окну строку (с дополнительным любым числом) синхронно через WM_COPYDATA. Можно и другому приложению. function SendIPCString(TargetWnd, SourceWnd: THandle; dwData: integer; const S: string): integer; var CD: TCopyDataStruct; begin CD.dwData := dwData; CD.cbData := Length(S); if CD.cbData = 0 then CD.lpData := NIL else CD.lpData := @S[1]; Result := SendMessage(TargetWnd, WM_COPYDATA, SourceWnd, integer(@CD)); end;
Алексей Еремеев
Функция приблизительного/нечеткого сравнения строк
| Недавно в поисках информации по интеллектуальным алгоритмам сравнения я нашел такой алгоритм — алгоритм сравнения (совпадения) двух строк, Так как он был написан на VBA, я под свои нужды переписал его на Delphi Уважаемые жители Королевства, я думаю данная функция пригодится тем, кто часто пишет функции поиска, особенно когда поиск приблизителен. То есть, например, в БД забито "Иванав Иван" - с ошибкой при наборе, а ищется "Иванов". Так вот, данный алгоритм может вам найти "Иванав" при вводе "Иванов",а также при "Иван Иванов" - даже наоборот с определенной степенью релевантности при сравнении. А используя сравнение в процентном отношении, вы можете производить поиск по неточным данным с более-менее степенью похожести. Еще раз повторяю, алгоритм не мой, я только его портировал на Delphi. |  |
Скачать проект (356 K)
Функция нечеткого сравнения строк БЕЗ УЧЕТА РЕГИСТРА
| //------------------------------------------------------------------------------ //MaxMatching - максимальная длина подстроки (достаточно 3-4) //strInputMatching - сравниваемая строка //strInputStandart - строка-образец // Сравнивание без учета регистра // if IndistinctMatching(4, "поисковая строка", "оригинальная строка - эталон") > 40 then ... Type TRetCount = packed record lngSubRows : Word; lngCountLike : Word; end; //------------------------------------------------------------------------------ function Matching(StrInputA: WideString; StrInputB: WideString; lngLen: Integer) : TRetCount; Var TempRet : TRetCount; PosStrB : Integer; PosStrA : Integer; StrA : WideString; StrB : WideString; StrTempA : WideString; StrTempB : WideString; begin StrA := String(StrInputA); StrB := String(StrInputB); For PosStrA:= 1 To Length(strA) - lngLen + 1 do begin StrTempA:= System.Copy(strA, PosStrA, lngLen); PosStrB:= 1; For PosStrB:= 1 To Length(strB) - lngLen + 1 do begin StrTempB:= System.Copy(strB, PosStrB, lngLen); If SysUtils.AnsiCompareText(StrTempA,StrTempB) = 0 Then begin Inc(TempRet.lngCountLike); break; end; end; Inc(TempRet.lngSubRows); end; // PosStrA Matching.lngCountLike:= TempRet.lngCountLike; Matching.lngSubRows := TempRet.lngSubRows; end; { function } //------------------------------------------------------------------------------ function IndistinctMatching(MaxMatching : Integer; strInputMatching: WideString; strInputStandart: WideString): Integer; Var gret : TRetCount; tret : TRetCount; lngCurLen: Integer ; //текущая длина подстроки begin //если не передан какой-либо параметр, то выход If (MaxMatching = 0) Or (Length(strInputMatching) = 0) Or (Length(strInputStandart) = 0) Then begin IndistinctMatching:= 0; exit; end; gret.lngCountLike:= 0; gret.lngSubRows := 0; // Цикл прохода по длине сравниваемой фразы For lngCurLen:= 1 To MaxMatching do begin //Сравниваем строку A со строкой B tret:= Matching(strInputMatching, strInputStandart, lngCurLen); gret.lngCountLike := gret.lngCountLike + tret.lngCountLike; gret.lngSubRows := gret.lngSubRows + tret.lngSubRows; //Сравниваем строку B со строкой A tret:= Matching(strInputStandart, strInputMatching, lngCurLen); gret.lngCountLike := gret.lngCountLike + tret.lngCountLike; gret.lngSubRows := gret.lngSubRows + tret.lngSubRows; end; If gret.lngSubRows = 0 Then begin IndistinctMatching:= 0; exit; end; IndistinctMatching:= Trunc((gret.lngCountLike / gret.lngSubRows) * 100); end; |
Кузан Дмитрий
Функция скрытия пиктограмм с рабочего стола
| Раздел Сокровищница |
Заметил в софтовых архивах, что появляються shareware программы с функцией скрытия пиктограмм с рабочего стола и эта возможность в некоторых декларируется как одна из самых "крутых". Стало обидно и смешно одновременно, поэтому набросал примерчик для тех кому интересно.
Чтобы скрыть пиктограммы, необходимо найти окно SysListView32, что делает код приведенный ниже. procedure TFrmProgman.FormCreate(Sender: TObject); begin FHandle := GetWindow(GetWindow(FindWindow('progman', nil), GW_CHILD), GW_CHILD); end; А здесь мы элементарно скрываем это окно или показываем. procedure TFrmProgman.btnHideClick(Sender: TObject); begin if TButton(Sender).Name = 'btnHide' then ShowWindow(FHandle, SW_HIDE) else ShowWindow(FHandle, SW_SHOW); end; При этом все функции рабочего стола активны - видна картинка, работает контекстное меню. Если же вы хотите и это убрать, тогда получите дескриптор окна progman.
(3K) — Пример для Дельфи 6, но код можно запустить под любой версией.
Исходники
Скачать модуль
Скачать программу тестирования скорости
Скачать практический пример
Использование буфера записей BDE
| Раздел Сокровищница |
Все идет к тому, что BDE в ближайшее время окончательно сдаст позиции компонентам прямого доступа к данным (IBX, dbExpress).
Но все наработанное с использованием BDE сразу не перепишешь и не выбросишь. Компоненты прямого доступа существенно расширяют возможности разработчика.
Недавно понадобилось напрямую работать с буфером записей запроса (TQuery), если бы можно было использовать IBQuery проблем бы с этим не возникло, но буфер записей BDE закрыт и просто до него не достучаться.
Задача стояла следующая: в БД (Interbase) при работе с достаточно большой таблицей появилась необходимость при навигации в ReadOnly DBGrid и нажатию короткой клавиши отмечать записи для отложенной печати (поле SOST := 1).
Данная задача решается несколькими способами:
Перевести Query в режим редактирования установить поле в необходимое значение и вызвать метод Query.Post; C использованием другого Query выполнить Update записи, затем переоткрыть Query. C использованием другого Query выполнить Update записи, затем в буфере записей выставить значение нужного поля. Первый метод не подходит по понятным соображениям, к тому же в нашем случае Query не редактируемый (RequestLive = false).
Второй слишком долгий и ведет к увеличению сетевого трафика.
Третий метод возможно реализовать только с использованием IBX или ClientDataSet, что в этом конкретном случае не приемлемо.
Поэтому для решения задачи третьим методом пришлось искать где BDE хранит полученные от IB сервера данные, вот что из этого получилось: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Db, DBTables, Grids, DBGrids, BDE, Menus; type TForm1 = class(TForm) DataSource: TDataSource; Query: TQuery; DBGrid: TDBGrid; Database: TDatabase; SetFldQ: TQuery; PopupMenu: TPopupMenu; Sost1: TMenuItem; Sost0: TMenuItem; procedure FormCreate(Sender: TObject); procedure Sost1Click(Sender: TObject); procedure Sost0Click(Sender: TObject); private { Private declarations } public { Public declarations } procedure SetSost(AValue: Integer); end; var Form1: TForm1; implementation {$R *.DFM} function GetBDERecBuff(ACursor: TQuery): Pointer;{cursor} Var P, P1: Pointer; CurNo, RecNo, RecSize: Integer; begin //Вызов этого метода синхронизирует положение курсора //DataSet и BDE ACursor.UpdateCursorPos; P := ACursor.Handle; Inc(PChar(P), $1E); P := Pointer(P^); Inc(PChar(P), $7E); P := Pointer(P^); Inc(PChar(P), $14); P := Pointer(P^); Inc(PChar(P), $36); P := Pointer(P^); // Получаем внутренний BDE-шный номер текущей записи P1 := P; Inc(PChar(P1), $A); Inc(PChar(P1), $2); RecNo := Integer(P1^) - 1; Inc(PChar(P), $4); P := Pointer(P^); // Получаем внутренний BDE-шный номер курсора P1 := P; Inc(PChar(P1), $11F); P1 := Pointer(P1^); CurNo := Word(P1^); // Получаем размер записи P1 := P; Inc(PChar(P1), $113); RecSize := Word(P1^); // Получаем указатель на массив где хранятся указатели на // буфера всех BDE курсоров Inc(PChar(P), $4); P := Pointer(P^); Inc(PChar(P), $68); P := Pointer(P^); // Выбираем из массива нужный нам указатель Inc(PChar(P), 4*(CurNo - 1)); P := Pointer(P^); // Получаем указатель на текущую запись Inc(PChar(P), RecNo * RecSize); Result := P; end; procedure PutFldToBDEBuf(ACursor: TQuery; AField: TField; pValue: Pointer); Var P: Pointer; begin // Получаем указатель на текущую запись P := GetBDERecBuff(ACursor); //складываем нужное значение в буфер BDE Check(DbiPutField(ACursor.Handle, AField.FieldNo, P, pValue)); //Вызов Resync для пересчета Calc-полей и немедленного отображений изменении на экране ACursor.Resync([]); end; procedure TForm1.FormCreate(Sender: TObject); begin Database.Open; Query.DataBaseName := Database.DatabaseName; SetFldQ.DataBaseName := Database.DatabaseName; DBGrid.PopupMenu := PopupMenu; Sost1.ShortCut := TextToShortCut('Ctrl+A'); Sost0.ShortCut := TextToShortCut('Ctrl+S'); Query.SQL.Text := 'SELECT * FROM AKODIF ORDER BY CODE'; Query.Open; SetFldQ.SQL.Text := 'UPDATE AKODIF SET SOST = :SOST WHERE CODE = :CODE'; SetFldQ.Prepare; end; procedure TForm1.SetSost(AValue: Integer); begin SetFldQ.ParamByName('SOST').AsInteger := AValue; SetFldQ.ParamByName('CODE').AsInteger := Query.FieldByName('CODE').AsInteger; SetFldQ.ExecSQL; PutFldToBDEBuf(Query, Query.FieldByName('SOST'), @AValue); end; procedure TForm1.Sost1Click(Sender: TObject); begin SetSost(1); end; procedure TForm1.Sost0Click(Sender: TObject); begin SetSost(0); end; end. Все описанное выше работает в Delphi 3, Delphi 4, Delphi 5. С BDE 5.01, idapi32.dll от 12.11.1999 размер 589 312. С другими версиями BDE скорее всего работать не будет!
Все, вышеописанное есть некий частный результат и интересует эта тема.
Использование функции wsprintf()
Данная заметка возможно, будет интересна для тех, кто программирует на Object Pascal с использованием только API-функций Windows.
Часто необходимо вывести (к примеру, даже в окошко с MB_OK) какое-то значение, будь то код ошибки типа HRESULT или результат работы какой-либо функции. Простейшее решение - использовать IntToStr() из модуля sysutils.pas. Однако в этом случае размер минимальной программы на Delphi увеличится с 16 до 41 кб, что лично меня очень неудовлетворяет. Хочется получить реальное преимущество в размерах, раз уж не используется VCL. Есть и другое объяснение - хотя мы и живём в эпоху быстрых процессоров и ёмких HDD, следить за качеством кода программ и его размерами обязывает культура программирования. В конце-концов это просто неразумно - ради одной функции тащить весь код из sysutils.pas и sysconst.pas. Складывается глупейшая ситуация - ради преобразования чисел в строку приходится мириться с тем, что к готовому exe-модулю подключаются многочисленные resourcestring и хлам в виде кучи ненужного кода.
Для некоторых преобразований можно использовать API-функцию wsprintf() из модуля windows.pas. Она позволяет произвести форматированную запись в буфер последовательности символов и значений аргументов. Вот как она описана: function wsprintf(Output: PChar; Format: PChar): Integer; stdcall; А вот так она описана в файле winuser.h: WINUSERAPI int WINAPIV wsprintfA(LPSTR, LPCSTR, ...); Как видно, осутствует третий параметр. Он подразумевает передачу значения произвольного типа - например, char* или int (при желании его можно даже опустить). Причина, по которой функция документирована неправильно - ограничение, накладываемое языком Object Pascal - он не позволяет передать в параметр функции значение произвольного типа (хотя, например, SizeOf() позволяет, но реализована она на системном уровне).
Я всё-таки нашёл способ приспособить wsprintf() для своих нужд. Выход - описать её самостоятельно в своей программе так:
function wsprintf( lpOut: LPSTR; lpFmt: LPCTSTR; p: Pointer ): Integer; stdcall; external 'user32.dll' name 'wsprintfA'; Теперь для вывода в буфер достаточно написать так: var szMessage: PChar; GetMem( szMessage, 256 ); // Определяем размер строки в памяти wsprintf( szMessage, 'Number %d', Pointer(899034)); MessageBox( 0, szMessage, 'Сообщение', MB_OK ); Предварительно надо выделить память для буфера, иначе форматирование не произойдёт.
Полную документацию по функции wsprintf() можно найти в справке Delphi. Добавлю, что для корректности можно приводить передаваемые значения не к типу Pointer, а к Pinteger - для типа Integer, PUINT - для целых беззнаковых и т. д.
Скачать demo-проект (0.67 K)
Смотрите также :
Использование команды RDTSC процессора Pentium для работы с малыми временными интервалам
| Раздел Сокровищница | нашел интересное использование команды RDTSC процессора Pentium для работы с малыми временными интервалами. Я думаю, что эта функция может найти широкое применение (в таймерах, управлении внешними устройствами, научных исследованиях).
Пример прилагается (4K) Этот счетчик увеличивается на 1 на каждом такте CPU. |
Использование модуля
Заводим переменную типа TFormula: TFormula=record CS:CodeSeg; //массив с кодом DS:DataSeg; //массив с переменными и константами proc:tproc; //вызываемая функция end; var formula1:tformula; Вызываем процедуру компиляции кода, в которой указываем нашу formula1, список имен используемых в ней переменных, и, конечно, входную строку. Для вычисления значения функции в formula1.DS записываем значения переменных в том порядке, в котором их имена фигурировали в списке (при этом важно изменять только первые 0..число переменных-1 элементы DS, т.к. в последующих элементах хранятся значения констант из входной строки), а затем вызываем formula1.proc, которая и возвратит искомое значение. Информация более конкретного характера содержится в самом модуле.
Использование SetRange
Метод procedure SetRange(const StartValues, EditValues: array of const);
показывает не только записи, индексные поля которых лежат в диапазоне [StartValues..EndValues].
Пример: Пусть в наборе данных Table1 показываются все записи. Включим в структуру записинабора данных два поля: "Номер группы" и "Наименование товара". Пусть итекущий индекс построен по полю "Номер группы".
Напишем такой обработчик события: CheckBox1.Click:
| procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp: Integer; begin If CheckBox1.Checked then begin GrNumTmp := StrToInt(Edit1.Text); With Table1 do begin CancelRange; SetRange([GrMunTmp],[GrNumTmp]); end; end else Table1.CancelRange; end; |
В отфильтрованном наборе данных показываются только те записи, индексное поле текущего индекса у которых (в нашем случае "Номер группы") имеет значение, лежащее в заданном диапазоне. В данном случае диапазон определяется переменной GrNumTmp. Поэтому для GrNumTmp = 3 будут показаны записи, принадлежащие к группе 3.
Если бы мы захотели, чтобы в наборе данных фильтровались записи из нескольких групп, то нам следовало бы добавить в форму второй компонент Edit2, в котором вводился бы номер конечной группы, в то время как в Edit1 вводился бы номер начльной группы:
| procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp1, GrNumTmp2: Integer; begin If CheckBox.Checked then begin GrNumTmp1 := StrToInt(Edit1.Text); GrNumTmp2 := StrToInt(Edit2.Text); With Table1 do begin CancelRange; SetRange([GrNumTmp1],[GrNumTmp2]); end; end else Table1.CancelRange; end; |
Александр Мефодьев [29.01.2000] (Специально для "Королевства")
ICQ: 56666220
Использованные идеи и алгоритмы
Алгоритм Эрли проверки корректности входной строки. Упрощенный вариант алгоритма Дейкстры перевода в обратную польскую запись на основе стека с приоритетами. Способ формирования кода в памяти из программы Сергея Втюрина. Методы вычисления различных математических функций из открытых исходников модуля Math.
Скачать проект (25K)
Смотрите также :
Используемые инструменты
Для копирования баз данных можно использовать различные инструменты. Я использую для этих целей специально разработанную программу копирования баз данных, под названием "Репликатор". Её можно скачать по адресу
Что же эта программа умеет?
Она умеет выполнять скрипты, копировать таблицы в нужной последовательности, отключать триггера, ключи, ограничения. А так же обходит ошибки вынося их текст в Лог и не обрывая соединение. А это нам и нужно для восстановления и перегенерации баз данных.
Изменение в ходе выполнения
| Раздел Сокровищница |
Сразу скажу, что эта статья - маленькая рекомендация тем, кто хочет реализовать возможность работы TWebBrowser в своей программе с настройками Proxy , которые отличаются от стандартных.
В один прекрасный день мне понадобилось в программе периодически менять Proxy и при этом пользоваться всем, что предоставляет IE. Лучший и единственный выбор - TwebBrowser. При близком знакомстве с ним стало понятно, что через Proxy он работать не может (вернее может, но берет настройки из "Свойств обозревателя"). Перспектива постоянно менять настройки реестра меня не прельщала . И как назло ни в одной крупной конференции не было даже упоминания о возможности настройки Proxy в ходе выполнения программы кроме изменения реестра (может плохо искал).
Перерыв Fido-архивы и конференции Инета накаткнулся на win-функцию UrlMkSetSessionOption. Вот к чему привели мои изыскания : .... uses ... urlmon, wininet ... .... var PIInfo : PInternetProxyInfo; ... New (PIInfo) ; // Изменение настроек ПРОКСИ PIInfo^.dwAccessType := INTERNET_OPEN_TYPE_PROXY ; // Тип доступа в интернет - через Proxy сервер PIInfo^.lpszProxy := PChar('some.proxy:someport'); // указать прокси напр. 195.43.67.33:8080 PIInfo^.lpszProxyBypass := PChar(''); // Список адресов, доступ к которым возможен минуя Proxy сервер UrlMkSetSessionOption(INTERNET_OPTION_PROXY, piinfo, SizeOf(Internet_Proxy_Info),0); .... Dispose (PIInfo) ; .... Вызывать функцию UrlMkSetSessionOption можно из любого места программы, причем любое количество раз и с разными настройками.
После вызова функции TWebBrowser будет работать через указанный прокси. Еще раз повторюсь, настройки касаются только текущей сессии (программы на момент выполнения ), общие настройки Windows не изменяются.
Андрей Попков
Дополнительно:
INTERNET_PROXY_INFO Structure Contains information that is supplied with the INTERNET_OPTION_PROXY value to get or set proxy information on a handle obtained from a call to the InternetOpen function. Syntax typedef struct { DWORD dwAccessType; LPCTSTR lpszProxy; LPCTSTR lpszProxyBypass; } INTERNET_PROXY_INFO, * LPINTERNET_PROXY_INFO; Members dwAccessType Unsigned long integer value that contains the access type. This can be one of the following values: INTERNET_OPEN_TYPE_DIRECT Internet accessed through a direct connection. INTERNET_OPEN_TYPE_PRECONFIG Applies only when setting proxy information. INTERNET_OPEN_TYPE_PROXY Internet accessed using a proxy. lpszProxy Address of a string value that contains the proxy server list. lpszProxyBypass Address of a string value that contains the proxy bypass list.
Это Unit1.pas
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons,StrEx,Math; type TForm1 = class(TForm) Edit1: TEdit; BitBtn1: TBitBtn; Label1: TLabel; Memo1: TMemo; Button1: TButton; Edit2: TEdit; Label2: TLabel; Button2: TButton; procedure BitBtn1Click(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Edit1Change(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; TProc=procedure; var Form1: TForm1; A:array of real; CS:array of Byte; DS:array of Real; Res,X,Y:real; proc:TProc; function preCalc(Ex:String):real; function Prepare(Ex:String):real; function SecindBracket(Ex:String;first:integer):Integer; implementation {$R *.DFM} // это про скобки... это просто и не заслуживает большого внимания. function SecindBracket(Ex:String;first:integer):Integer; var i,BrQ:integer; begin Result:=0; case Ex[first] of '(': begin i:=first+1; BrQ:=0; while (i<=length(Ex)) do begin if (BrQ=0) and (Ex[i]=')') then begin Result:=i;exit;end; if Ex[i]='(' then Inc(BrQ) else if Ex[i]=')' then Dec(BrQ); i:=i+1; end; end; ')': begin i:=first-1; BrQ:=0; while (i>0) do begin if (BrQ=0) and (Ex[i]='(') then begin Result:=i;exit;end; if Ex[i]='(' then Inc(BrQ) else if Ex[i]=')' then Dec(BrQ); i:=i-1; end; end; end; end; // а вот тут мы собственно и формируем процедуру function Prepare(Ex:String):real; begin SetLength(Ds,1); // вот это будет заголовок SetLength(CS,6); cs[0]:=$8b; cs[1]:=$05; cs[2]:=(integer(@ds) and $000000FF) shr 0; cs[3]:=(integer(@ds) and $0000FF00) shr 8; cs[4]:=(integer(@ds) and $00FF0000) shr 16; cs[5]:=(integer(@ds) and $FF000000) shr 24; // вот это - вычисление X:=1; //догадайтесь зачем :) preCalc(Ex); // а вот это - завершение SetLength(CS,high(CS)+7); cs[high(CS)-5]:=$DD; cs[high(CS)-4]:=$1D; cs[high(CS)-3]:=(integer(@res) and $000000FF) shr 0; cs[high(CS)-2]:=(integer(@res) and $0000FF00) shr 8; cs[high(CS)-1]:=(integer(@res) and $00FF0000) shr 16; cs[high(CS)-0]:=(integer(@res) and $FF000000) shr 24; SetLength(CS,high(CS)+2); // ну и не забудем про RET cs[high(CS)]:=$C3;// ret proc:=pointer(cs); end; // будем формировать код рассчета. function preCalc(Ex:String):real; var Sc,i,j:integer; s,s1:String; A,B:real; const Op: array [0..3] of char =('+','-','/','*'); begin s:=''; // да всегда инициализируйте переменные ваши for i:=1 to length(Ex) do if ex[i]<>' ' then s:=s+ex[i]; // чтобы под ногами не путались :) while SecindBracket(s,Length(s))=1 do s:=copy(s,2,Length(s)-2);// скобки if s='' then begin Result:=0; ShowMessage('Error !'); exit; end; val(s,Result,i); // это число ? а какое ? if i=0 then begin // ага это число. так и запишем Form1.Memo1.Lines.Add('fld '+FloatToStr(result)); SetLength(Ds,high(ds)+2); Ds[high(ds)]:=Result; SetLength(CS,high(CS)+4); cs[high(Cs)]:=high(ds)*8; cs[high(Cs)-1]:=$40; cs[high(Cs)-2]:=$DD; exit; end; if (s='x') or (s='X') then begin // опа, да это же Икс ! Form1.Memo1.Lines.Add('fld X'); SetLength(CS,high(CS)+7); cs[high(CS)-5]:=$DD; cs[high(CS)-4]:=$05; cs[high(CS)-3]:=(integer(@x) and $000000FF) shr 0; cs[high(CS)-2]:=(integer(@x) and $0000FF00) shr 8; cs[high(CS)-1]:=(integer(@x) and $00FF0000) shr 16; cs[high(CS)-0]:=(integer(@x) and $FF000000) shr 24; end; // это все еще выражение :( ох не кончились наши мучения i:=-1; j:=0; while j<=1 do Begin i:=length(s); Sc:=0; while i>0 do begin // ну скобки надо обойти if s[i]=')' then Inc(Sc); if s[i]='(' then Dec(Sc); if Sc<>0 then begin dec(i); continue; end; if (s[i]=Op[j*2]) then begin j:=j*2+10; break; end; if (s[i]=Op[j*2+1]) then begin j:=j*2+11; break; end; dec(i); end; inc(j); End; //('+','-','/','*'); // а вот и рекурсия - все что справа и слева от меня пусть обработает ... // ой да это же я:) Ну а я так уж и быть сформирую код операции в середине :) case j of 11: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FAddp St(1),st'); // cs //fAddP st(1),st // [DE C1] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$C1; // вот такой код сформируем cs[high(Cs)-1]:=$DE; end; // далее - аналогично для каждой операции 12: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FSubP St(1),st'); //fSubP st(1),st // [DE E9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$E9; cs[high(Cs)-1]:=$DE; end; 13: begin try preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('fdivP st(1),st'); //fDivP st(1),st // [DE F9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$F9; cs[high(Cs)-1]:=$DE; except ShowMessage('Division by zero !... '); preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); exit; end; end; 14: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FMulp St(1),st'); //fMulP st(1),st // [DE C9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$C9; cs[high(Cs)-1]:=$DE; end; end; end; // Вычисляй procedure TForm1.BitBtn1Click(Sender: TObject); begin x:=StrToFloat(Edit2.text); if (@proc<>nil) then proc; // Вычисляй Label1.caption:=FloatToStr( res ); end; // это всякие сервисные функции procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Clear; Prepare(Edit1.text); BitBtn1.Enabled:=true; end; procedure TForm1.Edit1Change(Sender: TObject); begin BitBtn1.Enabled:=false; end; procedure TForm1.FormCreate(Sender: TObject); begin Edit1.OnChange(self); end; // а это для того чтобы посмотреть какой за быстрый получился код procedure TForm1.Button2Click(Sender: TObject); //Speed test var t:TDateTime; i:integer; const N=$5000000; //количество повторений begin if @proc=nil then exit; t:=now; for i:=0 to N do begin x:=i; proc; x:=res; end; t:=now-t; Memo1.lines.add('work time for '+inttostr(N)+' repeats ='+TimeToStr(t)+' sec'); Memo1.lines.add('='+FloatToStr(t)+ ' days' ); end; end.
Как появляются иконки в трее.
| Раздел Сокровищница | ан Минич, дата публикации 09 июля |
Иконку в трей помещают с помощью Shell_NotifyIconW. Интересено посмотреть на этот процесс с другой точки зрения.
Цитата с сайта delphi.mastak.ru:
Shell_NotifyIconW просто ищет окно с классом "Shell_TrayWnd" и посылает в него сообщение WM_COPYDATA. в качестве данных выступает простая структура TNIDMessage.
возвращаясь к топику: если создать свое окно с классом "Shell_TrayWnd" и обрабатывать входящие сообщения WM_COPYDATA, то можно написать полный аналог system tray! ...
(с) paul_shmakov
...чем и займемся.
В первую очередь немаловажное замечание: сообщение посылается только одному окну, то есть наше приложение должно грузится первым. Разные там explorer'ы и другие подобные будут мешать.
Шаг первый:
Создаем окно "Shell_TrayWnd"
| procedure TForm1.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.WinClassName := 'Shell_TrayWnd'; end; |
Все. Окно класса "Shell_TrayWnd" имеем.
Шаг второй:
Ловим WM_COPYDATA
| procedure TFORM1.WMCOPYDATA(var Msg: Tmessage); var pcd: PCopyDataStruct; NID: PNotifyIconData; begin pcd := PCOPYDATASTRUCT(msg.lParam); if pcd^.dwData = 1 then begin NID := pointer(integer(pcd.lpData)+8); case integer(pointer(integer(pcd.lpData)+4)^) of NIM_ADD: Msg.Result := NewTrayIcon(NID); // добавить иконку NIM_DELETE: Msg.Result := DeleteTrayIcon(NID); // удалить иконку NIM_MODIFY: Msg.Result := ModifyTrayIcon(NID); // изменить иконку (или подсказку) end; exit; end; end; |
Обратите внимание на Msg.Result. Желательно чтобы NewTrayIcon, DeleteTrayIcon, ModifyTrayIcon возвращали Integer(True) или Integer(False) в зависимости от помещения/удаления иконки.
Некоторые приложения не проверяют этот результат, но если начнут проверять - то причины "глючного" поведения иконки того же AVP Monitor можно искать долго и безуспешно.
Шаг третий:
Поймали, и че с ним теперь делать?
А мы имеем очень интересную структуру - NID.cbSize - размер записи, в принципе не интересен; NID.Wnd - хендл окна (владельца иконки); NID.uID - идентификатор иконки (если их в приложении несколько), для данной задачи нужен для отсылки обратного сообщения; NID.uFlags - определяет, какие поля используются в сообщении. Параметр может быть любой комбинацией из флагов (0 - uCallbackMessage, 2 - hIcon, 4 - czTip); NID.uCallbackMessage - номер сообщения, которое посылается окну, определяемому полем NID.Wnd (владельцу). lParam отсылаемого сообщения дожен равняться NID.uID, а wParam сообщение от мыши.
Пример: PostMessage(NID.Wnd, NID.uCallBack, NID.uID, MOUSE_EVENT) где MOUSE_EVENT может принимать значения WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK и подобные для других кнопок мыши. NID.hIcon - хендл иконки, которую собственно и предполагается отображать; NID.szTip - строка, оканчивающаяся нулевым символом, содержит подсказку, которая должна выводится при наведении курсора на иконку.
В случаях ошибки нужно информировать приложения про необходимость поместить иконки обратно. Для этого послужат такие действия:
| procedure TForm1.FormCreate(Sender: TObject); var WM_TASKBARCREATED: UINT; begin WM_TASKBARCREATED := RegisterWindowMessage('TaskbarCreated'); PostMessage(HWND_BROADCAST, WM_TASKBARCREATED, 0, 0); end; |
Скачать демо проект (9.8K)
И несколько слов о демо проекте.
ВНИМАНИЕ!!! Следуйте данным инструкциям только в том случае, если Вы ясно понимаете смысл действий!!!
Повторюсь: Shell_NotifyIconW сообщение посылает только одному окну. Поэтому чтобы увидеть результаты работы демопроекта, загружать его надо без или вместо explorer'а.
Первый вариант (для Win9x): Пример: файл %windir%\system.ini изменить следующим образом:
Найти строчку:
shell=explorer.exe Заменить на (предполагается что демопроект находится в C:\Demotray\ ) : ;shell=explorer.exe shell=c:\demotray\demotray.exe Перегрузите Windows
Для возврата explorer'a раскомментируйте первую строчку, закомментируйте или удалите вторую.
Второй вариант: Лично я использую Far для выгрузки Explorer.exe
1) Загружаем IDE Delphi и демопроект 2) Загружаем Far, F11->Process list->
выбираем EXPLORER.EXE->F8->OK 3) Отлаживаем проект 4) Для появления Explorer'a просто запустите его.
Используйте эти инструкции на свой страх и риск. Прочитайте их дважды. Внимательно изучите исходники. Трижды.
Инструкции по закрытию EXPLORER.EXE действительны для Win9x.
Если у Вас NT - разберитесь сами. Если не сможете разобратся - то за такие проекты Вам браться рановато.
Гревные ругательства "А у меня после ... ничего не работает!" не принимаются.
Благодарности: Paul Shmakov - реверсинг Shell_NotifyIcon, моральная поддержка. Стив Тейксейра & Ксавье Пачеко - литература. Особая благодарность обоим использованым алфавитам.
Богдан Минич
Смотрите также: Добавить "иконку" приложения в область SysTray.
Как создать свое окно предварительного просмотра QuickReport отчетов?
| Раздел Сокровищница |
Внятного и простого ответа куцая документация на компонент TQRPreview не дает. И, хотя ответ на этот вопрос действительно очень прост, мне все же пришлось потратить некоторое время на его поиски, результаты которых я и привожу.
Создайте пустую форму и поместите на нее объекты TQRPreview, TToolBar и TImageList. Свойство Align QRPreview установите в alClient. Добавьте на компонент TToolBar необходимые вам кнопки. В TImageList с помощью ImageList Editor поместите иконки для кнопок ToolBar`а (я использовал иконки от стандартного QuickReport окна предпросмотра выдранные в помощью Resource Explorer) и в свойство ToolBar.Images поместите имя созданного компонента TImageList.
Затем переходим к написанию обработчиков нажатий на кнопки. Основные используемые свойства : QRPreview.PageNumber - номер текущей просматриваемой страницы, QRPreview.Zoom - масштаб просмотра отчета и QRPreview.QRPrinter - объект принтера. Ниже показаны назначения кнопок и обработчики для них : * Печать отчета QRPreview.QRPrinter.Print; * Настройка принтера QRPreview.QRPrinter.PrintSetup; * Переход к первой странице QRPreview.PageNumber:=1; * Переход к предыдущей странице QRPreview.PageNumber:=QRPreview.PageNumber-1; * Переход к следующей странице QRPreview.PageNumber:=QRPreview.PageNumber+1; * Переход к последней странице QRPreview.PageNumber:=QRPreview.QRPrinter.PageCount; * Масштабирование отчета на 100% QRPreview.Zoom:=100; * Масштабирование отчета по ширине страницы QRPreview.ZoomToWidth; * Масштабирование отчета по целой странице QRPreview.ZoomToFit; Процедуры сохранения, загрузки отчета и подобные можно найти в исходниках QuickReport`а в файле qrprev.pas (почти все вышеперечисленные обработчики также взяты из этого файла).
Последнее что требуется сделать - написать такой обработчик события OnPreview просматриваемого отчета : frmPreview.QRPreview.QRPrinter:=TQRPrinter(Sender); //frmPreview - форма frmPreview.Show; // окна предпросмотра Видно, что окно предпросмотра не содержит ссылок на конкретный компонент TQuickRep и очевидно что его можно использовать в различных отчетах и программах. Разумеется всплывающие подсказки на кнопках и прочие красивости вставляются по вкусу.
В обработчик закрытия окна нужно записать следующие строки : QRPreview.QRPrinter.ShowingPreview:=false; QRPreview.QRPrinter.Free;
PS. Замечания и исправления принимаются по адресу shadowj@yandex.ru
Алексей Трунтов
Специально для
Как все это работает:
Компилятор он и есть компилятор. Сначала выражение надо скомпилировать. Делается это с помощью функции
function Prepare(Ex:String):real; которая вызывает function preCalc(Ex:String):real;формирующую код, вычисляющий заданное выражение. Как можно догадаться, Ex - это строка, содержащая математическое выражение. Функция preCalc рекурсивна и распознавая полученную математику, попутно формируя исполняемый код. Она имеет мало проверок на корректность и нет нужды вводить туда мусор и радоваться, когда увидите что все повисло. Помните правило GIGO (Garbage in Garbage Out). Не надо также ставить 0 под знак деления. Но это уже не моя ошибка :)))
ВНИМАНИЕ:
ограничение на глубина рекурсии: полученый код не должен помещать в стек более 8 значений.Снятие этого ограничения опять же лишь вопрос практической реализации.
Для понятности формируемый код представляется в ближайшем Memo. Функция возвращает: а фиг его знает что она возвращает :) лучше не обращайте внимания :)
Скомпилировали? Теперь можно и запускать:
При компиляции мы сформировали процедуру с красноречивым названием: proc:TProc; где type TProc=procedure; пример запуска можно найти в procedure TForm1.BitBtn1Click(Sender: TObject); Также встречаются процедуры и функции: function SecindBracket(Ex:String;first:integer):Integer; вот уж и не помню, отчего появилось такое красивое название (скорее всего от очепятки), но все это призвано обработать скобки в выражении , procedure TForm1.BitBtn1Click(Sender: TObject); // Вычисляйзапускает вычисление, а также procedure TForm1.Button2Click(Sender: TObject); //Speed testдля того чтобы посмотреть какой за быстрый получился код.
К сему прилагается слегка комментированный исходный код. Вряд ли кому нужны комментарии типа: I:=0; // обнуляем счетчик а по структуре программы там комментариев хватает.
Ну вот и все... Буду рад если вам это пригодиться. Если какие пожелания - пишите. Конструктивная критика - пишите. Неконструктивная критика - тоже пишите - у меня файлы удаляются без помещения в корзину.
Как выставить приоритет любому процессу
В качестве параметров необходимо передать _имя процесса_ (то, которое в диспетчере задач) и приоритет.
Не забудьте также подключить модуль TLHelp32.
| procedure SetPriority(Name: String; Priority: Integer); var Handler: THandle; Data: TProcessEntry32; Finded: boolean; Res: boolean; ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle; function ReturnName: String; var I : byte; Names: string; begin names:=''; i:=0; while data.szExeFile[i] <> '' do begin names:=names+data.szExeFile[i]; inc(i); end; ReturnName:=names; end; procedure TryIt; begin if AnsiUpperCase(ReturnName)=AnsiUpperCase(Name) then begin ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, true, data.th32ProcessID); Finded:=true; if ProcessHandle=0 then begin RaiseLastWin32Error; exit; end; case Priority of 0: Res:=true; 1: Res:=SetPriorityClass(ProcessHandle, IDLE_PRIORITY_CLASS); 2: Res:=SetPriorityClass(ProcessHandle, NORMAL_PRIORITY_CLASS); 3: Res:=SetPriorityClass(ProcessHandle, HIGH_PRIORITY_CLASS); 4: Res:=SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); end; if not Res then RaiseLastWin32Error; end; end; begin Finded:=false; Handler:= CreateToolHelp32SnapShot(TH32CS_SNAPALL,0); if process32first(handler,data) then begin TryIt; while process32next(handler,data) do TryIt end; if not Finded then ShowMessage('Cannot find'); end; |
Как заставить работать ActionList в формах, импортируемых из DLL
При использовании форм, импортируемых из DLL, вы столкнетесь с проблемой что ActionList работать не будет до тех пор, пока вы не активизируете его обновление самостоятельно. А следовательно, обновление всех компонентов управления работать не будет.
Класс для чтения/записи потока с преобразованием информации "на лету".
| й Перовский, дата публикации 18 ноября 2003г. |
Мне пришлось столкнуться с проблемой записи информации в шифрованный файл. Причем в прототипе использовалась запись иерархии объектов в FileStream при помощи функций Load и Store. Чтобы не переделывать объекты и методы сохранения/восстановления, я создал класс TСryptoStream наследник TStream, предназначенный для блочного шифрования информации. Понятно, что сам метод шифрования может быть произвольным. Более того, это может быть совсем не шифрование, а, например, перекодировка, подсчет статистики и т.д.
Работа с TCryptoStream аналогична работе с TFileStream - при создании объекта указывается режим записи или чтения. Для преобразования блоков используется внешняя функция.
| const csmOpenRead =0; {либо чтение, либо запись} csmOpenWrite =1; {только последовательный доступ} type Tcsm = csmOpenRead .. csmOpenWrite;{csm- CryptoStreamMode - режим работы} {Функция блочного преобразования должна быть этого типа} TTransform=procedure ( Buffer:pointer; Count: Longint); {Описание класса TCryptoStream} TCryptoStream=class (TStream) private fMode:Tcsm; {либо чтение, либо запись} FS:TStream; {обрабатываемый поток} FTransform:TTransform;{Функция блочного преобразования} Data:pointer; {Указатель на блок для преобразования} L:integer; {Размер блока преобразования} Ost:integer; {Текущее свободное место в блоке} public constructor Create(S:TStream;al:integer; aTransform: TTransform;Mode: Tcsm); destructor destroy;override; function Read(var Buffer; Count: Longint): Longint;override; function Write(const Buffer; Count: Longint): Longint; override; end; |
В прилагаемых файлах, кроме собственно модуля uCryptoStream, содержится проект, демонстрирующий использование TСryptoStream для шифрования потока простейшим методом (XOR с заданным значением).
Скачать (4.5K)
