Не часто задаваемые вопросы по Delphi
Этот сборник вопросов по Delphi составлен и постоянно пополняется нами с 1998 г.
Мы используем как собственный опыт, так и сторонние источники для его пополнеия.
При этом мы отбираем вопросы, касающиеся специфицеских возможностей и нестандартных приемов программирования.
Мы надеемся, что и новички и специалисты найдут в данном сборнике ответы на интересующие их вопросы.
Даже если ответа на интересующий Вас вопрос здесь нет, то Вы наверняка узнаете что-то для себя новое.
Данный документ создан на основе БД программы Consul. Вы можете скачать программу Consul бесплатно.
В состав дистрибутива входит и настоящая база данных.

Общее Список авторов, чья информация использована в настоящей базе данных по Delphi в алфавитном порядке. Рекомендуемая литература по Delphi. Проблема с использованием Delphi-приложений в различных форматах экрана. Какие дефайны использовать для определения версии Delphi/CPPB ? Borland IDE Как включить окошко CPU Window? Как установить компонент от Delphi 2 под Delphi 3? Delphi требуют PAS-файл. Object Pascal Преобразование PChar в longint Различия в значении логического типа TRUE. Утечка памяти при поиске файлов( FindFirst, FindNext ). OLE Как работать с файлами MS Word или таблицами Excel? Пример запуска макроса в MS WinWord-е. API Управление аппаратной частью Открытие и закрытие устройства CD ROM. Изменение громгости звука в Windows95 Переключение видео режимов. Получение списка логических устройств в W95 и их типов. Как корректно проверить готовность дисковода? Как определить тип устройства? Привязка к серийному номеру винта. Минимальная инф-ия о состоянии модема. Как программно изменять громкость звука? Сообщения & события Как контролироавать число документов в очереди принтера? Как послать самостийное сообщение всем главным окнам в Windows? Как отследить изменение файловой системы и/или реестра ОС? Обмен информацией между приложениями Win32 — Win16. Как пpинимать яpлыки пpи пеpетягивании их на контpол ? Как перехватить нажатие 'горячих клавиш' ОС? DLL Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32? Администрирование [Win32] Как проверить, имеем ли мы административные привилегии в системе? Как отследить изменение файловой системы и/или реестра ОС? Ресурсы Как инсталлировать на время работы программы свои шрифты? Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)? Не горизонтальный шрифт. Выделение иконки из приложения. Расширения оболочки W95 А как поместить свою иконку в область индикаторов на taskbar? Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как добавить горизонтальную полосу прокрутки в TListBox? Как создавать ярлыки на рабочем столе? Как получить имя папки pабочего стола? Хэндл рабочего стола для манипуляций с иконками рабочего стола? Очистка папки 'Документы'. Получение информыции о ярлыках. Как спрятать панель задач в Windows? Как очистить все файлы в меню Документы? Удаление файлов в корзину Трюки Как эмулировать нажатие CTRL+ESC для показа стартового меню? Как перезагрузить Explorer? Как удалить кнопку 'Пуск' из панели задач (taskbar)? Как вставить в StatusPanel свои компоненты, например ProgressBar? Как консольное приложение может узнать что Винды завершаются? Как сделать так, чтобы запущенная программа не была видна на панели задач? Как запрограммировать непрямоугольную форму? Как получить иконку и имя Рабочего Стола? Как изменить внешний вид хинтов (всплывающих подсказок)? Отключение CTRL-ALT-DEL Как создать приложение чтобы его не было видно в tasklist'е при нажатии CTRL+ALT+DEL? Удаление запущенного процесса. Работа с файлами Как отловить события создания или удаления файлов другими программами? [Win32] Как удалить файл в корзину (Recycle Bin)? Диалог выбора директории. Копирование файлов средствами Windows. Мышь,клавиатура и таймер Как ограничить перемещение курсора мыши какой-либо областью экрана? Как переключать раскладку клавиатуры из своей программы? Как перехватывать клавиши, нажатые в окне другой программы? И любые события, поступающие другим программам? Как отчитывать промежутки времени с точностью, большей чем 60 мсек? Процессы Как мне запустить какую-нибудь программу? А как подождать, пока запущенная мной программа не отработает? Принудительное завершение процесса. Как сделать так, чтобы программу можно было запустить только в одном экземпляре? [Win32] Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе? Как запретить переключение на другие задачи? Организация ожидания. Как выполнить перезагрузку (reboot) в Windows NT? Как спрятать окно приложения из списка задач и из таскбара? Получение хэндла главного окна процесса по хэндлу процесса. Как получить результат работы консольной программы ? Как поменять приоритет процесса? Запуск задач в качестве системных процессов. Сетевые ф-ии Проверка подключения к сети. Как узнать список установленных cjm-портов? Окна Перебор окон. Другое Переменные окружения Информация о виртуальной памяти. Как сделать MS-Style диалог "О программе" ? Информация о часовых поясах. Как обновить ярлыки на рабочем столе? ЧТО ДЕЛАЕТ inf-файл? DB Просмотр удаленных записей в DBase Упаковка таблицы Paradox Как заставить BDE производить запись изменений в таблицах Paradox на диск? Ускорение работы с последовательностью записей. Путь к локальной таблице. Создание алиасов. SQL Как в DELPHI 3 заполнить поле одним и тем же значением сразу у многих записей? Сетевые ф-ии WSAAsyncSelect: параметр handle при запускаете dll (init). Как сделать чтобы при событиях моя программа отпpавляла кому-либо сообщение на мой компьютеp. Как работать с поименованными каналами под W'95/NT в сети? Как подключать сетевые диски? Стандартные элементы управления Мне надо добавить много строк в TListbox или в TCombobox или в TMemo или в TRichEdit, при этом сам объект постоянно мигает, перерисовываясь. Как избавиться от этого? Многоколоночный ListBox. Как указать максимальный размер текста для RichEdit Control? Выделение стpочек в TTreeView жиpным или бледным. Как в TMemo определить номер строки, в которой находится курсор и его местоположение в строке. Выделение стpок в TTreeView жиpным/бледным. Позициированиие в ListBox. Элементы VCL Отправка сообщений компонентам Ускорение работы TMemo Как привязать к конкретному компоненту дополнительную информацию? Cвойство Hint Каким образом можно отследить вставку и удаление компонент в форму в design-time? Как создать копию произвольного компонента? Как использовать ChartFX. Формы Как сделать так, чтобы по Alt-F4 форма не закрывалась, а выдавала запрос на сохранение? Как правильно создавать компоненты в run-time? Как можно перетаскивать форму не только за заголовок? Как сделать так, чтобы в моей форме курсор перемещался по полям ввода по Enter, как по Tab? Как запретить кнопку Close [x] в заголовке окна. Как отобразить некоторые окна своей программы в панели задач Windows (помимо главного окна) Свертывание фоpмы при откpытом модальном окне. Имея имя фоpмы нyжно пеpебpать на ней все компоненты имеющие свойство font. Необходимо, чтобы дочерняя форма не активизировала родительское окно. Как использовать форму из DLL ? MDI MDI-приложение, в котором способны сливаться не только меню дочернего и главного окна, но и полосы инструментов? Работа с принтером Простейший способ печати. Как мне отправить на принтер чистый поток данных? Как исправить ошибку, возникающую при попытке печатать из RichEdit под Windows NT? Как отправить на принтер чистый поток данных? Наиболее распространенные библиотеки компонентов rxLib Курсоры, иконки и др. Как использовать свои курсоры в программе? Как я могу использовать анимированный курсор? Работа с Help файлами Хелп с окошечком для поиска раздела. Как заставить Help-файлы нормально отображать русский под Windows 3.x? Графика Создание и обработка изображений Как создать disable'ный битмап из обычного (emboss etc)? Как скопировать экран (или его часть) в TBitmap? Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра? Как быстро нарисовать тень в заданном регионе? Как рисовать на органе управления, если свойство Canvas недоступно? Работа с изображением в памяти. Как преобразовать ICO в BMP? Как из HBitmap получить АДРЕС БИТМАПА В ПАМЯТИ ? Создание иконки из битового изображения Преобразование цветного изображения в черно-белое Графические форматы Как работать с разными графическими форматами, кроме BMP? JPG в Visual C++ 5.0. GIF из RxLib 2.40 Другое Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)? Подскажите способ обмена информацией между приложениями Win32 — Win16. Как сказать VCL, чтобы клавиши shortcut пунктов главного меню главной формы действовали только в этой форме? Как задать в качестве фона MDIForm картинку из TBitmap? [Win32] Как вывести на экран путь файла с "красивым" обрезанием по длине? Каким образом можно мзменить системное меню формы? Размер рабочего стола. Как умертвить PC Speaker? Как из программы переключать языки? Как удобнее работать с буфером обмена как последовательностью байт? Как изменить внешний вид хинтов (всплывающих подсказок)? Как проиграть Wave-ресурс? Каким образом можно мзменить системное меню формы? Добавление пунктов в системное меню. Поиск запущенной копии вашей программы. Форма отображения величин в окне "Watch List". Как работать с плагинами ? Имитация ввода с клавиатуры для программы выполняющейся в дос-окне? Как получить результат работы консольной программы ? Алгоритмы Как считать CRC-32 ? Преобразование сумм в выражения прописью. Bugs Const из другого unit'а дает неверное значение.

Общее Список авторов, чья информация использована в настоящей базе данных по Delphi в алфавитном порядке.
Akzhan Abdulin, 2:5040/55 Anthony Buntyakov, antosha(at)metcombank.ru Arthur Aseev, 2:5030/465.2 Andrey Grigoriev, 2:5061/24.20 Alex Konshin, 2:5030/217 Alexander Lokshin, 2:5020/529 Alexey Mahotkin, 2:5020/433, alexm(at)hsys.msk.ru Alexander Petrosyan, 2:5020/468.8 Alex Petin, 2:5000/97.8 Andrey Ruckoy, 2:5047/7 Andrey Sarinkov, 2:5040/33.121 Alexey Sinutin, 2:5022/12.16 Andrew Verigo, 2:452/23.32 Alexey Yashin, 2:5020/62.31 Boris Loboda, 2:461/256 Boris Podchezertseff, 2:5020/656.20 Dmitry Kryloff, 2:5054/9.20 Dmitry Shikhman, 2:468/13.32 Eugene Kopko, 2:464/196 Evgeny Levashoff, 2:5022/31.7 Eugene Mayevski, 2:463/209 Eugeny Sverchkov, 2:5031/12.23 Ilya Andreev, 2:5030/55.28 Ivan Gudym, 2:4642/2213.9 Igor Slusarev, 2:5020/118.18 Juris Bekins, 2:5100/35 Max Vystropov, 2:5020/1412 Pavel Shklovsky, 2:5011/18 Roman Procopovich, 2:5030/254.201 Roman Rechmakov, 2:5020/952.26 Stanislav Babin, 2:5030/356.7 Serge Korolev, 2:5020/104 Sergey Mazunov, 2:5083/30.20 Sergey Okhapkin, 2:5020/47 Serg Vostrikov, 2:5053/15.3 Sergey Arkhipov, 2:5054/88.10 Sergey Belov, sbelov(at)aha.ru Victor Babkin, 2:463/279.6 Vlad Sharnin, vlad(at)nplks.rb.ru Chudin Andrey, 2:5020/1246.16 составление: Chudin Andrey, 2:5020/1246.16 Inprize FAQ В некоторых текстах ответов источник оговорен отдельно. Рекомендуемая литература по Delphi.
1) Кен Хендриксон "Руководство разработчика баз данных" 2) Рэй Конопка "Hаписание оригинальных компонент в среде Delphi" 3) Рэй Лишнер "Секреты Delphi 2" 4) Том Сван "Програмирование в Delphi для Windows95" 5) Tом Сван "Секреты 32 разрядного программирования в Delphi" 6) Джеффри Рихтер "Windows для профессионалов" (highly recommended!) 7) Т. Миллер, "Использование Delphi 3" Проблема с использованием Delphi-приложений в различных форматах экрана.
ОТВЕТЫ: Вот основные приемы, чтобы минимизировать различия во внешнем виде программ для разных разрешений: — используйте при разработке Small Font для Windows; — установите свойства AutoSize = true. Паскарел Вячеслав ------------ Я думаю, это ошибка Delphi или компонентов. Помогает только отключение масштабирования: у формы в Object Inspector Scaled заменить на False Blare@rocketmail.com ------------ Используйте AutoSize = true и PixelsPerInch>=120 (120 — стандартное значение для Delphi). Это не всегда решает все проблемы но, как правило, сильно облегчает жизнь. Alexey A. Kutuzov ------------ К предыдущему ответу хочется добавить следующее: При построении программы делайте все Control-элементы внутри формы масштабируемыми. Т.е. используйте свойства выравнивания, либо прописывайте код в OnResize, который сохранит пропорции содержимого формы. Andrew V. Fionik Еще можно добавить: // фиксируется разрешение при котором ведется разработка приложения ScreenWidth : Integer = 800; ScreenHeight : Integer = 600; // а затем масштабируется в соответствии с текущим разрешением ScaleBy(Screen.Height, ScreenHeight); Alexandre Stepatchev Добавлю к предыдущим ответам : не используйте при разработке не TrueType шрифты, они меняют размер в зависимости от настроек "крупный/мелкий шрифт". Используйте Arial, Times New Roman, Courier new и т.д. Отключите свойство Scaled. ntcstr@orc.ru Какие дефайны использовать для определения версии Delphi/CPPB ?
{$IFDEF VER80} — D1 (Delphi 1.0) {$IFDEF VER90} — D2 {$IFDEF VER93} — B1 (Builder 1.0) {$IFDEF VER100} — D3 {$IFDEF VER110} — B3 {$IFDEF VER120} — D4Borland IDE Как включить окошко CPU Window?
Вставьте в registry строковый ключ HKCU\Software\Borland\Delphi\2.0\Debugging\EnableCPU=1 соответственно для Delphi 3 -- Delphi\3.0. Как установить компонент от Delphi 2 под Delphi 3? Delphi требуют PAS-файл.
Hикак. Ищите исходник или .DCU, скомпилированный для Delphi 3.Object Pascal Преобразование PChar в longint
Question: Many Windows functions claim to want PChar parameters in the documentation, but they are defined as requiring LongInts. Is this a bug? Answer: No, this is where "typecasting" is used. Typecasting allows you to fool the compiler into thinking that one type of variable is of another type for the ultimate in flexibility. The last parameter of the Windows API function SendMessage() is a good example. It is documented as requiring a long integer, but commonly requires a PChar for some messages (WM_WININICHANGE). Generally, the variable you are typecasting from must be the same size as the variable type you are casting it to. In the SendMessage example, you could typecast a PChar as a longint, since both occupy 4 bytes of memory: Example: var s : array[0..64] of char; begin StrCopy(S, 'windows'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); end; Pointers are the easiest to typecast, and are the most flexible since you can pass anything to the called procedure, and the most dangerous for the same reason. You can also use untyped variable parameters for convenience, although var parameters are really pointers behind the scenes. Example: type PBigArray = ^TBigArray; TBigArray = Array[0..65000] of char; procedure ZeroOutPointerVariable(P : pointer; size : integer); var i : integer; begin for i := 0 to size — 1 do PBigArray(p)^[i] := #0; end; procedure ZeroOutUntypedVariable(var v, size : integer); var i : integer; begin for i := 0 to size — 1 do TBigArray(v)[i] := #0; end; procedure TForm1.Button1Click(Sender: TObject); var s : string[255]; i : integer; l : longint; begin s := 'Hello'; i := 10; l := 2000; ZeroOutPointerVariable(@s, sizeof(s)); ZeroOutPointerVariable(@i, sizeof(i)); ZeroOutPointerVariable(@l, sizeof(l)); s := 'Hello'; i := 10; l := 2000; ZeroOutUntypedVariable(s, sizeof(s)); ZeroOutUntypedVariable(i, sizeof(i)); ZeroOutUntypedVariable(l, sizeof(l)); end; Различия в значении логического типа TRUE.
In Delphi 3, the value "True" for data types ByteBool, WordBool, and LongBool is now represented as -1 for compatibility with Microsoft Visual Basic. Note that many compilers represent "True" as either non-zero or a positive 1. When passing values to non Visual Basic applications, you should consider using the following technique to avoid incompatibilities: LongBool(Abs(True)); When accepting boolean values from any external source, you should always test against the value "False". The following technique should always work, since the value for false is always zero: if BoolValPassed <> False then DoSomething. Утечка памяти при поиске файлов( FindFirst, FindNext ).
Не забывайте вызывать SysUtils.FindClose(SearchRec); begin Result := SysUtils.FindFirst(Path, Attr, SearchRec); while Result = 0 do begin ProcessSearchRec(SearchRec); Result := SysUtils.FindNext(SearchRec); end; SysUtils.FindClose(SearchRec); end;OLE Как работать с файлами MS Word или таблицами Excel?
Воспользоваться функцией CreateOLEObject и работать с VBA или WordBasic. === Cut Пример by Sergey Arkhipov 2:5054/88.10 === Пример проверен только на Word 7.0 (рус) ! unit InWord; interface uses ... ComCtrls; // Delphi3 ... OLEAuto; // Delphi2 [skip] procedure TPrintForm.MPrintClick(Sender: TObject); var W: Variant; S: String; begin S:=VarToStr(Table1['Num']); //В D3 без промежуточной записи // в var у меня не пошло :( try // А вдруг где ошибка :) W:=CreateOleObject('Word.Basic'); // Создаем документ по шаблону MyWordDot // с указанием пути если он не в папке шаблонов Word W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0); // Отключение фоновой печати (на LJ5L без этого был пустой лист) W.ToolsOptionsPrint(Background:=0); // Переходим к закладке Word'a 'Num' W.EditGoto('Num'); W.Insert(S); //Сохранение W.FileSaveAs('C:\MayPath\Reports\MyReport') W.FilePrint(NumCopies:='2'); // Печать 2-х копий finally W.ToolsOptionsPrint(Background:=1); W:=UnAssigned; end; end; ..... === Cut Конец примера === === Cut Пример 2 === ... MyExcel:=CreateOleObject('Excel.Application'); MyExcel.visible:=true; MyExcel.WorkBooks.Add; MyExcel.Cells(1,1):='Администрация'; ... === Cut Конец примера === Пример запуска макроса в MS WinWord-е.
... vvWord:= CreateOleObject('Word.Application.8'); vvWord.Application.Visible:=true; vvWord.Documents.Open( TempFileName ); vvWord.ActiveDocument.SaveAs( FileName, 1 ); // as .DOC vvWord.Application.Run( 'Macros Name' ); ...API Управление аппаратной частью

Открытие и закрытие устройства CD ROM.
Most of you are probably familiar with the TMediaPlayer component. It's a nice multi-purpose component for multimedia, but it has one failing: its inability to close a CD-ROM drive tray if it's open. And unfortunately for us, there's no way to manipulate methods or properties of TMediaPlayer to enable this functionality. So what we have to do is use the Windows API; in particular, we'll be using the MMSystem.pas file. One thing to note: We can use Windows API function calls solely, but TMediaPlayer does some internal handling
that we don't need to worry about if we employ the component. So this example makes use of the TMediaPlayer. Just follow these steps: 1. Start a new project and drop a TMediaPlayer and a TButton on it. 2. Add a "MMSystem" declaration to the uses statement of your form. 3. Set AutoOpen to True on the TMediaPlayer. Set the DeviceType property to dtCDAudio. You might want to consider disabling the btEject option from EnabledButtons property since we'll be handling that functionality in code. 4. One thing I use this for is for data CD's in some applications, so I also set the Visible
property to False and just let my button do the opening and closing of the tray. 5. Finally, add the following code to the button's OnClick event: procedure TForm1.Button2Click(Sender: TObject); begin with MediaPlayer1 do if (MediaPlayer1.Mode = mpOpen) then mciSendCommand(MediaPlayer1.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0) else mciSendCommand(MediaPlayer1.DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0); end; Notice we use the function mciSendCommand. This is the "Swiss Army Knife" of the MMSystem unit. In Windows, everything's controlled by messages. With respect to device control,
mciSendCommand is very similar to a window's WndProc in that it acts as a message dipatcher. Just supply the device, the message type, message flags,
and message parameters, and you're on your way. For more detailed information, I suggest you look in the help file. -- By Brendan Delumpa Изменение громгости звука в Windows95
MMSYSTEM.PAS file in Delphi\Source\Rtl\Win has all the multimedia extension support in Windows. Переключение видео режимов.
unit VidMode; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls; type TForm1 = class(TForm) Edit1: TEdit; Label1: TLabel; Run: TButton; Test: TButton; Label2: TLabel; ComboBox1: TComboBox; procedure RunClick(Sender: TObject); procedure TestClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1 : TForm1; Modes : Array[0..255] of TDevMode; implementation {$R *.DFM} procedure TForm1.RunClick(Sender: TObject); var DC : THandle; // Bits : Integer; // HRes : Integer; // VRes : Integer; // DM : TDevMode; // ModeNum : LongInt; // Ok : Bool; I : Byte; begin // DC := Canvas.Handle; Bits := GetDeviceCaps(DC, BITSPIXEL); HRes := GetDeviceCaps(DC, HORZRES); VRes := GetDeviceCaps(DC, VERTRES); Edit1.Text := Format('%d x %d, %d bits',[HRes, VRes, Bits]); ModeNum := 0; EnumDisplaySettings(Nil, ModeNum, DM); Modes[ModeNum] := DM; // Add to array Ok := True; While Ok do Begin Inc(ModeNum); Ok := EnumDisplaySettings(Nil, ModeNum, DM); Modes[ModeNum] := DM; // Add to array End; // Now ModeNum contains # of supported modes For I := 0 to ModeNum-1 do Begin ComboBox1.Items.Add(Format('%d x %d, %d bits', [TDevMode(Modes[I]).dmPelsWidth, TDevMode(Modes[I]).dmPelsHeight, TDevMode(Modes[I]).dmBitsPerPel])); ComboBox1.ItemIndex := 0; End; end; procedure TForm1.TestClick(Sender: TObject); var NewMode : TDevMode; ChResult : LongInt; Msg : String; // Mode is TDevMode(Modes[ListBox1.ItemIndex]) begin NewMode := TDevMode(Modes[ComboBox1.ItemIndex]); NewMode.dmDisplayFrequency := 0; NewMode.dmDisplayFlags := DM_BITSPERPEL AND DM_PELSWIDTH AND DM_PELSHEIGHT AND DM_DISPLAYFLAGS; // In Win95 we should use CDS_UPDATEREGISTRY to change // number of bits per pixel and resolution. Also we need // to restart the computer to take effect of new settigs ChResult := ChangeDisplaySettings(NewMode, CDS_UPDATEREGISTRY); Msg := ''; Case ChResult of DISP_CHANGE_SUCCESSFUL : Msg := 'Success'; DISP_CHANGE_RESTART : Msg := 'Restart'; DISP_CHANGE_BADFLAGS : Msg := 'Bad Flags'; DISP_CHANGE_FAILED : Msg := 'Failed'; DISP_CHANGE_BADMODE : Msg := 'Bad Mode'; DISP_CHANGE_NOTUPDATED : Msg := 'Not updated'; End; ShowMessage(Msg); end; end. Получение списка логических устройств в W95 и их типов.
Воспользуйся ф-ями GetLogicalDrives и GetDriveType. Первая возвращает битовую маску 26-ти дисков, вторая — возвращает тип диска. Это может быть: DRIVE_UNKNOWN DRIVE_NO_ROOT_DIR DRIVE_REMOVABLE DRIVE_FIXED DRIVE_REMOTE DRIVE_CDROM DRIVE_RAMDISK Синтаксис: GetLogicalDrives: DWORD; GetDriveType( lpRootPathName: PChar; {Указатель на строку с корневым каталогом} ): UINT; Пример: W := GetLogicalDrivers; Root := '#:\' for i := 0 to 25 do begin Root[1] := Char(Ord('A')+i); if GetDriveType(Root) = DRIVE_CDROM then begin if (W and (1 shl i))>0 then Msg := Root+' is CD-ROM and It is inserted.' else Msg := Root+' is CD-ROM and It is not available.' ShowMessage(Msg); end; end; Да, посмотри на предмет корневых каталогов ф-ю GetLogicalDriveStrings. Как корректно проверить готовность дисковода?
You can use the Windows API function SetErrorMode() to suppress the Window's critical Error dialog. Example: function IsDriveReady(DriveLetter : char) : bool; var OldErrorMode : Word; OldDirectory : string; begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); {$I-} ChDir(DriveLetter + ':\'); {$I+} if IoResult <> 0 then Result := False else Result := True; ChDir(OldDirectory); SetErrorMode(OldErrorMode); end; procedure TForm1.Button1Click(Sender: TObject); begin if not IsDriveReady('A') then ShowMessage('Drive Not Ready') else ShowMessage('Drive is Ready'); end; Как определить тип устройства?
case GetDriveType('C:\') of 0 : ShowMessage('The drive type cannot be determined'); 1 : ShowMessage('The root directory does not exist'); DRIVE_REMOVABLE:ShowMessage('The disk can be removed'); DRIVE_FIXED : ShowMessage('The disk cannot be removed'); DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive'); DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive'); DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk'); end; Привязка к серийному номеру винта.
var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char; VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : Integer; begin GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH); Memo1.Lines.Add('VName = '+VolumeName); Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8)); Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength)); Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4)); Memo1.Lines.Add('FSName = '+FileSystemName); end; Минимальная инф-ия о состоянии модема.
var CommPort : string; hCommFile : THandle; ModemStat : DWord; begin CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile = INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Get the Modem Status} if GetCommModemStatus(hCommFile, ModemStat) <> false then begin if ModemStat and MS_CTS_ON <> 0 then ShowMessage('The CTS (clear-to-send) is on.'); if ModemStat and MS_DSR_ON <> 0 then ShowMessage('The DSR (data-set-ready) is on.'); if ModemStat and MS_RING_ON <> 0then ShowMessage('The ring indicator is on.'); if ModemStat and MS_RLSD_ON <> 0 then ShowMessage('The RLSD (receive-line-signal-detect) is on.'); end; {Close the comm port} CloseHandle(hCommFile); end; Как программно изменять громкость звука?
unit Volumes; interface uses Windows, Messages, Classes, ExtCtrls, ComCtrls, MMSystem; const CDVolume = 0; WaveVolume = 1; MidiVolume = 2; type TVolumeControl = class(TComponent) private FDevices : array[0..2] of Integer; FTrackBars : array[0..2] of TTrackBar; FTimer : TTimer; function GetInterval: Integer; procedure SetInterval(AInterval: Integer); function GetVolume(AIndex: Integer): Byte; procedure SetVolume(AIndex: Integer; aVolume: Byte); procedure InitVolume; procedure SetTrackBar(AIndex: Integer; ATrackBar: TTrackBar); { Private declarations } procedure Update(Sender: TObject); procedure Changed(Sender: TObject); protected { Protected declarations } procedure Notification(AComponent: TComponent; AOperation: TOperation); override; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; published { Published declarations } property Interval: Integer read GetInterval write SetInterval default 500; property CDVolume: Byte index 0 read GetVolume write SetVolume stored False; property CDTrackBar: TTrackBar index 0 read FTrackBars[0] write SetTrackBar; property WaveVolume: Byte index 1 read GetVolume write SetVolume stored False; property WaveTrackBar: TTrackBar index 1 read FTrackBars[1] write SetTrackBar; property MidiVolume: Byte index 2 read GetVolume write SetVolume stored False; property MidiTrackBar: TTrackBar index 2 read FTrackBars[2] write SetTrackBar; end; procedure Register; implementation procedure Register; begin RegisterComponents('Any', [TVolumeControl]); end; type TVolumeRec = record case Integer of 0: (LongVolume: Longint); 1: (LeftVolume, RightVolume : Word); end; function TVolumeControl.GetInterval: Integer; begin Result := FTimer.Interval; end; procedure TVolumeControl.SetInterval(AInterval: Integer); begin FTimer.Interval := AInterval; end; function TVolumeControl.GetVolume(AIndex: Integer): Byte; var Vol: TVolumeRec; begin Vol.LongVolume := 0; if FDevices[AIndex] <> -1 then case AIndex of 0: auxGetVolume(FDevices[AIndex], @Vol.LongVolume); 1: waveOutGetVolume(FDevices[AIndex], @Vol.LongVolume); 2: midiOutGetVolume(FDevices[AIndex], @Vol.LongVolume); end; Result := (Vol.LeftVolume + Vol.RightVolume) shr 9; end; procedure TVolumeControl.SetVolume(aIndex: Integer; aVolume: Byte); var Vol: TVolumeRec; begin if FDevices[AIndex] <> -1 then begin Vol.LeftVolume := aVolume shl 8; Vol.RightVolume := Vol.LeftVolume; case AIndex of 0: auxSetVolume(FDevices[AIndex], Vol.LongVolume); 1: waveOutSetVolume(FDevices[AIndex], Vol.LongVolume); 2: midiOutSetVolume(FDevices[AIndex], Vol.LongVolume); end; end; end; procedure TVolumeControl.SetTrackBar(AIndex: Integer; ATrackBar: TTrackBar); begin if ATrackBar <> FTrackBars[AIndex] then begin FTrackBars[AIndex] := ATrackBar; Update(Self); end; end; procedure TVolumeControl.Notification(AComponent: TComponent; AOperation: TOperation); var I: Integer; begin inherited Notification(AComponent, AOperation); if (AOperation = opRemove) then for I := 0 to 2 do if (AComponent = FTrackBars[I]) then FTrackBars[I] := Nil; end; procedure TVolumeControl.Update(Sender: TObject); var I: Integer; begin for I := 0 to 2 do if Assigned(FTrackBars[I]) then with FTrackBars[I] do begin Min := 0; Max := 255; if Orientation = trVertical then Position := 255 — GetVolume(I) else Position := GetVolume(I); OnChange := Self.Changed; end; end; constructor TVolumeControl.Create(AOwner: TComponent); begin inherited Create(AOwner); FTimer := TTimer.Create(Self); FTimer.OnTimer := Update; FTimer.Interval := 500; InitVolume; end; destructor TVolumeControl.Destroy; var I: Integer; begin FTimer.Free; for I := 0 to 2 do if Assigned(FTrackBars[I]) then FTrackBars[I].OnChange := Nil; inherited Destroy; end; procedure TVolumeControl.Changed(Sender: TObject); var I: Integer; begin for I := 0 to 2 do if Sender = FTrackBars[I] then with FTrackBars[I] do begin if Orientation = trVertical then SetVolume(I, 255 — Position) else SetVolume(I, Position); end; end; procedure TVolumeControl.InitVolume; var AuxCaps : TAuxCaps; WaveOutCaps : TWaveOutCaps; MidiOutCaps : TMidiOutCaps; I,J : Integer; begin FDevices[0] := -1; for I := 0 to auxGetNumDevs — 1 do begin auxGetDevCaps(I, @AuxCaps, SizeOf(AuxCaps)); if (AuxCaps.dwSupport and AUXCAPS_VOLUME) <> 0 then begin FTimer.Enabled := True; FDevices[0] := I; break; end; end; FDevices[1] := -1; for I := 0 to waveOutGetNumDevs — 1 do begin waveOutGetDevCaps(I, @WaveOutCaps, SizeOf(WaveOutCaps)); if (WaveOutCaps.dwSupport and WAVECAPS_VOLUME) <> 0 then begin FTimer.Enabled := True; FDevices[1] := I; break; end; end; FDevices[2] := -1; for I := 0 to midiOutGetNumDevs — 1 do begin MidiOutGetDevCaps(I, @MidiOutCaps, SizeOf(MidiOutCaps)); if (MidiOutCaps.dwSupport and MIDICAPS_VOLUME) <> 0 then begin FTimer.Enabled := True; FDevices[2] := I; break; end; end; end; end.Сообщения & события Как контролироавать число документов в очереди принтера?
... private procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); message WM_SPOOLERSTATUS; ... procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); begin Lable1.Caption := IntToStr(msg.JobsLeft) + ' Jobs currenly in spooler'; msg.Result := 0; end; Как послать самостийное сообщение всем главным окнам в Windows?
Пример: Var FM_FINDPHOTO: Integer; // Для использовать hwnd_Broadcast нужно сперва зарегистрировать уникальное // сообщение Initialization FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll'); // Чтобы поймать это сообщение в другом приложении (приемнике) нужно перекрыть DefaultHandler procedure TForm1.DefaultHandler(var Message); begin with TMessage(Message) do begin if Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM) else Inherited DefaultHandler(Message); end; end; // А тепрь можно SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0); Кстати, для посылки сообщения дочерним контролам некоего контрола можно использовать метод Broadcast. Andrey Burov (2:463/238.19) Как отследить изменение файловой системы и/или реестра ОС?
Отслеживание файловой системы через FindFirstFileNotification и прочие. Отслеживание реестра ОС — RegNotifyChangeKeyValue (только для NT). Alexey Mahotkin (2:5020/433) Обмен информацией между приложениями Win32 — Win16.
Пользуйтесь сообщением WM_COPYDATA. Для Win16 константа определена как $004A, в Win32 смотрите в WinAPI Help. #define WM_COPYDATA 0x004A /* * lParam of WM_COPYDATA message points to... */ typedef struct tagCOPYDATASTRUCT { DWORD dwData; DWORD cbData; PVOID lpData; } COPYDATASTRUCT, *PCOPYDATASTRUCT; Как пpинимать яpлыки пpи пеpетягивании их на контpол ?
TForm1 = class(TForm) ... private { Private declarations } procedure WMDropFiles(var M : TWMDropFiles); message WM_DROPFILES; ... end; var Form1: TForm1; implementation uses StrUtils, ShellAPI, ComObj, ShlObj, ActiveX;; procedure TForm1.FormCreate(Sender: TObject); begin ... DragAcceptFiles(Handle, True); ... end; procedure TForm1.FormDestroy(Sender: TObject); begin ... DragAcceptFiles(Handle, False); ... end; procedure TForm1.WMDropFiles(var M : TWMDropFiles); var hDrop: Cardinal; n: Integer; s: string; begin hDrop := M.Drop; n := DragQueryFile(hDrop, 0, nil, 0); SetLength(s, n); DragQueryFile(hDrop, 0, PChar(s), n + 1); DragFinish(hDrop); M.Result := 0; FileOpen(s); end; procedure TForm1.FileOpen(FileName: string); begin if CompareText(ExtractFileExt(FileName), '.lnk') = 0 then FileName := ResolveShortcut(Application.Handle, FileName); DocName := ExtractFileName(FileName); Caption := Application.Title + ' — ' + DocName; ... end; function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string; var obj: IUnknown; isl: IShellLink; ipf: IPersistFile; pfd: TWin32FindDataA; begin Result := ''; obj := CreateComObject(CLSID_ShellLink); isl := obj as IShellLink; ipf := obj as IPersistFile; ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ); with isl do begin Resolve(Wnd, SLR_ANY_MATCH); SetLength(Result, MAX_PATH); GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY); Result := PChar(Result); end; end; Как перехватить нажатие 'горячих клавиш' ОС?
... private procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY; ... var implementation const id_SnapShot = 101; procedure TForm1.WMHotKey (var Msg : TWMHotKey); begin if Msg.HotKey = id_SnapShot then ShowMessage('GotIt'); end; procedure TForm1.FormCreate(Sender: TObject); begin RegisterHotKey(Form1.Handle, id_SnapShot, 0, VK_SNAPSHOT); end; procedure TForm1.FormDestroy(Sender: TObject); begin UnRegisterHotKey (Form1.Handle, id_SnapShot); end;DLL Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
Вы должны определить в программе вызываемую снаружи функцию. Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь четыре аргумента. Первый — HWND окна, порождаемого rundll32 (можно использовать в качестве owner'а своих dialog box'ов), второй — HINSTANCE задачи, третий — остаток командной строки (LPCSTR, даже под NT), четвертый — не знаю ;). Hапример, === int __stdcall __declspec(dllexport) Test ( HWND hWnd, HINSTANCE hInstance, LPCSTR lpCmdLine, DWORD dummy ) { MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK); return 0; } === rundll32 test.dll,_Test@16 this is a command line === выдаст message box со строкой "this is a command line". Oleg Moroz (2:5020/701.22) Function Test( hWnd: Integer; hInstance: Integer; lpCmdLine: PChar; dummy: Longint ): Integer; StdCall; export; begin Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK); Result := 0; end; Akzhan Abdulin (2:5040/55) Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень забавную вещь. А именно -- пусть у нас есть исходник на Си пpимеpно такого вида: int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD dummy ) ...... int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD dummy ) ...... и .def-файл пpимеpно такого вида: EXPORTS RunDll RunDllA=RunDll RunDllW то rundll32 становится pазбоpчивой -- под HТ вызывает UNICODE-веpсию. Под 95, pазумеется, ANSI. Rulez. Alexey A Popoff pvax@glas.apc.org, posp@ccas.ru http://www.ccas.ru/~posp/popov/pvax.html (2:5020/487.26)Администрирование [Win32] Как проверить, имеем ли мы административные привилегии в системе?
// Routine: check if the user has administrator provileges // Was converted from C source by Akzhan Abdulin. Not properly tested. type PTOKEN_GROUPS = TOKEN_GROUPS^; function RunningAsAdministrator (): Boolean; var SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY; psidAdmin: PSID; ptg: PTOKEN_GROUPS = nil; htkThread: Integer; { HANDLE } cbTokenGroups: Longint; { DWORD } iGroup: Longint; { DWORD } bAdmin: Boolean; begin Result := false; if not OpenThreadToken(GetCurrentThread(), // get security token TOKEN_QUERY, FALSE, htkThread) then if GetLastError() = ERROR_NO_TOKEN then begin if not OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, htkThread) then Exit; end else Exit; if GetTokenInformation(htkThread, // get #of groups TokenGroups, nil, 0, cbTokenGroups) then Exit; if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then Exit; ptg := PTOKEN_GROUPS( getmem( cbTokenGroups ) ); if not Assigned(ptg) then Exit; if not GetTokenInformation(htkThread, // get groups TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then Exit; if not AllocateAndInitializeSid(SystemSidAuthority, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdmin) then Exit; iGroup := 0; while iGroup do // check administrator group begin if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then begin Result := TRUE; break; end; Inc( iGroup ); end; FreeSid(psidAdmin); end; Andy Nikolayev an@megatel.msk.su (2:5020/56) Как отследить изменение файловой системы и/или реестра ОС?
Отслеживание файловой системы через FindFirstFileNotification и прочие. Отслеживание реестра ОС — RegNotifyChangeKeyValue (только для NT). Alexey Mahotkin(2:5020/433)Ресурсы Как инсталлировать на время работы программы свои шрифты?
Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно след. образом: {$IFDEF WIN32} AddFontResource( PChar( my_font_PathName { AnsiString } ) ); {$ELSE} var ss : array [ 0..255 ] of Char; AddFontResource ( StrPCopy ( ss, my_font_PathName )); {$ENDIF} SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); Убрать его по окончании работы: {$IFDEF WIN32} RemoveFontResource ( PChar(my_font_PathName) ); {$ELSE} RemoveFontResource ( StrPCopy ( ss, my_font_PathName )); {$ENDIF} SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 ); При этом не надо никаких перезагрузок и прочего, после добавления фонт сразу можно использовать. my_font_PathName : string ( не string[nn] для D2+) — содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным, во всяком случае, я это не проверял. Andry Trushin (2:5020/474.7) Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?
1) Вынимаете pесуpсы из этого модуля. 2) Пеpеводите их на дpугой язык. (напpимеp pусский) 3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы вынули pесуpсы, напpимеp vcl30), в котоpый включаете _пеpеведенные_ pесуpсы: {$R vcl30rus.res} 4) Собиpаете все это. 5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System. Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в pегиональных установках стоит Russia — то тогда это все. Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы, то необходимо сделать следующее добавление в Registry: HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales "X:\MyProject\MyApp.exe" = "rus" Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться pусские pесуpсы. Дpугие пpиложения, напpимеp Delphi — это не затpонет. Таким обpазом можно заменять даже DFM-ки из пpоекта. Более подpобно об этом — см Help — Index — Localizing... Alexander Simonenko .alex@protec.kiev.ua.(2:463/249) Не горизонтальный шрифт.
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont; {-create a rotated font based on the font object F} var LF : TLogFont; begin FillChar(LF, SizeOf(LF), #0); with LF do begin lfHeight := F.Height; lfWidth := 0; lfEscapement := Angle*10; lfOrientation := 0; if fsBold in F.Style then lfWeight := FW_BOLD else lfWeight := FW_NORMAL; lfItalic := Byte(fsItalic in F.Style); lfUnderline := Byte(fsUnderline in F.Style); lfStrikeOut := Byte(fsStrikeOut in F.Style); lfCharSet := DEFAULT_CHARSET; StrPCopy(lfFaceName, F.Name); lfQuality := DEFAULT_QUALITY; {everything else as default} lfOutPrecision := OUT_DEFAULT_PRECIS; lfClipPrecision := CLIP_DEFAULT_PRECIS; case F.Pitch of fpVariable : lfPitchAndFamily := VARIABLE_PITCH; fpFixed : lfPitchAndFamily := FIXED_PITCH; else lfPitchAndFamily := DEFAULT_PITCH; end; end; Result := CreateFontIndirect(LF); end; ... {create the rotated font} if FontAngle <> 0 then Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle); ... Вращаются только векторные шрифты. Nikita Popov nix@tekton.dol.ru (2:5020/87.2) Выделение иконки из приложения.
How do I display the icon that is associated with a given file type? Answer: Use the ShellApi function ExtractAssociatedIcon() to retrieve the icon that is associated with the file. Example: uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); var Icon : hIcon; IconIndex : word; begin Icon := ExtractAssociatedIcon(HInstance, 'C:\SomePath\SomeFile.ext', IconIndex); DrawIcon(Form1.Canvas.Handle, 10, 10, Icon); end;Расширения оболочки W95 А как поместить свою иконку в область индикаторов на taskbar?
Компонент TrxTrayIcon из библиотеки rxLib. Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc.
unit BetterTreeView; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, CommCtrl; type TTVNewEditCancelEvent = procedure( Sender: TObject; Node: TTreeNode; var Delete: Boolean) of object; TBetterTreeView = class(TTreeView) protected FIsEditingNew: Boolean; FOnEditCancel: TTVChangedEvent; FOnNewEditCancel: TTVNewEditCancelEvent; procedure Edit(const Item: TTVItem); override; public function NewChildAndEdit(Node: TTreeNode; const S: String) : TTreeNode; published property IsEditingNew: Boolean read FIsEditingNew; property OnEditCancel: TTVChangedEvent read FOnEditCancel write FOnEditCancel; property OnNewEditCancel: TTVNewEditCancelEvent read FOnNewEditCancel write FOnNewEditCancel; end; implementation procedure TBetterTreeView.Edit(const Item: TTVItem); var Node: TTreeNode; Action: Boolean; begin with Item do begin { Get the node } if (state and TVIF_PARAM) <> 0 then Node := Pointer(lParam) else Node := Items.GetNode(hItem); if pszText = nil then begin if FIsEditingNew then begin Action := True; if Assigned(FOnNewEditCancel) then FOnNewEditCancel(Self, Node, Action); if Action then Node.Destroy end else if Assigned(FOnEditCancel) then FOnEditCancel(Self, Node); end else inherited; end; FIsEditingNew := False; end; function TBetterTreeView.NewChildAndEdit (Node: TTreeNode; const S: String): TTreeNode; begin SetFocus; Result := Items.AddChild(Node, S); FIsEditingNew := True; Node.Expand(False); Result.EditText; SetFocus; end; end. Том Сван "Секреты..." Как добавить горизонтальную полосу прокрутки в TListBox?
Компонент VCL TListBox автоматически реализует вертикальную полосу прокрутки. Полоска прокрутки появляется, когда окно списка слишком мало для показа всех элементов списка. Однако окно списка не показывает горизонтальной полосы прокрутки, когда какие-либо элементы списка имеют большую ширину, чем само окно списка. Конечно, есть возможность добавить горизонтальную полосу прокрутки. Добавьте следующий код в обработчик события OnCreate Вашей формы: procedure TForm1.FormCreate(Sender: TObject); var i, MaxWidth: integer; begin MaxWidth := 0; for i := 0 to ListBox1.Items.Count — 1 do if MaxWidth then MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]); SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0); end; Этот код находит ширину, в пикселах, самой длинной строки в окне списка. Затем он использует сообщение LB_SETHORIZONTALEXTENT для установки горизонтальной прокручиваемой ширины, в пикселах, для окна списка. Два дополнительных пиксела добавлены к MaxWidth, чтобы сдвинуть оконечные символы от правой границы окна списка. Как создавать ярлыки на рабочем столе?
function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string): IPersistFile; var MyObject : IUnknown; MySLink : IShellLink; MyPFile : IPersistFile; WideFile : WideString; begin MyObject := CreateComObject(CLSID_ShellLink); MySLink := MyObject as IShellLink; MyPFile := MyObject as IPersistFile; with MySLink do begin SetPath(PChar(CmdLine)); SetArguments(PChar(Args)); SetWorkingDirectory(PChar(WorkDir)); end; WideFile := LinkFile; MyPFile.Save(PWChar(WideFile), False); Result := MyPFile; end; procedure CreateShortcuts; var Directory, ExecDir: String; MyReg: TRegIniFile; begin MyReg := TRegIniFile.Create( 'Software\MicroSoft\Windows\CurrentVersion\Explorer'); ExecDir := ExtractFilePath(ParamStr(0)); Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' + ProgramMenu; CreateDir(Directory); MyReg.Free; CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir, Directory + '\Demonstration.lnk'); CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir, Directory + '\Installation notes.lnk'); CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir, Directory + '\Install Intel Video Interactive.lnk'); end; Roman Ryltsov. ryltsov@geocities.com. ryltsov@kharkov.com. http://surf.to/ryltsov N.BВообще правильнее в процедуре CreateShortcuts пользовать Win32API::GetSpecialFolderLocation с нужным параметром (CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае "Рабочего стола"). Akzhan Abdulin (2:5040/55) Как получить имя папки pабочего стола?
==== id:ishellfolder; pi:pitemidlist; lpname:tstrret; [...] shgetspecialfolderlocation(0,CSIDL_PROGRAMS,pi) shgetdesktopfolder(id) id.getdisplaynameof(pi,0,lpname) ==== Denis Tanayev denis@demo.ru Хэндл рабочего стола для манипуляций с иконками рабочего стола?
Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять хэндл этого органа управления. Пример: function GetDesktopListViewHandle: THandle; var S: String; begin Result := FindWindow('ProgMan', nil); Result := GetWindow(Result, GW_CHILD); Result := GetWindow(Result, GW_CHILD); SetLength(S, 40); GetClassName(Result, PChar(S), 39); if PChar(S) <> 'SysListView32' then Result := 0; end; После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32. К примеру, следующая строка кода: SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 ); разместит иконки рабочего стола по левой стороне рабочего стола Windows. (Borland FAQ N687, переведен Акжаном Абдулиным) Очистка папки 'Документы'.
// // Clear contents of Documents menu // procedure TForm1.Button2Click(Sender: TObject); var Result : Integer; begin Result := Application.MessageBox ('Do you want to '+ #13#10+'clear Documents folder?', 'Warning!', MB_ICONSTOP OR MB_OKCANCEL); Case Result of IDOK : SHAddToRecentDocs(SHARD_PATH, Nil); IDCANCEL : ; End; end; Получение информыции о ярлыках.
{ Can't use Standard OpenDialog since it really opens .lnk file and returns the command string, associated with link. } unit SLI_Unit; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, OLE2, ShlObj, ComCtrls, Menus; type TForm1 = class(TForm) Edit0: TEdit; Button1: TButton; Panel1: TPanel; Label1: TLabel; Label2: TLabel; Label3: TLabel; Edit2: TEdit; Edit3: TEdit; Edit4: TEdit; Label7: TLabel; Edit1: TEdit; HotKey1: THotKey; procedure Button1Click(Sender: TObject); procedure ShowLinkInfo; private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin ShowLinkInfo; end; procedure TForm1.ShowLinkInfo; Var Desc : Array[0..MAX_PATH] of Char; SL : IShellLink; PF : IPersistFile; HRES : HRESULT; FD : TWin32FindData; begin CoInitialize(Nil); HRes := COCreateInstance(CLSID_ShellLink, Nil, CLSCTX_INPROC_SERVER, IID_IShellLink, SL); If Succeeded(HRes) Then Begin HRes := SL.QueryInterface(IID_IPersistFile, PF); If Succeeded(HRes) Then Begin Edit0.Text := 'D:\LINKDEMO.LNK'; PF.Load('D:\LINKDEMO.LNK', STGM_READ); SL.Resolve(Handle, SLR_ANY_MATCH); SL.GetPath(Desc, MAX_PATH, FD, SLGP_UNCPRIORITY); Edit1.Text := StrPas(Desc); SL.GetDescription(Desc, MAX_PATH); Edit2.Text := StrPas(Desc); SL.GetWorkingDirectory(Desc, MAX_PATH); Edit3.Text := StrPas(Desc); SL.GetArguments(Desc, MAX_PATH); Edit4.Text := StrPas(Desc); PF.Release; SL.Release; End; End; end; end. Как спрятать панель задач в Windows?
HWND hwndTaskbar; hwndTaskbar = FindWindow ("Shell_TrayWnd", NULL); SetWindowPos (hwndTaskbar, 0, 0, 0, 0, 0, SWP_HIDEWINDOW); // Hide taskbar //SetWindowPos (hwndTaskbar, 0, 0, 0, 0, 0, SWP_SHOWWINDOW);// Show it again Как очистить все файлы в меню Документы?
#include SHAddToRecentDocs (0, 0); ps: Чтобы добавить файлы в меню Документы см. WinAPI help ф-ии SHAddToRecentDocs (). ---------------- PASCAL: uses ShlOBJ; procedure TForm1.Button1Click(Sender: TObject); begin SHAddToRecentDocs(SHARD_PATH, nil); end; Удаление файлов в корзину
Answer: Use the ShellAPI function SHFileOperation().uses ShellAPI; procedure SendToRecycleBin(FileName: string); var SHF: TSHFileOpStruct; begin with SHF do begin Wnd := Application.Handle; wFunc := FO_DELETE; pFrom := PChar(FileName); fFlags := FOF_SILENT or FOF_ALLOWUNDO; end; SHFileOperation(SHF); end; procedure TForm1.Button1Click(Sender: TObject); begin SendToRecycleBin('c:\DownLoad\Test.gif'); end;Трюки Как эмулировать нажатие CTRL+ESC для показа стартового меню?
HWND hwndShell; hwndShell = FindWindow ("Progman", NULL); //hwndShell = FindWindow ("Shell_TrayWnd", NULL); // То же самое SendMessage (hwndShell, WM_SYSCOMMAND, SC_TASKLIST, 0); Как перезагрузить Explorer?
HWND hwndShell; hwndShell = FindWindow ("Progman", NULL); PostMessage (hwndShell, WM_QUIT, 0, 0L); ShellExecute (0, "open", "Explorer", NULL, NULL, SW_SHOWNORMAL); Как удалить кнопку 'Пуск' из панели задач (taskbar)?
HWND hwndTaskbar, hwndButton; hwndTaskbar= FindWindow ("Shell_TrayWnd", NULL); // Taskbar hwndButton = FindWindowEx (hwndTaskbar, 0, "Button", NULL); // Button SendMessage (hwndButton, WM_CLOSE, 0, 0); Как вставить в StatusPanel свои компоненты, например ProgressBar?
pgProgress положить на форму как Visible := false; StatusPanel надо OwnerDraw сделать и pефpешить, если Position меняется. >== Режем pаз ==<procedure TMainForm.stStatusBarDrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin if Panel.Index = pnProgress then begin pgProgress.BoundsRect := Rect; pgProgress.PaintTo(stStatusBar.Canvas.Handle, Rect.Left, Rect.Top); end; end; >== Режем два ==Как консольное приложение может узнать что Винды завершаются?
Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так: BOOL Ctrl_Handler( DWORD Ctrl ) { if( (Ctrl == CTRL_SHUTDOWN_EVENT) || (Ctrl == CTRL_LOGOFF_EVENT) ) { // Вау! Юзер обламывает! } else { } return TRUE; } А где-то в программе: SetConsoleCtrlHandler( Ctrl_Handler, TRUE ); Таких обработчиков можно навесить кучу. Если при обработке какого-то из сообщений обработчик возвращет FALSE, то вызывается следующий обработчик. Alexander V. Naumochkin (2:5020/59) Как сделать так, чтобы запущенная программа не была видна на панели задач?
[...] procedure TForm1.FormCreate(Sender: TObject); begin Application.OnMinimize := ApplicationMinimize; Application.OnRestore := ApplicationRestore; ShowWindow(Application.Handle, SW_HIDE); end; procedure TForm1.ApplicationMinimize(Sender : TObject); begin ShowWindow(Application.Handle, SW_HIDE); end; procedure TForm1.ApplicationRestore(Sender : TObject); begin ShowWindow(Application.Handle, SW_HIDE); end; --- Для воостановления : Application.Restore; Application.BringToFront; --- ( ! ) Обратите внимание на то, что выводимые скрытой таким образом программой диалоговые окна не видны,
что может привести к проблемам
в случае, если вы забыли воостановить окно перед выводом диалога. Как запрограммировать непрямоугольную форму?
SetWindowRgn(); ( Win32). [--cut--] var rgn:HRGN; [...] procedure TForm1.FormCreate(Sender: TObject); begin rgn := CreateEllipticRgn(0, 0, Width, Height); SetWindowRgn(Handle, rgn, True); end; procedure TForm1.FormDestroy(Sender: TObject); begin DeleteObject(rgn); end; [--cut--] Есть компонент TFormShaper, free for noncommercial use: http://www.wirtschaft.tu-ilmenau.de/~aeg/ Как получить иконку и имя Рабочего Стола?
SHGetSpecialFolderLocation Как изменить внешний вид хинтов (всплывающих подсказок)?
1. Создаем свой класс — потомок от THintWindow type TCustomHint = class (THintWindow) public constructor Create(AOwner: TComponent); override; end; Пpимечание 1. Этот способ не позволит изменить цвет шpифта — для этого пpидется пеpекpывать метод Paint; Пpимечание 2. Если пеpекpыть CreateParams, то можно, напpимеp, наpисовать Hint в фоpме облачка. Пpимечание 3. Для изменения цвета фона F1 TApplication.OnShowHint, HintInfo. 2. Меняем фонт: constructor TCustomHint.Create(AOwner: TComponent); begin inherited Create(AOwner); with Canvas.Font do // Именно так, а не пpосто Font! begin Name := 'Times New Roman Cyr'; Style := [fsBold, fsItalic]; Size := 40; end; end; 3. Устанавливаем новый хинт procedure TForm1.FormCreate(Sender: TObject); // Это может быть любой begin // обpаботчик HintWindowClass := TMyHint; // Устанавливаем глобальную пеpеменную Application.ShowHint := false; // Application.FHintWindow.Free Application.ShowHint := true; // Application.FHintWindow.Create end; Литеpатуpа: 1. <...>\Source\VCL\Forms.pas (TApplication). 2. <...>\Source\VCL\Controls.pas (THintWindow). 3. Delphi Help (OnShowHint, THintInfo). Dmitry Medved (2:464/58.7) Отключение CTRL-ALT-DEL
Бывают ситуации, когда вашей программе понадобится отключить реакцию на клавиши Ctrl-Alt-Del
(например, если вы не хотите, чтобы ее выгрузили из памяти).
Это можно сделать при помощи функции API SystemParametersInfo, которая позволяет узнать,
либо установить параметры операционной системы, такие как установки клавиатуры, дисплея, звука и т.д.
Она используется в Панели Управления. Синтакс функции следующий: BOOL SystemParametersInfo( UINT uiAction, // параметр, который нужно узнать или установить UINT uiParam, // зависит от действия PVOID pvParam, // зависит от действия UINT fWinIni // флаг обновления информации о пользователе (user profile) ); Значение каждого параметра объясняется в Win32 Developer's Reference. Теперь, чтобы сделать то, что мы хотим, вызываем следующую прцедуру: procedure DisableCtrlAltDel; var i : integer; begin i := 0; SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @i, 0); end. Аналогично можно отключить Alt-Tab. Для этого нужно задать SPI_SETFASTTASKSWITCH в качестве первого параметра функции. Как создать приложение чтобы его не было видно в tasklist'е при нажатии CTRL+ALT+DEL?
#include "process.h" RegisterServiceProcess (NULL, RSP_SIMPLE_SERVICE); ps: RegisterServiceProcess не определена в WinAPI. См. файл process.h. Удаление запущенного процесса.
Under Win32, unless you are running from a removable drive, you cannot delete a running executable. You can have Windows delete the executable the next time Windows is ran by adding an entry to the RunOnce key in the Windows registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce You can name the key anything you like, and specify a command line to another executable or to a dos command passed to command.com. Example: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; with reg do begin RootKey := HKEY_LOCAL_MACHINE; LazyWrite := false; OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false); WriteString('Delete Me!','command.com /c del FILENAME.EXT'); CloseKey; free; end; end;Работа с файлами Как отловить события создания или удаления файлов другими программами?
(Win32:) FindFirstChangeNotification/FindNextChangeNotification/FindCloseChangeNotification (Win16:) FileCDR, но она плохо документирована. [Win32] Как удалить файл в корзину (Recycle Bin)?
program del; uses ShellApi; //function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall; Var T:TSHFileOpStruct; P:String; begin P:='C:\Windows\System\EL_CONTROL.CPL'; With T do Begin Wnd:=0; wFunc:=FO_DELETE; pFrom:=Pchar(P); fFlags:=FOF_ALLOWUNDO End; SHFileOperation(T); End. Ed Lagerburg lagerbrg@euronet.nl Диалог выбора директории.
функция Shell32.dll SHBrowseForFolder. --- var Form1 : TForm1; Shell : IShellForlder; HRES : HResult; procedure CallBack(Wnd : HWnd; uMsg : Uint; lParam, lpData : LPARAM); stdcall; var S : String; begin S := 'Выберите папку для установки программы'; SendMessage(Wnd, BFFM_SetStatusText, 0, LongInt(@S[1])); end; procedure TForm1.Button1Click(Sender : TObject); var InfoType : Byte; BI : TBrowseInfo; S : PChar; Image : Integer; PIDL : PItemIDList; Path : array[0..MAX_PATH — 1] of WideChar; ResPIDL : PItemIDList; begin SHGetSpecialFolderLocation(Handle, CSIDL_PROGRAMS, PIDL); S := StrAlloc(128); with BI do begin hWndOwner := Form1.Handle; pszDisplayName := S; lpszTitle := 'Поиск Папки'; ulFlags := BIF_StatusText; pidlRoot := PIDL; lpfn := @CallBack; iImage := Image; end; ResPIDL := SHBrowseForFolder(BI); SHGetPathFormIDList(ResPIDL, @Path[0]); Edit1.Text := StrToPas(@PAth[0]); StrDispose(S); end; Вообщем вставляешь этот код куда надо, и все будет работать без ошибок... K.Grudnev@tnet.sochi.ru Копирование файлов средствами Windows.
procedure TForm1.Button1Click(Sender: TObject); var Fo : TSHFileOpStruct; buffer : array[0..4096] of char; p : pchar; begin FillChar(Buffer, sizeof(Buffer), #0); p := @buffer; p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1; StrECopy(p, 'C:\DownLoad\4.ZIP'); FillChar(Fo, sizeof(Fo), #0); Fo.Wnd := Handle; Fo.wFunc := FO_COPY; Fo.pFrom := @Buffer; Fo.pTo := 'D:\'; Fo.fFlags := 0; if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then ShowMessage('Cancelled') end;Мышь,клавиатура и таймер Как ограничить перемещение курсора мыши какой-либо областью экрана?
ClipCursor() Как переключать раскладку клавиатуры из своей программы?
ActivateKeyboardLayout. Как перехватывать клавиши, нажатые в окне другой программы? И любые события, поступающие другим программам?
SetWindowsHookEx(). Как отчитывать промежутки времени с точностью, большей чем 60 мсек?
Для начала описываешь процедуру, которая будет вызываться по сообщению от таймера : procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD) stdcall; begin // // Тело процедуры. end; создаешь Таймер и вешаешь на него созданную процедуру uTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC); Hу и в конце убиваешь таймер timeKillEvent(uTimerID); И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек. Leonid Tserling tlv@f3334.dd.vaz.tlt.ruПроцессы Как мне запустить какую-нибудь программу?
WinExec() или ShellExecute. У второй больше возможностей. А как подождать, пока запущенная мной программа не отработает?
CreateProcess() в параметре process info возвращает handle запущенного процесса. Вот и делаешь WaitForSingleObject(pi.hProcess, INFINITE); ...или... === Cut === handle := WinExec(...); if handle >= 32 then while GetModuleUsage(handle) > 0 do Delay( nn ); else raise .... === Cut === ...или... ... используйте GetProcessTimes(), параметр lpExitTime. Принудительное завершение процесса.
(Win32) TerminateProcess. (Win16) Handle:=Winexec(App, 0); PostMessage(Handle, WM_QUIT, 0, 0); Как сделать так, чтобы программу можно было запустить только в одном экземпляре?
- Воспользуйтесь функцией ActivatePrevInstance из библиотеки rxLib. Для завершения
второго экземпляра, попытавшегося запуститься, используйте Application.Terminate; -or- X:\DELPHI2\DEMOS\IPCDEMOS\ipcthrd.pas, функция IsMonitorRunning(). -or- CreateSemaphore(nil,0,1,'MySemaphoreName'); [Win32] Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?
Это возможно с использованием вспомогательных инфоpмационных функций (tool help functions). Для получения списка пpоцессов надо делать следующее: 1. Cпеpва вызывается фукция hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0) // — получение снимка состояния системы 2. Process32First() — получене инфоpмации о пеpвом пpоцессе в списке 3. Далее в цикле Process32Next() — получение инфоpмации о следующем пpоцессе в списке Dima Bogachev (2:5020/1056.18) Пример: >== Режем pаз ==<unit KernlUtl; interface uses TlHelp32, Windows, Classes, Sysutils; procedure GetProcessList(List: TStrings); procedure GetModuleList(List: TStrings); function GetProcessHandle(ProcessID: DWORD): THandle; procedure GetParentProcessInfo(var ID: DWORD; var Path: String); const PROCESS_TERMINATE = $0001; PROCESS_CREATE_THREAD = $0002; PROCESS_VM_OPERATION = $0008; PROCESS_VM_READ = $0010; PROCESS_VM_WRITE = $0020; PROCESS_DUP_HANDLE = $0040; PROCESS_CREATE_PROCESS = $0080; PROCESS_SET_QUOTA = $0100; PROCESS_SET_INFORMATION = $0200; PROCESS_QUERY_INFORMATION = $0400; PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF; implementation procedure GetProcessList(List: TStrings); var I: Integer; hSnapshoot: THandle; pe32: TProcessEntry32; begin List.Clear; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (hSnapshoot = -1) then Exit; pe32.dwSize := SizeOf(TProcessEntry32); if (Process32First(hSnapshoot, pe32)) then repeat I := List.Add(Format('%x, %x: %s', [pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile])); List.Objects[I] := Pointer(pe32.th32ProcessID); until not Process32Next(hSnapshoot, pe32); CloseHandle (hSnapshoot); end; procedure GetModuleList(List: TStrings); var I: Integer; hSnapshoot: THandle; me32: TModuleEntry32; begin List.Clear; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0); if (hSnapshoot = -1) then Exit; me32.dwSize := SizeOf(TModuleEntry32); if (Module32First(hSnapshoot, me32)) then repeat I := List.Add(me32.szModule); List.Objects[I] := Pointer(me32.th32ModuleID); until not Module32Next(hSnapshoot, me32); CloseHandle (hSnapshoot); end; procedure GetParentProcessInfo(var ID: DWORD; var Path: String); var ProcessID: DWORD; hSnapshoot: THandle; pe32: TProcessEntry32; begin ProcessID := GetCurrentProcessID; ID := -1; Path := ''; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (hSnapshoot = -1) then Exit; pe32.dwSize := SizeOf(TProcessEntry32); if (Process32First(hSnapshoot, pe32)) then repeat if pe32.th32ProcessID = ProcessID then begin ID := pe32.th32ParentProcessID; Break; end; until not Process32Next(hSnapshoot, pe32); if ID <> -1 then begin if (Process32First(hSnapshoot, pe32)) then repeat if pe32.th32ProcessID = ID then begin Path := pe32.szExeFile; Break; end; until not Process32Next(hSnapshoot, pe32); end; CloseHandle (hSnapshoot); end; function GetProcessHandle(ProcessID: DWORD): THandle; begin Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID); end; end. >== Режем два == #include typedef long (*NtQSI)(LONG, PVOID,LONG, LONG); struct ThreadInfo { FILETIME ftCreationTime; DWORD dwUnknown1; DWORD dwStartAddress; DWORD dwOwningPID; DWORD dwThreadID; DWORD dwCurrentPriority; DWORD dwBasePriority; DWORD dwContextSwitches; DWORD dwThreadState; DWORD dwUnknown2; DWORD dwUnknown3; DWORD dwUnknown4; DWORD dwUnknown5; DWORD dwUnknown6; DWORD dwUnknown7; }; struct ProcessInfo { DWORD dwOffset; // an ofset to the next Process structure DWORD dwThreadCount; DWORD dwUnkown1[6]; FILETIME ftCreationTime; DWORD dwUnkown2; DWORD dwUnkown3; DWORD dwUnkown4; DWORD dwUnkown5; DWORD dwUnkown6; WCHAR* pszProcessName; DWORD dwBasePriority; DWORD dwProcessID; DWORD dwParentProcessID; DWORD dwHandleCount; DWORD dwUnkown7; DWORD dwUnkown8; DWORD dwVirtualBytesPeak; DWORD dwVirtualBytes; DWORD dwPageFaults; DWORD dwWorkingSetPeak; DWORD dwWorkingSet; DWORD dwUnkown9; DWORD dwPagedPool; // kbytes DWORD dwUnkown10; DWORD dwNonPagedPool; // kbytes DWORD dwPageFileBytesPeak; DWORD dwPageFileBytes; DWORD dwPrivateBytes; DWORD dwUnkown11; DWORD dwUnkown12; DWORD dwUnkown13; DWORD dwUnkown14; struct ThreadInfo ati[1]; }; NtQSI ntqsi; HANDLE h; int i; long j; long tt; char *vt; // UNICODE struct ThreadInfo *tinfo, *tinf2; struct ProcessInfo *pinfo; char buf[20480]; void main() { h=LoadLibrary("NTDLL.DLL"); ntqsi = (NtQSI)GetProcAddress(h,"NtQuerySystemInformation"); j = (*ntqsi)(5,buf,20480,0); pinfo = buf; for(;;){ vt = pinfo->pszProcessName; printf("%4lX|%13s|%8ld|%7lX|%7ld", pinfo->dwProcessID,vt, pinfo->dwThreadCount,pinfo->dwParentProcessID, pinfo->dwOffset); printf("|%4ld\n",pinfo->dwBasePriority); printf("\t| ID|Owner|State|Priority|Base Priority\n"); tinfo = &pinfo->ati[0]; for(i=0;idwThreadCount;++i){ tinf2 = &tinfo[i]; printf("\t|%4lX|%5lX|%5lX|%8s|%8s\n", tinf2->dwThreadID, tinf2->dwOwningPID, tinf2->dwThreadState, tinf2->dwCurrentPriority, tinf2->dwBasePriority); } if(pinfo->dwOffset==0) break; pinfo = (struct ProcessInfo*)((char *)pinfo + pinfo->dwOffset); } } Viktor Krapivin (2:450/102.13) ------------- Пример2: unit ML_Unit; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, TlHelp32; type TForm1 = class(TForm) ListBox1: TListBox; Button1: TButton; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1 : TForm1; implementation var Form1 : TForm1; implementation {$R *.DFM} procedure Module32List(S : TStrings); var Module32 : TModuleEntry32; SS : THandle; Next : Bool; begin // Module32.dwSize := SizeOf(TModuleEntry32); // SS := CreateToolHelp32Snapshot(TH32CS_SNAPMODULE, 0); // If Module32First(SS, Module32) then begin // S.Add(Module32.szExePath); Repeat // Next := Module32Next(SS, Module32); // If Next Then S.Add(Module32.szExePath); Until Not Next; end; CloseHandle(SS); end; procedure TForm1.FormCreate(Sender: TObject); begin // Module32List(ListBox1.Items); end; procedure TForm1.Button1Click(Sender: TObject); begin // ListBox1.Items.Clear; // Module32List(ListBox1.Items); end; end. Как запретить переключение на другие задачи?
=== Cut === Выключить Ctl-alt-del bool old; SystemParametersInfo (SPI_SCREENSAVERRUNNING,1,&old,0) Включить обратно SystemparametersInfo (SPI_ScreenSaverrunning,0,&old,0) === Cut === Konstantin Okolelyh (2:5025/77.23) Организация ожидания.
Пример #1. Загрузка процессора программой увеличивается приблизительно на 1-3% по сравнению с пустой системой.
Достоинства этого метода состоят в том, что благодаря использованию MsgWaitForMultipleObjects пустое ожидание может быть прервано, например, приходом сообщения (в отличие от SleepEx).
При весьма небольшом увеличении загрузки процессора dwSlice может быть уменьшено до 1. #include #include HANDLE hThread; VOID ReleaseTimeSlice( DWORD dwSlice ) { MsgWaitForMultipleObjects( 1, &hThread, FALSE, dwSlice, QS_ALLINPUT ); } VOID main( VOID ) { hThread = GetCurrentThread(); puts( "Press any key to terminate." ); while ( !_kbhit() ) { ReleaseTimeSlice( 10 ); } getch(); } Пример #2. Загрузка процессора программой увеличивается приблизительно на 3-4% по сравнению с пустой системой.
Hесомненное достоинство метода -ссылка на него в документации по Visual C++ и Win32 SDK. Однако, этот метод имеет ограничение, так как time slice отдается только нити с _таким же_ приоритетом. #include #include VOID main( VOID ) { puts( "Press any key to terminate." ); while ( !_kbhit() ) { Sleep( 10 ); } getch(); } Serge Popov Как выполнить перезагрузку (reboot) в Windows NT?
Даже если ты работаешь под Администратором, твоя программка должна запросить дополнительные привилегии. Вот как это делается (Си): void Reboot (void) { HANDLE hToken; TOKEN_PRIVILEGES* NewState; OSVERSIONINFO OSVersionInfo; OSVersionInfo.dwOSVersionInfoSize = sizeof (OSVERSIONINFO); GetVersionEx (&OSVersionInfo); if (OSVersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT) { OpenProcessToken (GetCurrentProcess (), TOKEN_ADJUST_PRIVILEGES, &hToken); NewState = (TOKEN_PRIVILEGES*) malloc (sizeof (TOKEN_PRIVILEGES) + sizeof (LUID_AND_ATTRIBUTES)); NewState->PrivilegeCount = 1; LookupPrivilegeValue (NULL, SE_SHUTDOWN_NAME, &NewState->Privileges[0].Luid); NewState->Privileges[0].Attributes = SE_PRIVILEGE_ENABLED; AdjustTokenPrivileges (hToken, FALSE, NewState, NULL, NULL, NULL); free (NewState); CloseHandle (hToken); } ExitWindowsEx (EWX_REBOOT, 0); } Andy Nikolayev an@megatel.ru (2:5020/56) Как спрятать окно приложения из списка задач и из таскбара?
Для NT — всё как обычно, для 95 так: #define RSP_SIMPLE_SERVICE 0x00000001 #define RSP_UNREGISTER_SERVICE 0x00000000 void SimpleServiceRegister (void) { HINSTANCE hInstKernel; DWORD (__stdcall *pRegisterServiceProcess) (DWORD, DWORD); hInstKernel = LoadLibrary ("KERNEL32.DLL"); if (hInstKernel) { pRegisterServiceProcess = (DWORD (__stdcall *) (DWORD, DWORD)) GetProcAddress (hInstKernel, "RegisterServiceProcess"); if (pRegisterServiceProcess) { pRegisterServiceProcess (NULL, RSP_SIMPLE_SERVICE); } FreeLibrary (hInstKernel); } } Andy Nikolayev an@megatel.ru (2:5020/56) Получение хэндла главного окна процесса по хэндлу процесса.
HWND WindWindowByProcessId(DWORD ProcessId) { HWND hwndCurrent=GetDesktopWindow(); do { DWORD WindowProcessId=0; GetWindowThreadProcessId(hwndCurrent, &WindowProcessId); if(WindowProcessId==ProcessId) return hwndCurrent; } while(GetWindow(hwndCurrent, GW_HWNDPREV)); return NULL; } ID пpоцесса ты смощешь найти там же где беpешь его хэндл — в стpуктуpе PROCESS_INFORMATION. Сам понимаешь, что это пpимеp. И у него есть масса непpиятных моментов: 1) Если у пpиложения будет откpыто несколько окон — веpнется пеpвое встpеченное на доpоге. 2) Если пpиложение написано на Delphi/C++Builder, то этим окном может запpосто оказаться TDataModule,
и что ты будешь делать с его хэндлом — непонятно. Alexander Simonenko 2:463/249fidonet Как получить результат работы консольной программы ?
Hужно использовать пайпы (CreatePipe), и работать с ними как с обычным файлом. const H_IN_READ = 1; H_IN_WRITE = 2; H_OUT_READ = 3; H_OUT_WRITE = 4; H_ERR_READ = 5; H_ERR_WRITE = 6; type TPipeHandles = array [1..6] of THandle; var hPipes: TPipeHandles; ProcessInfo: TProcessInformation; (************************************************************** CREATE HIDDEN CONSOLE PROCESS **************************************************************) function CreateHiddenConsoleProcess(szChildName: string; ProcPriority: DWORD; ThreadPriority: integer): Boolean; label error; var fCreated: Boolean; si: TStartupInfo; sa: TSecurityAttributes; begin // Initialize handles hPipes[ H_IN_READ ] := INVALID_HANDLE_VALUE; hPipes[ H_IN_WRITE ] := INVALID_HANDLE_VALUE; hPipes[ H_OUT_READ ] := INVALID_HANDLE_VALUE; hPipes[ H_OUT_WRITE ] := INVALID_HANDLE_VALUE; hPipes[ H_ERR_READ ] := INVALID_HANDLE_VALUE; hPipes[ H_ERR_WRITE ] := INVALID_HANDLE_VALUE; ProcessInfo.hProcess := INVALID_HANDLE_VALUE; ProcessInfo.hThread := INVALID_HANDLE_VALUE; // Create pipes // initialize security attributes for handle inheritance (for WinNT) sa.nLength := sizeof(sa); sa.bInheritHandle := TRUE; sa.lpSecurityDescriptor := nil; // create STDIN pipe if not CreatePipe( hPipes[ H_IN_READ ], hPipes[ H_IN_WRITE ], @sa, 0 ) then goto error; // create STDOUT pipe if not CreatePipe( hPipes[ H_OUT_READ ], hPipes[ H_OUT_WRITE ], @sa, 0 ) then goto error; // create STDERR pipe if not CreatePipe( hPipes[ H_ERR_READ ], hPipes[ H_ERR_WRITE ], @sa, 0 ) then goto error; // process startup information ZeroMemory(Pointer(@si), sizeof(si)); si.cb := sizeof(si); si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; si.wShowWindow := SW_HIDE; // assign "other" sides of pipes si.hStdInput := hPipes[ H_IN_READ ]; si.hStdOutput := hPipes[ H_OUT_WRITE ]; si.hStdError := hPipes[ H_ERR_WRITE ]; // Create a child process try fCreated := CreateProcess( nil, PChar(szChildName), nil, nil, True, ProcPriority, // CREATE_SUSPENDED, nil, nil, si, ProcessInfo ); except fCreated := False; end; if not fCreated then goto error; Result := True; CloseHandle(hPipes[ H_OUT_WRITE ]); CloseHandle(hPipes[ H_ERR_WRITE ]); // ResumeThread( pi.hThread ); SetThreadPriority(ProcessInfo.hThread, ThreadPriority); CloseHandle( ProcessInfo.hThread ); Exit; //----------------------------------------------------- error: ClosePipes( hPipes ); CloseHandle( ProcessInfo.hProcess ); CloseHandle( ProcessInfo.hThread ); ProcessInfo.hProcess := INVALID_HANDLE_VALUE; ProcessInfo.hThread := INVALID_HANDLE_VALUE; Result := False; end; Как поменять приоритет процесса?
procedure TForm1.Button1Click(Sender: TObject); var ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle; begin ProcessID := GetCurrentProcessID; ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID); SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); ThreadHandle := GetCurrentThread; SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL); end; ------- Можно и так: SetThreadPriority(GetCurrentThread(), THREAD_PRIORITY_TIME_CRITICAL); SetPriorityClass(GetCurrentProcess(), REALTIME_PRIORITY_CLASS); Запуск задач в качестве системных процессов.
program Service; uses Windows,Registry,TlHelp32,SysUtils; {$APPTYPE CONSOLE} var add_reg,del_reg,run_hidden,term_service,not_run,run_once:boolean; i:integer; reg:Tregistry; Function RegisterServiceProcess(dwProcessId,dwType:DWORD):DWORD;stdcall;external 'kernel32.dll'; Function GetProcessId(exename:string):integer; var hSnap:THandle; pe:TProcessEntry32; procid:integer; procexe:string; begin pe.dwSize:=SizeOf(pe); hSnap:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0); If Process32First(hSnap,pe) then begin While Process32Next(hSnap,pe) do begin procexe:=pe.szExeFile;procid:=pe.th32processid; if uppercase(procexe)<>uppercase(exename) then continue; result:=procid; closehandle(hSnap); exit; end; end; result:=0; closehandle(hSnap) end; Function GetProcessExe(var exename:string):integer; var hSnap:THandle; pe:TProcessEntry32; procid:integer; prochandle:integer; procexe:string; begin pe.dwSize:=SizeOf(pe); hSnap:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0); If Process32First(hSnap,pe) then begin While Process32Next(hSnap,pe) do begin procexe:=pe.szExeFile;procid:=pe.th32processid; if uppercase(procexe)<>uppercase(exename) then continue; prochandle:=openprocess(PROCESS_ALL_ACCESS,true,procid); result:=prochandle; closehandle(hSnap); exit; end; end; result:=0; closehandle(hSnap) end; Procedure Help; begin Writeln('RunService 1.0 for Windows95/98 by Anton Geleznyak (2:5000/106)'); Writeln('---------------------------------------------------------------'); Writeln('Syntax: Runserv [keys]'); Writeln('Possible keys are:'); WRiteln('/a — add to registry services startup.'); Writeln('/o — add to registry services startup to run once.'); Writeln('/h — run hidden.'); Writeln('/r — remove from registry services startup.'); Writeln('/t — terminate service.'); Writeln('/n — do not run.'); Writeln('/h — this help screen.'); Writeln(''); end; Procedure Add_to_Registry(exename:string); begin reg:=Tregistry.Create; reg.RootKey:=HKEY_LOCAL_MACHINE; if not run_once then reg.OpenKey('\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUNSERVICES\',true) else reg.OpenKey('\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUNSERVICESONCE\',true); reg.WriteString(exename,exename); reg.CloseKey; reg.Free end; Procedure Remove_from_Registry(exename:string); begin reg:=Tregistry.Create; reg.RootKey:=HKEY_LOCAL_MACHINE; reg.OpenKey('\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUNSERVICES\',true); if reg.ValueExists(exename) then
reg.DeleteValue(exename) else
begin
Writeln('ERROR: Service record not found in the registry.');halt(253);
end;
reg.CloseKey;
reg.Free
end;
Procedure Execute(exename:string); begin if run_hidden then WinExec(pchar(exename),sw_hide) else WinExec(pchar(exename),sw_show); RegisterServiceProcess(GetProcessId(exename),1); end; Procedure TerminateService(exename:string); begin if getprocessexe(exename)=0 then begin Writeln('ERROR: Cannot terminate process that is not started yet.');halt(254);end; terminateprocess(getprocessexe(exename),0); end; begin add_reg:=false; del_reg:=false; run_hidden:=false; term_service:=false; not_run:=false; run_once:=false; if (paramcount=0) or (lowercase(paramstr(1))='/h') then begin help;halt(0);end; if paramcount>1 then begin for i:=2 to paramcount do begin if lowercase(paramstr(i))='/a' then add_reg:=true; if lowercase(paramstr(i))='/h' then run_hidden:=true; if lowercase(paramstr(i))='/r' then del_reg:=true; if lowercase(paramstr(i))='/t' then term_service:=true; if lowercase(paramstr(i))='/n' then not_run:=true; if lowercase(paramstr(i))='/o' then run_once:=true; end; end; if not fileexists(paramstr(1)) then begin Writeln('ERROR: Exefile not found');halt(255);end; if add_reg or run_once then Add_To_Registry(paramstr(1)); if del_reg then Remove_From_Registry(paramstr(1)); if term_service then TerminateService(paramstr(1)); if not not_run then Execute(paramstr(1)); halt(0); end.Сетевые ф-ии Проверка подключения к сети.
if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then ShowMessage('Machine is attached to network') else ShowMessage('Machine is not attached to network'); Как узнать список установленных cjm-портов?
var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey('hardware\devicemap\serialcomm', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end;Окна Перебор окон.
Using the Windows API function FindWindow() is the simplest and most straightforward method of locating a given window provided you know the exact window caption or class name. If you know only part of the window's caption (ie: 'Netscape — ' + 'Some Unknown URL', you need to use the Windows EnumWindows() function to enumerate all the active windows, then call the Windows API functions GetWindowsText() and GetClassName to see if you find a match for the window that you are searching for. The following example returns the window handle of the first window enumerated that contains a partial match of the window title and an exact match of the window's ClassName (if given) and brings that window to the foreground. type PFindWindowStruct = ^TFindWindowStruct; TFindWindowStruct = record Caption : string; ClassName : string; WindowHandle : THandle; end; function EnumWindowsProc(hWindow : hWnd; lParam : LongInt) : Bool {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} var lpBuffer : PChar; WindowCaptionFound : bool; ClassNameFound : bool; begin GetMem(lpBuffer, 255); Result := True; WindowCaptionFound := False; ClassNameFound := False; try if GetWindowText(hWindow, lpBuffer, 255) > 0 then if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0 then WindowCaptionFound := true; if PFindWindowStruct(lParam).ClassName = '' then ClassNameFound := True else if GetClassName(hWindow, lpBuffer, 255) > 0 then if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then ClassNameFound := True; if (WindowCaptionFound and ClassNameFound) then begin PFindWindowStruct(lParam).WindowHandle := hWindow; Result := False; end; finally FreeMem(lpBuffer, sizeof(lpBuffer^)); end; end; function FindAWindow(Caption : string; ClassName : string) : THandle; var WindowInfo : TFindWindowStruct; begin with WindowInfo do begin Caption := Caption; ClassName := ClassName; WindowHandle := 0; EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo)); FindAWindow := WindowHandle; end; end; procedure TForm1.Button1Click(Sender: TObject); var TheWindowHandle : THandle; begin TheWindowHandle := FindAWindow('Netscape — ', ''); if TheWindowHandle = 0 then ShowMessage('Window Not Found!') else BringWindowToTop(TheWindowHandle); end;Другое Переменные окружения
// // ENVIR. This sample shows how to get process environment strings and // values of individual environment variables. Uses GetEnvironmentStrings // and GetEnvironmentVariable functions from WIN32 API // unit EnvUnit; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; Button1: TButton; Edit2: TEdit; ComboBox1: TComboBox; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var DosEnv : PChar; I : Integer; SignPos : Integer; begin // // GetEnvironmentStrings = 32-bit version of GetDosEnvironment // Memo1.Lines.Clear; // Get all environment variables DosEnv := GetEnvironmentStrings; While DosEnv^ <> #0 do begin // Add one by one into memo Memo1.Lines.Add(StrPas(DosEnv)); // Get next one Inc(DosEnv, StrLen(DosEnv)+1); end; // Fill in ComboBox With Memo1 do begin for I := 0 to Lines.Count-1 do begin SignPos := Pos('=',Lines[I]); ComboBox1.Items.Add(Copy(Lines[I], 1, SignPos-1)); end; end; // Show 1st element ComboBox1.ItemIndex := 0; ComboBox1.OnChange(Self); end; procedure TForm1.Button2Click(Sender: TObject); var Name, Value : PChar; begin // Get memory Name := StrAlloc(255); Value:= StrAlloc(255); // Convert to PChar StrPCopy(Name, ComboBox1.Items[ComboBox1.ItemIndex]); // Get variable value GetEnvironmentVariable(Name, Value, 255); // Show it as Pascal string Edit2.Text := StrPas(Value); // Free memory StrDispose(Name); StrDispose(Value); end; end. Информация о виртуальной памяти.
unit VMUnit; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls; type TForm1 = class(TForm) Label1: TLabel; TabControl1: TTabControl; Panel1: TPanel; Label2: TLabel; Label3: TLabel; Label4: TLabel; Label5: TLabel; Label6: TLabel; Label7: TLabel; Label8: TLabel; procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1 : TForm1; MemoryStatus : TMemoryStatus; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin MemoryStatus.dwLength := SizeOf(MemoryStatus); GlobalMemoryStatus(MemoryStatus); With MemoryStatus do Begin dwTotalPhys := dwTotalPhys DIV 1024; {} Label2.Caption := 'Memory load : ' + IntToStr(dwMemoryLoad); Label3.Caption := 'Total phys : ' + IntToStr(dwTotalPhys); Label4.Caption := 'Avail phys : ' + IntToStr(dwAvailPhys); Label5.Caption := 'Total Page File : ' + IntToStr(dwTotalPageFile); Label6.Caption := 'Avail Page File : ' + IntToStr(dwAvailPageFile); Label7.Caption := 'Total Virtual : ' + IntToStr(dwTotalVirtual); Label8.Caption := 'Avail Virtual : ' + IntToStr(dwAvailVirtual); End; end; end. Как сделать MS-Style диалог "О программе" ?
Диалог можно нарисовать ручками (из калькулятора того же срисовать), а информацию об OS и количестве памяти можно взять следующим образом : type TAboutForm = class(TForm) OS: TLabel; Mem: TLabel; ... procedure TAboutForm.GetOSInfo; var Platform: string; BuildNumber: Integer; begin case Win32Platform of VER_PLATFORM_WIN32_WINDOWS: begin Platform := 'Windows 95'; BuildNumber := Win32BuildNumber and $0000FFFF; end; VER_PLATFORM_WIN32_NT: begin Platform := 'Windows NT'; BuildNumber := Win32BuildNumber; end; else begin Platform := 'Windows'; BuildNumber := 0; end; end; if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or (Win32Platform = VER_PLATFORM_WIN32_NT) then begin if Win32CSDVersion = '' then OS.Caption := Format('%s %d.%d (Build %d)', [Platform, Win32MajorVersion, Win32MinorVersion, BuildNumber]) else OS.Caption := Format('%s %d.%d (Build %d: %s)', [Platform, Win32MajorVersion, Win32MinorVersion, BuildNumber, Win32CSDVersion]); end else OS.Caption := Format('%s %d.%d', [Platform, Win32MajorVersion, Win32MinorVersion]) end; procedure TAboutForm.InitializeCaptions; var MS: TMemoryStatus; begin GetOSInfo; MS.dwLength := SizeOf(TMemoryStatus); GlobalMemoryStatus(MS); Mem.Caption := FormatFloat('#,###" KB"', MS.dwTotalPhys div 1024); end; Информация о часовых поясах.
The following example lists the time zones known to Windows. Example: uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false); if reg.HasSubKeys then begin ts := TStringList.Create; reg.GetKeyNames(ts); reg.CloseKey; for i := 0 to ts.Count -1 do begin reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false); Memo1.Lines.Add(ts.Strings[i]); Memo1.Lines.Add(reg.ReadString('Display')); Memo1.Lines.Add(reg.ReadString('Std')); Memo1.Lines.Add(reg.ReadString('Dlt')); Memo1.Lines.Add('----------------------'); reg.CloseKey; end; ts.Free; end else reg.CloseKey; reg.free; end; Как обновить ярлыки на рабочем столе?
SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0); ЧТО ДЕЛАЕТ inf-файл?
Он позволяет осуществить: Создание элементов реестра Определение инициализационных параметров (INI-settings) Копирование файлов с дистрибутива и размещение их в системе Инсталляция устройств Управление другими INF-фаилами Конфигурирование опций устройств INF-файлы представляют собой инициализационные файлы, которые конфигурируют устройство или приложение в вашей системе и задают его элементы в реестре. INF-файлы обычно поставляются производителем продукта вместе с устройством или приложением. Кроме того, можно их найти на электронных досках объявле- ний и других on-line сервисах. INF-файлы понадобятся вам для многих обычных (не РпР) устройств, которые вам нужно будет конфигурировать для работы с Windows 95. Как правило, INF-файлы включают список допустимых логических конфигураций, имена файлов драйверов устройств и г. д. В ряде случаев вам потребуется самим писать INF-файлы для устройств или программного обеспече- ния. Формат lNF-файлов аналогичен формату INIфайлов, которые использовались в Windows З.х, включая квадратные скобки, ключи и разделы, используемые то- лько Windows 95. Структура INF-файла ------------------- Когда вы инсталлируете новое устройство. Windows ищет INF-фаилы для этого устройства, используя при этом идентификатор устройства (device ID). Собрав из INF-фаила всю необходимую информацию, система создает в реестре элемент для этого устройства под ключом HKEY_LOCAL_MACHINE. Значения из INF-файла копируются в элемент реестра, соответствующий драйверу устройства. Такие значения, как DevLoader= и Driverdesc= включаются в элемент аппаратного драйвера Driver=. Элемент Еnum содержит значения Driver= и ConfigFlags=. INF-фаилы представляют собой файлы в формате ASCII, состоящие из нескольких разделов. Каждый раздел предназначен для выполнения определенной задачи. Имена разделов обычно заключаются в квадратные скобки. Типичные элементы представляют собой ключ и значение, соединенные знаком равенства. В раздел можно включить одно или несколько значений. Кроме того, в состав элемента можно включать комментарии, отделяя их символом точки с запятой, например: [section] keyname=value ;эта часть строки является комментарием Поскольку INF-файлы являются файлами формата ASCII, должен существовать способ, с помощью которого они будут предоставлять реестру информацию в двоичном формате. Структура INF определяет двоичный файл, который преобра- зует ASCII-текст в двоичный формат при чтении его реестром. Типы информационных файлов: Layout (Формат). Определяет информацию о диске и номере версии, а также содержит список всех файлов с указанием диска, на котором они располагают- ся. Selective Install (Избирательная инсталляция). Определяет части инстал- ляции, являющиеся необязательными компонентами, а также те ее части, кото- рые зависят от инсталляции других компонентов. Например, Microsoft Fax тре- бует предварительной загрузки Microsoft Exchange. Вы имеете возможность уп- равлять инсталляцией компонент этих типов. Application/Installation, APPS.INF (Приложения/Инсталляция). Обнаружива- ет используемые вами приложения MS-DOS и устанавливает для них параметры окружения. Эти lNF-файлы содержат настройки и параметры для многих приложе- ний DOS. Как правило, это самый большой информационный файл в вашей систе- ме. В его состав входят многие виды настройки памяти, настройки расширенной памяти (XMS), а также другие параметры, которые в Windows З.х содержались в настройках PIF Device Installation and Configuration (Инсталляция и конфигуриро вание устройств). Это наиболее общий из всех информационных файлов на котором мы до сих пор концентрировали все внимание. Эти файлы описывают параметры на- стройки для конкретных физических устройств. Если вы имеете драйвер устрой- ства ранних версий, в INF-файле будет содержаться информация об этом уст- ройстве. Устройства Plug and Play, с другой стороны, помещают информацию о себе прямо в реестр. Общая организация lNF-файла --------------------------- Раздел каждого устройства в INF-файлс состоит из следующих разделов: Раздел [Version]. Идентифицирует INF и класс поддерживаемого устройства. Ниже перечислен список некоторых устройств, которые вы можете включить: adapter keyboard NetService CDROM MCADevices NetTrans (сетевые транспорты) diskdrive media nodriver dispaly modem PCMCIA EISADevices monitor ports Fdc mouse printer Hdc MTD SCSIAdapter Раздел [Manufacturer]. Идентифицирует производителя устройства (например, Link, Micro, и т.п.) и соответствующих продуктов. Каждый INF-файл должен иметь по крайней мере один раздел [ Manufacturer]. Раздел [Install]. Содержит информацию о физических атрибутах устройства и его драйверах. Раздел [Classlnstall]. Этот раздел необязателен. Он идентифицирует новый класс для указанного уст- ройства в INF-фаиле Раздел [String]. Идентифицирует локализованные строки в INF-фаиле Раздел [Miscellaneous]. Содержит информацию о том, как устройства управляются пользовательским ин- терфейсом W95. Элементы APPS.INF ----------------- В разделе [appname] файла APPS.INF вы найдете элементы, перечисленные в табл. Используя эти элементы вы сможете быстрее перенести в W95 настройки PIF из ваших старых инсталляций Windows. Многие из приложений, перечисленных в файле APPS.INF, представляют собой старые игры для MS-DOS. Если вы сталкиваетесь с тем, что игра не работает в среде W95, просмотрите этот файл. Возможно, вам удастся модифицировать ка- кой-либо из его элементов таким образом, чтобы игра запустилась или стала работать лучше. Если вы вносите изменения в файл APPS.INF, вам потребуется перезагрузить W95, чтобы внесенные изменения попали в реестр. Помимо редак- тирования файла APPS.INF, некоторые из параметров вы можете изменить, от- крыв страницу свойств конкретного приложения. Ниже приведен пример раздела [аррname]: [PRODIGY.EXE] LowMem=440 EMSMen=None XMSMem=None Enable=lml Disable=win,hma В этой части файла APPS.INF раздел [appname] замещается именем исполняемого модуля, например, PRODIGY.EXE, PARADOX.EXE и т.п. Имя элемента реестра Описание ключа Значение ALLOWSSAVER Позволяет появляться заставке sav (работает в REALMODE) при работающих программах DOS. Настройка по умолчанию ALTENTER Позволяет использовать клавиатурную аеn комбинацию + для переклю- чения между полноэкранным и оконным режимами. Настройка по умолчанию. ALTESC Позволяет использовать выход с помощью Aes клавиатурной комбинации -. Настройка по умолчанию. ALTPRTSCRN Позволяет выполнять моментальный снимок Psc экрана с помощью клавиатурной комбинации +. Настройка по умолчанию. ALTSPACE Позволяет использовать клавиатурную aps комбинацию + для отображения системного меню. Настройка по умолчанию. ALTTAB Позволяет использовать клавиатурную ком- Ata бинацию для переключения между приложе- ниями. Настройка по умолчанию. BACKGROUND Дает приложению указание работать в win фоновом режиме. Настройка по умолчанию. CDROM Позволяет использовать драйвер MSCDEX. cdr (работает в REALMODE) Настройка по умолчанию. CLOSEONEXIT Закрывает при выходе окно DOS. He явля- cwe ется настройкой по умолчанию. CRTLESC Позволяет закрывать приложение нажатием ces клавиатурной комбинации +. Настройка по умолчанию. DETECTIDLE Задает чувствительность в неактивном сос- dit тоянии. Настройка по умолчанию. DISKLOCK Позволяет осуществлять прямой доступ к dsk (работает в REALMODE) диску. EMS Активизирует EMS386 для программ DOS. ems (работает в REALMODE) Настройка по умолчанию. EMSLOCKED Указывает на блокировку памяти EMS eml EMULATEROM Указывает на необходимость использо- emt вания быстрой эмуляции ROM. Настройка по умолчанию. EXCLUSIVE Работает в эксклюзивном режиме. Этот exc параметр игнорируется. FASTPASTE Активизирует быструю вставку из прило- aft жения. Настройка по умолчанию. GLOBALMEM Активизирует глобальную защиту памяти gmp LOWLOCKED Указывает на то, что нижняя память lml (до 640 Кб) заблокирована. Этот параметр игнорируется. MOUSE Активизирует функции мыши. Настройка по mse (работает в REALMODE) умолчанию. NETWORK Разрешает программе DOS получать доступ net (работает в REALMODE) к сетевым дискам и принтерам. Настройка по умолчанию. PRIVATECFG Позволяет программе DOS использовать пер- cfg (работает в REALMODE) сональный файл CONFIG.SYS. He является настройкой по умолчанию. REALMODE Запускает программу в реальном режиме DOS. dos He является настройкой по умолчанию. RETAINVRAM Дает указание сохранить видеопамять. rvm Этот параметр игнорируется. UNIQUESETTINGS Запускает программы DOS в отдельных DOS- uus сеансах. Не является настройкой по умолчаний. USEHMA Дает указание использовать НМА (верхние hma адреса памяти). Значение по умолчанию. VESA Дает программам DOS получать доступ к vsa (работает в REALMODE) продвинутым графическим возможностям. WINDOWED Запускает приложение в окне, а не в win полноэкранном режиме. Настройка по умолчанию. WINLIE Не позволяет программам DOS обнаруживать lie W95. Не яаляется параметром по умолчанию. XMSLOCKED Дает указание блокировать память XMS. Xml В файле APPS.INF доступны, но не реализованы следующие параметры: DISPLAYTBAR (dtb) Отображает панель инструментов. EXCLMOUSE (exm) Разрешает режим монопольного использования мыши QUICKEDIT (qme) Активизирует для мыши режим быстрого редактирования WARNIFACTIVE (wia). Позволяет подавать предупреждения, если приложение DOS еще активно Справочник по разделам ---------------------- В нижеприведенных таблицах описаны все ключевые слова и значения, ассоци- ированные с конкретными разделами. Синтаксис раздела [Version] приведен ни- же. Квадратные скобки используются для обозначения начала нового раздела. Для того чтобы настройки INF были понятны W95 и реестру, квадратные скобки обязательно должны присутствовать. [Version] Signature=$CHICAGO$ Class=name_of_class Provider=%File_creator% LayoutFile=filename.inf Ключевое слово Значение Описание Signature $Chicago$ Задает операционную систему для INF-файла. На момент написания большинства INF-файлов кодовое название Windows 95 было следующим: Chicago. Class name_of_class Указывает класс, который будет определен в ре- естре. Список общих классов устройств, которые вы можете ввести сюда, приведен в данном при- ложении ранее. LayoutFile filename.inf Эта строка определяет имя INF-файла, содержа- щего имена исходного диска и файлов, которые должны быть включены для инсталляции этого устройства. Если его не определить, то по умол- чанию файл имеет имя LAYOUT.INF. Если вы не включите эти данные в раздел Version, то должны будете включить в файл APPS.INF разделы SourceDiskName и SourceDiskFiles. Синтаксис раздела [Manufacturer] приведен ниже. [Manufacturer] "manufacturer" %string_value%=manufacturer_section Информация раздела [Manufacturer] Ключевое слово Описание "manufacturer" Имя производителя этого устройства, заключенное в кавычки. Сюда можно включить любую строку. Это клю- чевое слозо является необязательным. %string_value% Указывает имя строки, включенной в раздел Stings INF-файла. Строки должны быть заключены в символы процента (%). manufacturer_section Указывает на раздел Manufacturer Name в INF-файле. Раздел [Manufacturer Name] включает описания устройства для указанного уст- ройства Ключевые слова, используемые в этом разделе, описаны в таблице. Синтаксис этого раздела выглядит следующим образом: [name_of_manufacturer] description of deviсe=install_section,ID_of_device[compatible_device_IDs,...] Информация раздела [Manufacturer Name] Ключевое слово Описание description_of_device Описание инсталлируемого устройства. install_section Указывает имя раздела Install для этого устройства. ID_of_device Идентификатор (ID) инсталлируемого устройства. [compatible_device_IDs,...] Содержит Ссылки на устройства, совместимые с данным. В этот список можно включить несколько устройств, разделив их запятыми. Раздел [File List] можно использовать для указания файлов, которые вы хоти- те скопировать, переименовать или удалить. В зависимости от элемента разде- ла [Install] вы можете использовать три следующих синтаксических параметра: [file_list section] new_filename, old_filename Эта конструкция используется для элементов RenFiles. Допускается вклююние любого количества элементов new_filename, old_filename. Для элементов DelFiles используется следующий синтаксис: [file_list section] filename Параметр filename обозначает имя файла, который вы хотите удалить. Для элемента CopyFiles используется следующий синтаксис. Параметры source_filename и temporary_filename в этой конструкции являются необязате- льными. [file_list section] destination_filename,source_filename,temporary_filename Ниже приведен образец синтаксиса раздела [Install]. Этот раздел включает дополнительные разделы INF-файла, которые содержат описания устройства. В правой части выражения, после знака равенства, можно указать несколько зна- чений, разделенных запятыми. [name_of_install_section] LogConfig=section_name Copyfiles=file_list_section Renfiles=file_list_section DelFiles=file_list_section UpdateInis=UpdateIni_section_name UpdateIniFields=UpdateIniFields_section_name AddReg=AddRegitry_section DelReg=DelRegitry_section Ini2Reg=IniToRegistry_section UpdateCfgSys=UpdateConfig_section UpdateAutoBat=UpdateAutoexec_section Reboot или Restart Информация раздела [Install] Ключевое слово Значение Описание [name_of_install_section] Содержит имя устройства, соответ- ствующего информации, приведен- ной в этом разделе. В разделе ManufacturerName INF-файла дол- жна присутствовать ссылка на этот раздел LogСonfig section_name Содержит информацию о разделах логической конфигурации уст- ройства. Значения section_name указывают на разделы INF-файла в которых содержится информа- ция о данном устройстве. CopyFiles file_list_section Содержит информацию, необходимую для копирования указанного файла или файлов в каталог, указанный в разделе File_List. Вы можете дать системе указание скопировать отдельный файл. Для этого перед именем файла необходимо включить символ @. При этом файл будет скопирован в каталог DefaultDestDir, определенный в разделе DestinationDir INF-файла. RenFiles fiie_list_section Позволяет переименовать указан- ный файл. Представляет собой указатель на раздел File_List INF-файла. DelFiles file_list_section Позволяет удалить указанный файл. Представляет собой указа- тель на раздел FileList INF-файла. UpdateInis UpdateIni_section_name Позволяет указать Значение INI- файла, которое вы хотите изме- нить через INF-файл. Представля- ет собой указатель на раздел Update INI. UpdatelniFields UpdateIniFields_section_name Позволяет изменять, замещать или удалять отдельные элементы значений INI-файла (в отличие от предыдущего параметра, который изменял все значение целиком). Этот параметр представляет со- бой указатель на раздел Update IniFields. AddReg AddRegistry_section Позволяет указать подключ или значение, которые требуется до- бавить в реестр. Представляет собой указатель на раздел Add Registry. DelReg Del_Registry_section Позволяет указать подключ или значение, которые требуется уда- лить из реестра. Представляет собой указатель на раздел Delete Registry Ini2Reg IniToRegistry_section Перемещает в реестр строки и разделы из INI-файла. Представ- ляет собой указатель на раздел Ini to Registry. UpdateCfgSys UpdateConfig_section Содержит указатель на раздел Update Config. в этом разделе находятся команды, которые должны быть добавлены, удалены или переименованы в файле CONFIG.SYS. UpdateAutoBat UpdateAutoexec_section Содержит указатель на раздел Update AutoExec. В этом разделе находятся команды, которые мо- дифицируют файл AUTOEXEC.BAT. Reboot или Restart Команды, вызывающие перезапуск системы или перезагрузку ком- пьютера после завершения про- граммы установки. Ниже приведен пример синтаксиса раздела [Logical Configuration]. Раздел [LogConfig] необходимо указать в разделе [Install]. Этот раздел содержит информацию о конфигурации системных ресурсов, включая IRQ, порты ввода/вы- вода, каналы DMA и т. д. Для каждого включаемого элемента программа Setup создает запись логической конфигурации в двоичном формате и включает эту информацию в реестр в раздел driver. INF-файлы могут содержать несколько (или ни одного) разделов [Logical Configuration]. Ключевые слова и значения этого раздела описаны в таблице. [LogConfig Section name] ConfigPriority=value_of_priority MemConfig=menory_range_settings I/OConfig=ioport_settings IRQConfig=irq_sectings DMAConfig=dma_settings Ключевое слово Значение Описание ConfigPriority value_of_priority Содержит значение приоритета конфигурации для данного устрой- ства. MemConfig memory_range_settings Указывает диапазон памяти для данного устройства. I/OConfig ioport_settings Позволяет указать для устройства конфигурацию портов ввода/вывода. IRQConfig irq_settings Содержит СПИСОК допустимых IRQ для данного устройства. Если устройство не использует IRQ, не следует включать эту строку в INF-файл. DMAConfig dma_settings Указывает допустимые значения DMA для данного устройства. Для параметров настройки, перечисленных в таблице, можно указывать не один, а несколько ресурсов. Однако, в процессе инсталляции будет использован то- лько один из ресурсов, приведенных в списке. Чтобы указать несколько ресур- сов для одного устройства, вам потребуется создать соответствующее число записей для каждого из ресурсов. Ниже приведен пример синтаксиса раздела [Update AutoExec]. Имя раздела [UpdateAutoBat] должно быть указано в разделе [Install]. Этот раздел соде- ржит команды, манипулирующие строками в файле AUTOEXEC.BAT. Ключевые слова и значения этого раздела приведены в таблице. [Update_autobat_section] CmdDelete=command CmdAdd=command UnSet=environmentvariablename PreFixPath=%ldid% RemOldPath=%ldid% TmpDir=%ldid% Ключевое слово Значение Описание CmdDelete command Указывает команду, которая должна быть удалена из файла AUTOEXEC.BAT. Эта строка обрабатывается перед строкой CmdAdd. CmdAdd command Указывает команду, которую требуется добавить в файл AUTOEXEC.BAT. UnSet environmentvariablename Указывает переменную окружения, кото- рую вы хотите удалить из файла AUTOEXEC.BAT. PreFixPath %ldid% Позволяет включить предопределенную фиксированную переменную path в форме логического идентификатора каталога (logical directory identificator, LDID). RemOldPath %ldid% Позволяет указать путь, который должен быть удален из файла AUTOEXEC.BAT. TmpDir %ldid% Позволяет указать временный каталог на время установки. Ниже приведен пример синтаксиса раздела [Update Config]. Имя раздела [Update_config_section] должно быть задано в разделе [Install]. Этот раздел содержит команды манипуляции со строками в файле CONFIG.SYS. Ключевые слова и значения этого раздела описаны в таблице. [Update_config_section] DevRename=current_name,new_name DevDelete=driver_name DevAddDev=driver_name,configkeyword Stacks=dos_stack_values Buffers=dos_buffer_values Files=dos_buffer_values LastDrive=dos_lastdrive_value Ключевое слово Значение Описание DevRename current_name,new_name Позволяет переименовать драйверы устройств, вызываемые из файла CONFIG.SYS. Раздел может содержать несколько строк DevRename. Записи DevRename обрабатываются первыми, прежде, чем начнется обработка каких-либо других записей раздела. DevDelete driver_name Позволяет указать драйверы устройств, которые должны быть удалены из файла CONFIG.SYS. Раздел может содержать несколько записей DevDelete. DevAddDev driver_name,configkeyword Позволяет указать новый драйвер, который должен быть добавлен в файл CONFIG.SYS. Раздел может содержать несколько записей DevAddDev. Stacks dos_stack_values Указывает значение Stacks= в файле CONFIG.SYS. Buffers dos_buffer_values Указывает значение Buffers= в файле CONFIG.SYS. Files dos_file_values Указывает значение Files= в файле CONFIG.SYS. LastDrive dos_lastdrive_value Указывает значение lastdrive= в файле CONFIG.SYS. Ниже приведен пример синтаксиса раздела [Update INI]. Раздел [Update INI] необходимо указать в разделе [Install] записью UpdateINIs. Этот раздел добавляет, удаляет или замещает записи в указанном INI-фаЙле. Ключевые слова и значения для этого раздела описаны в таблице. [Update_ini_section] ini-file,ini-section,original_entry,new_entry, options Значение Описание options Необязательные флаги операции, которые могут принимать одно из следующих значений 0 Значение по умолчанию. Ищет ключ (имя записи) original_entry, игнорируя его значение. Если ключ при- сутствует, соответствующая запись заменяется на new_entry. Если original_entry равна NULL, new_entry добавляется безусловно. Если new_entry равна NULL, original_entry удаляется. 1 Ищет запись original_entry по ключу и значению. Обнов- ление выполняется только в том случае, когда совпадают и ключ, и значение записи original_entry. 2 Ищет запись, ключ которой совпадает с указанным в original entry. Если запись уже существует, она не за- мещается значением, указанным вами в new_entry. 3 Ищет запись, ключ и значение которой совпадают с указанными в original_entry. Если такая запись существует, она замещается new_entry. Ниже приведена синтаксическая конструкция раздела [Update IniFields]. Имя раздела [UpdatelniFields] должно быть указано элементом [UpdatelniFieldsl в разделе [Install]. Утверждения этого замещают, добавляют или удаляют поля в указанной записи INI-файла. В отличие от раздела [Update INI], команды из данного раздела работают с фрагмента- ми записей, а не с записями в целом. [update_inifields_section] ini-file,ini-section,profile_name,old_field,new_field Если в строке INI-файла для указанной записи присутствовал комментарий, он удаляется. Модификаторы old_field и new_field являются необяза- тельными. Раздел [Add Registry] позволяет добавлять в реестр ключи и значения. Кроме того, существует необязательная возможность установить фактиче- ское значение. Имя раздела [add_registry_section] должно быть задано элементом AddReg раздела [Install]. Синтаксис раздела выглядит следую- щим образом: [add_registry_section] reg_root_string В этот раздел вы можете включить подключи, имена значений и (необязательно) сами значения. Раздел [Delete Registry] используется для удаления из реестра подклю- чен и имен значений. Синтаксис этого раздела выглядит следующим обра- зом: [del_registry_section] reg_root_string,subkey Имя этого раздела должно быть указано элементом DelReg в разделе [Install]. Каждый элемент, включенный в этот раздел, удалит из реестра подключ или значение. Раздел [Ini to Registry] позволяет перемещать в реестр строки и разде- лы из INI-файла. Эта операция или создает в реестре новый элемент, или подключ или значение. Имя раздела [ini_to_registry section] должно быть указано элементом lni2Reg в разделе [Install]. Раздел [DestinationDirsI позволяет определить каталог назначения для раздела [File_List]. Ссылка на имя раздела [DestinationDirs] должна присутствовать в одном из следующих трех элементов раздела [Install]: DelFiles, CopyFiles или RenFiles. Синтаксис раздела приведен ниже. Более подробную информацию можно найти в таблице. [DestinationDirs] file_list=ldid,subdirectory DefaultDestDir=ldid,subdirectory Ключевое слово Значение Описание file_list ldid,subdirectory Указывает имя раздела FileList. subdirectory Указывает каталог, находящийся в каталоге ldid. Это значение необязательно. ldid Указывает логический идентификатор диска. Список допустимых значений ldid приведен далее. DefaulDestDir Позволяет указать каталог-приемник по умолчанию для всех неупомянутых разделов File_List. Этот параметр не является обязательным. По умол- чанию W95 использует каталог LDID_WIN. Раздел [SourceDisksFilesj используется для указания исходных файлов, используемых в процессе инсталляции. Кроме того, с помощью этого разде- ла можно указать исходные диски, содержащие эти файлы. Синтаксис раз- дела очень прост: [SourceDisksFiles] name_of_source_disk=disk_number Элемент disk_number определяется в разделе [SourceDisksNames], кото- рый использует следующий синтаксис: [SourceDisksNames] disk_ordinal=description_of_disk,label,serial_number Раздел [ClassInstall] устанавливает новый класс устройства в разделе реестра [Class]. Синтаксис раздела [ClassInstall] приведен ниже. Подробную информацию о значениях и элементах, которые используются в этом разделе, можно найти в таблице выше. [ClassInstall] CopyFiles=fils_list_section RenFiles=fils_list_section DelFiles=fils_list_section UpdateInis=UpdateIni_section_name UpdateIniFields=UpdateIniFields_section_name AddReg=AddRegistry_section DelReg=DelRegistry_section Наконец, последним разделом INF-фаила является раздел [Strings]. Этот раздел определяет один или несколько строковых ключей. Синтаксис этого раздела приведен ниже. [Strings] string_key="valve" Ключевое слово string_key обозначает строковый ключ, формирующийся из буквенно-цифровых символов, например, MfgName. Хотя раздел [Strings] обычно является последним в INF-файле, строковые ключи можно использовать везде, где допустимо употребление строк. Программа Setup подставляет вместо строкового ключа строку, заданную элементом "value" и в дальнейшем использует именно ее, например: MSFT="Microsoft" Встпетив строку MSFT. поогоамма Setup интерпретирует ее как Microsoft Значения LDID ------------- В таблице перечислены допустимые значения LDID (logical disk identifier), которые вы можете использовать в INF-файлах. ID Обозначает 00 Пустой LDID; используется для создания нового LDID 01 Исходное устройство:\путь 02 Временный каталог Setup; используется только в процессе установки W95 03 Каталог Uninstall 04 Каталог Backup 10 Каталог Windows 11 Каталог SYSTEM 12 Каталог lOsubsys 13 Каталог COMMAND 14 Каталог Control Panel 15 Каталог Printers 16 Каталог Workgroup 17 Каталог INF 18 Каталог Help 19 Каталог Administration 20 Каталог Fonts 21 Каталог Viewers 22 Каталог VMM32 23 Каталог Color 25 Каталог Shared 26 Каталог Winboot 27 Машинно-зависимый каталог 28 Каталог Winboot Host 30 Корневой каталог загрузочного устройства 31 Корневой каталог хост-диска виртуального загрузочного устройства 32 Каталог с прежней версией Windows (если есть) 33 Каталог с прежней версией MS-DOS (если есть)DB Просмотр удаленных записей в DBase
При удалении записей в таблицах dBASE на самом деле происходит пометка записи на удаление, в то время как сами записи остаются в файле,
пока таблица не будет упакована. Поэтому "удаленные" записи можно просмотреть, и даже восстановить их. Чтобы показать помеченные на удаление записи, нужно использовать функцию BDE DbiSetProp. Ниже приведен пример функции-оболочки для DbiSetProp.
Ей передается в качестве параметра таблица и логическая переменная, означающая показывать удаленные записи, или нет.
Таблица может быть открыта или закрыта. procedure TForm1.ShowDeleted(Table: TTable; ShowDeleted: Boolean); var rslt: DBIResult; szErrMsg: DBIMSG; begin Table.DisableControls; try Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON, LongInt(ShowDeleted))); finally Table.EnableControls; end; Table.Refresh; end; Упаковка таблицы Paradox
function PackParadoxTable(Tbl: TTable; Db: TDatabase):DBIResult; var TblDesc: CRTblDesc; begin Result := DBIERR_NA; FillChar(TblDesc, SizeOf(CRTblDesc), 0); StrPCopy(TblDesc.szTblName, Tbl.TableName); TblDesc.bPack := True; Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil,False); end; Таблица, передаваемая в качестве второго параметра, должна быть закрыта. Как заставить BDE производить запись изменений в таблицах Paradox на диск?
ОТВЕТ: // Сбрасывает табличные буфера, физически на диск function TMyUtil.flushBuf : Boolean; var tmpDM: TDataModule; i: LongInt; begin result:=3Dtrue; with YouDateModule or You table for i:=3D0 to ComponentCount-1 do begin if components[i] is TTable then begin with components[i] as TTable do begin if active then begin if (DbiSaveChanges(Handle)=3DDBIERR_NONE) then begin FlushBuffers; end //if else begin ShowMessage('Ошибка сброса на диск ' + TableName); result:=3Dfalse; end; end; //if active=20 end; //with end; //if end; //for end; //with end; Кроме того, не забывайте из той программы, которая хочет просмотреть изменения вызывать refresh для нужной таблицы. Ускорение работы с последовательностью записей.
var s: String; begin Table1.Open; ............ while not Table1.eof do begin s := Table1.FieldByName('...').AsString; ........ Table1.Next; end; Table1.Close; end; можно записать var s: String; f: TField; begin Table1.Open; f := Table1.FieldByName('...'); {!!!!!} ............ while not Table1.eof do begin s := f.AsString; {!!!!!} ........ Table1.Next; end; Table1.Close; end; Путь к локальной таблице.
implementation {$R *.DFM} uses DbiTypes, DbiProcs; function fDbiFormFullName(Tbl: TTable): String; var Props: CurProps; Buffer1 : array[0..DBIMAXPATHLEN] of char; Buffer2 : array[0..DBIMAXPATHLEN] of char; begin Check(DbiGetCursorProps(Tbl.Handle,Props)); StrPCopy(Buffer1, Tbl.TableName); Check(DbiFormFullName(Tbl.DBHandle, @Buffer1, Props.szTableType, @Buffer2)); Result := StrPas(Buffer2); end; Notes: Table_You_Are_Using.Active Must be True. Works on Local Tables. Создание алиасов.
procedure CheckAlias(const AliasName, AliasType, AliasPath: String); { Если алиас не существует, создать его } var SList: TStrings; i: Integer; AliasFound: Boolean; begin { Проверка существования алиса BDE } try SList := TStringList.Create; Session.GetAliasNames(SList); AliasFound := False; for i:=0 to SList.Count-1 do if SList[i]=AliasName then begin AliasFound := True; break; end; finally SList.Free; end; if AliasFound then begin try SList := TStringList.Create; Session.GetAliasParams(AliasName,SList); {А в 4-ой версии SList[2]!!! и без слова Path } if SList[0]<>'PATH='+AliasPath then { Правильно ли задан путь } begin SList[0] := 'PATH='+AliasPath; Session.ModifyAlias(AliasName,SList); end; finally SList.Free; end; end else Session.AddStandardAlias(AliasName,AliasPath,AliasType); { Создать новый алиас } Session.SaveConfigFile; end;SQL Как в DELPHI 3 заполнить поле одним и тем же значением сразу у многих записей?
ОТВЕТ: Для заполнения поля таблицы определенным значением сразу для многих записей необходимо воспользоваться командами SQL, а именно — командой UPDATE. Где в секции WHERE и определить условие, которому и отвечают эти записи.
В случае отсутствия секции WHERE будут заполнены все записи таблицы.
Чтобы выполнить этот запрос из Delphi, достаточно создать компоненту типа TQuery
(кстати, совершенно не обязательно делать ее визуальной, можно просто создать экземпляр этого типа) и заполнить свойство SQL
соответствующим текстом.
Или в инспекторе объектов или в коде программы. Например: Query.SQL.ADD('UPDATE Table SET DateToDay=:CurrentDate WHERE Sum > 0 '); Тогда для всех строк, у которых поле Sum положительно, будет произведена замена поля DateToDay значением переменной CurrentDate. Для исполнения этой замены необходимо задать значение параметра и выполнить запрос. Query.Close; Query.ParamByName('CurrentDate').AsDateTime:=Now; Query.Open; Замена произведена. Елена ФилипповаСетевые ф-ии WSAAsyncSelect: параметр handle при запускаете dll (init).
const WM_ASYNCSELECT = WM_USER+0; TNetConnectionsManager = class(TObject) protected FWndHandle : HWND; procedure WndProc( var MsgRec : TMessage ); ... end; constructor TNetConnectionsManager.Create begin inherited Create; FWndHandle := AllocateHWnd(WndProc); ... end; destructor TNetConnectionsManager.Destroy; begin ... if FWndHandle<>0 then DeallocateHWnd(FWndHandle); inherited Destroy; end; procedure TNetConnectionsManeger.WndProc( var MsgRec : TMessage ); begin with MsgRec do if Msg=WM_ASYNCSELECT then WMAsyncSelect(MsgRec) else DefWindowProc( FWndHandle, Msg, wParam, lParam ); end; Hо pекомендую посмотpеть WinSock2, в котоpом можно: WSAEventSelect( FSocket, FEventHandle, FD_READ or FD_CLOSE ); WSAWaitForMultipleEvents( ... ); WSAEnumNetworkEvents( FSocket, FEventHandle, lpNetWorkEvents ); То есть, обойтись без окон и без очеpеди сообщений windows, а заодно иметь возможность pаботать и с IPX/SPX, и с netbios. Свой winsock2.pas я вчеpа кинул в RU.DELPHI.DB, если кто имеет такой из дpугих источников — свистните погpомче. Alex Konshin alexk@msmt.spb.su (2:5030/217) Как сделать чтобы при событиях моя программа отпpавляла кому-либо сообщение на мой компьютеp.
Win32: F1 "NetMessageBufferSend" Win16: Почему-то неописан, но руками наковырял... function NetMessageBufferSend( Zero1, Zero2: Word; WhoTo: PChar; Buffer: PChar; BufSize: Word): Integer; external 'NETAPI' index 525; Александр Петросян(PAF, Alexander Petrosyan), Зеленоград.(2:5020/468.8) Как работать с поименованными каналами под W'95/NT в сети?
сервер : StrPCopy(buff,Edit1.Text); fPipeHandle:=CreateNamedPipe(buff, Pipe_Access_Duplex or File_Flag_Overlapped, Pipe_Type_Message or Pipe_ReadMode_Byte or Pipe_Wait, 5, $400, $400, 235, nil); клиент : StrPCopy(buff,Edit1.Text); fFileHandle:=CreateFile(buff, Generic_Read or Generic_Write, File_Share_Read or File_Share_Write, nil, Open_Existing, File_Attribute_Normal or File_Flag_Overlapped or Security_Anonymous, 0); if fFileHandle <> Invalid_Handle_Value then begin ... Jack Sinelnikov (2:5054/9.13) Как подключать сетевые диски?
Вот pабочий кусок кода из пpогpаммы "мэйлеpа" сетевой FIDO станции: var nw:TNetResource; ... nw.dwType:=RESOURCETYPE_DISK; nw.lpLocalName:=nil; nw.lpRemoteName:=PChar('\\'+MailServer.RemoteName+'\MAIL'); nw.lpProvider:=nil; if MailServer.Password<>'' then Err:=WNetAddConnection2(nw,PChar(MailServer.Password),nil,0) else Err:=WNetAddConnection2(nw,nil,nil,0); If Err=NO_ERROR then begin ... end; MailServer.RemoteName и Password -- имя удаленного компа в сети и паpоль доступа к pесуpсу соответвенно. ps.: так, как написано, ты будешь к pесуpсу обpащаться как к '\\Comp\Disc'. если хочешь подключить сетевой pесуpс как локальный диск -- меняй nw.lpLocalName. pps.: когда(если) закончишь юзать сетевой диск, ставь WNetCancelConnection2. Vadim Saitov (2:5011/76.13)Стандартные элементы управления Мне надо добавить много строк в TListbox или в TCombobox
или в TMemo или в TRichEdit, при этом сам объект постоянно мигает, перерисовываясь. Как избавиться от этого?
BeginUpdate/EndUpdate. Многоколоночный ListBox.
ListCtrl из common controls. У него есть такой стиль. ------------------------------ В книгах и других источниках по Delphi часто приводится пример создания компонента,
способного выводить текст в списке в несколько колонок.
Между тем, мало кому известен факт, что стандартный компонент TListBox уже содержит свойство, которое позволяет это делать.
Это свойство TabWidth (в Delphi 2 оно не описано в файлах помощи, хотя так же присутствует),
которое наследуется от класса TCustomListBox и задает величину табуляции в пикселах.
Установите его равным, скажем, половине ширины компонента ListBox, чтобы отображалось две колонки.
Когда будете добавлять строки, всавьте в нужных местах символ табуляции (^I): ListBox1.Items.Add('Колонка1'^I'Колонка2'); Недостаток такого подхода заключается в том, что ширина колонки не изменяется авоматически
в зависимости от ширины выводимых строк, что, впрочем, легко исправить.
Посмотрите на метод TextWidth класса TCanvas. Он возвращает ширину в пикселах передаваемой ему в качестве параметра строки.
Тогда перед добавлением каждого нового элемента в список проверяем, превышает ли его ширина ширину колонки: with ListBox do begin W := Canvas.TextWidth(Str); if W > TabWidth then TabWidth := W; end; Как указать максимальный размер текста для RichEdit Control?
У этого компонента есть свойство MaxLength, которое работает некорректно. Поэтому лучше пользоваться RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0); Причем перед каждом открытии файла это действие необходимо повторять. Maxim Liverovskiy (2:5030/254.38) Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки. Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT. Stas Mehanoshin (2:5030/143.23) Выделение стpочек в TTreeView жиpным или бледным.
procedure SetNodeState(node :TTreeNode; Flags: Integer); var tvi: TTVItem; begin FillChar(tvi, Sizeof(tvi), 0); tvi.hItem := node.ItemID; tvi.mask := TVIF_STATE; tvi.stateMask := TVIS_BOLD or TVIS_CUT; tvi.state := Flags; TreeView_SetItem(node.Handle, tvi); end; И вызываем: SetNodeState(TreeView1.Selected, TVIS_BOLD); // Текст жиpным SetNodeState(TreeView1.Selected, TVIS_CUT); // Иконкy бледной (Ctrl+X) SetNodeState(TreeView1.Selected, TVIS_BOLD or TVIS_CUT); // Текст жиpным SetNodeState(TreeView1.Selected, 0); // Hи того, ни дpyгого Dmitry Nogin (FidoNet 2:5020/611.15) Как в TMemo определить номер строки, в которой находится курсор и его местоположение в строке.
var X,Y: LongInt; ............ Y:=Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0); X:=Memo1.Parform(EM_LINEINDEX, Y, 0); inc(Y); X:=Memo1.SelStart-X+1; ........ Alexey Glotov (2:5020/382.18) Выделение стpок в TTreeView жиpным/бледным.
procedure SetNodeState(node :TTreeNode; Flags: Integer); var tvi: TTVItem; begin FillChar(tvi, Sizeof(tvi), 0); tvi.hItem := node.ItemID; tvi.mask := TVIF_STATE; tvi.stateMask := TVIS_BOLD or TVIS_CUT; tvi.state := Flags; TreeView_SetItem(node.Handle, tvi); end; И вызываем: SetNodeState(TreeView1.Selected, TVIS_BOLD); // Текст жиpным SetNodeState(TreeView1.Selected, TVIS_CUT); // Иконкy бледной (Ctrl+X) SetNodeState(TreeView1.Selected, TVIS_BOLD or TVIS_CUT); // Текст жиpным SetNodeState(TreeView1.Selected, 0); // Hи того, ни дpyгого Когда-то (мечтательно закатив глаза в потолок) в API было еще и TVIS_DISABLE. Снесли собаки.
А pекомендyемyю стилистикy yпотpебления этого добpа смотpи в MS Internet News. Dmitry Nogin (FidoNet 2:5020/611.15) Позициированиие в ListBox.
procedure TForm1.Edit1Change(Sender: TObject); var S : Array[0..255] of Char; begin StrPCopy(S, Edit1.Text); with ListBox1 do ItemIndex := Perform(LB_SELECTSTRING, 0, LongInt(@S)); end;Элементы VCL Отправка сообщений компонентам
Если вам необходимо послать сообщение Windows (или ваше собственное) какому-либо компоненту, воспользуйтесь методом Perform.
Этот метод вводится в классе TControl, поэтому его имеют все визуальные компоненты.
Метод Perform посылает сообщение непосредственно оконной процедуре компонента, минуя очередь сообщений Windows, в отличие от функций API SendMessage и PostMessage, которые посылают сообщения в очередь. Пример: Panel1.Perform(WM_LButtonDown, 0, MakeLong(1, 1)); Panel1.Perform(WM_LButtonUp, 0, MakeLong(1, 1)); Ускорение работы TMemo
Если в вашей программе происходит добавление большого количества строк в компонент Memo, то операцию можно значительно ускорить.
Для этого нужно вызвать метод BeginUpdate перед добавлением строк, и метод EndUpdate после добавления: Memo1.Lines.BeginUpdate; ... {добавляем множество строк ...} ... Memo1.Lines.EndUpdate; Вышесказанное в равной степени относится к компоненту ListBox и его свойству Items,
а также к другим компонентам, которые имеют свойства типа TStrings. Как привязать к конкретному компоненту дополнительную информацию?
Не забывайте про свойство Tag: его вполне хватит для размещения в нем указателя на произвольную информацию. Пример: --- динамическое создание и привязка текстовой строки. begin for i := 0 to ComponentCount — 1 do if Components[i] is TEdit then Components[i].Tag := LongInt(NewStr('Hello '+IntToStr(i))); end; ---освобождение памяти begin for i := 0 to ComponentCount — 1 do if Components[i] is TEdit then begin TEdit(Components[i]).Text := PString(Components[i].Tag)^; DisposeStr(PString(Components[i].Tag)); end; end; --- Cвойство Hint
Если Hint является полем Вашей компоненты, например FHint:THintWindow, тогда в конструкторе Create Вашей компоненты можно например его инициализировать: FHint:=THintWindow.Create(Self); FHint.Parent:=Self.Parent; далее при необходимости отобразить Hint: R:=Rect(x1,y1,x2,y2); FHint.ActivateHint(R,''); FHint.Caption:='my hint; Почему сразу не передать строку в качестве второго параметра метода ActiveHint? Вначале эта строка будет отображаться в прямоугольнике по умолчанию, левый верхний угол которого имеет координаты (0,0) в системе координат всего экрана (!) и только потом перемещаться в координаты (R.X , R.Y) — это приводит к не очень красивому "морганию" Hint'a, особенно если строка достаточно большая (>10 символов). при необходимости скрыть Hint: FHint.Caption:=''; R:=Rect(0,0,0,0); FHint.ActivateHint(R,''); такая последовательность действий объясняется теми же причинами, что и при показе Hint'a. - DIJ 1'95 Каким образом можно отследить вставку и удаление компонент в форму в design-time?
Для получения такой информации предназначен метод procedure Notification (AComponent: TComponent; Operation: TOperation); virtual; класса TComponent. Перекрыв его в своей компоненты Вы можете произвести необходимые действия,
в зависимости от значения параметра Operation типа TOperation = (opInsert, opRemove); объявленного в модуле Classes. Параметр AComponent — компонента, соответственно вставлемая или удаляемая, в зависимости от Operation. Как создать копию произвольного компонента?
{ Здесь пpоцедypа CreateClone, котоpая кpеатит компонентy ОЧЕHЬ ПОХОЖУЮ на входнyю. С такими же значениями свойств. Пpисваивается все, кpоме методов. } function CreateClone(Src: TComponent): TComponent; var F: TStream; begin F := nil; try F := TMemoryStream.Create; F.WriteComponent(Src); RegisterClass(TComponentClass(Src.ClassType)); F.Position := 0; Result := F.ReadComponent(nil); finally F.Free; end; end; Как использовать ChartFX.
with ChartFX do begin Visible := false; { Устанавливаем режим ввода значений } { 1 — количество серий (в нашем случае 1), 3 — количество значений } OpenData [COD_VALUES] := MakeLong (1,3); { Hомер текущей серии } ThisSerie := 0; { Value [i] — значение с индексом i } { Legend [i] — комментарий к этому значению } Value [0] := a; Legend [0] := 'Значение переменной A'; Value [1] := b; Legend [1] := 'Значение переменной B'; Value [2] := c; Legend [2] := 'Значение переменной C'; { Закрываем режим } CloseData [COD_VALUES] := 0; { Ширина поля с комментариями на экране (в пикселах) } LegendWidth := 150; Visible := true; end; end;Формы Как сделать так, чтобы по Alt-F4 форма не закрывалась, а выдавала запрос на сохранение?
Обрабатывать OnCloseQuery. Как правильно создавать компоненты в run-time?
---cut--- procedure TForm1.CreateButton; var btn : TButton; begin btn := TButton.Create(Self); { Уничтожать кнопку будет форма } btn.Parent := Self; { Родителем кнопки будет форма } btn.OnClick := ButtonClicked; { Процедура, которая будет исполняться при } btn.Visible := true; { нажатии на кнопку } end; ---cut--- Как можно перетаскивать форму не только за заголовок?
WM_NCHITTEST. === Cut === Как сделать так, чтобы в моей форме курсор перемещался по полям ввода по Enter, как по Tab?
Если вы хотите обрабатывать событие на уровне формы (а не в каждом отдельном компоненте),
уберите обработчики события у всех компонент и создайте FormKeyPress -- обработчик OnKeyPress для формы: ---cut--- procedure Form1.OnKeyPress(Sender : TObject; var Key : char); begin if Key = #13 then begin SelectNext(Sender as TWinControl, true, true); Key := #0; end; end; ---cut--- ( NB:нyжно выставлять y фоpмы KeyPreview = True; default-кнопки на фоpмy поместшать нельзя ). Как запретить кнопку Close [x] в заголовке окна.
Вот кусок, который делает все, что тебе нужно: procedure TForm1.FormCreate(Sender: TObject); var Style: Longint; begin Style := GetWindowLong(Handle, GWL_STYLE); SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU); end; procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key = VK_F4) and (ssAlt in Shift) then begin MessageBeep(0); Key := 0; end; end; Alexander Petrushev (2:5001/88.10) 'а самом деле есть более простой способ (запрет на SC_CLOSE), но я уже деталей его не помню. Akzhan Abdulin (2:5040/55) === Cut === { Disable close button } procedure TForm1.Button1Click(Sender: TObject); var SysMenu: HMenu; begin SysMenu := GetSystemMenu(Handle, False); Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED); end; { Enable close button } procedure TForm1.Button2Click(Sender: TObject); begin GetSystemMenu(Handle, True); Perform(WM_NCPAINT, Handle, 0); end; === Cut === 'о это окно можно закрыть из TaskBar'а. Vlad Filyakov (2:5022/26.9) И все же, кажется, я делал иначе. :( Akzhan Abdulin (2:5040/55) Как отобразить некоторые окна своей программы в панели задач Windows (помимо главного окна)
Hапример, так: procedure TMyForm.CreateParams(var Params :TCreateParams); {override;} begin inherited CreateParams(Params); {CreateWindowEx} Params.ExStyle := Params.ExStyle or WS_Ex_AppWindow; end; Max Rusov (2:5030/456.1) Свертывание фоpмы при откpытом модальном окне.
function TMyModalForm.Execute: TModalResult; begin Show; try SendMessage(Handle, CM_ACTIVATE, 0, 0); ModalResult := 0; repeat Application.HandleMessage; if Application.Terminated then ModalResult := mrCancel; if ModalResult = mrCancel then CloseModal; until ModalResult <> 0; Hide; Result := ModalResult; SendMessage(Handle, CM_DEACTIVATE, 0, 0); finally Hide; end; end; ( TMyForm должно быть FormStyle := fsStayOnTop ) Eugeny D.Shtefanov shtefanov@usa.net -- Дорабатывайте ф-ию по вашему желанию. Имея имя фоpмы нyжно пеpебpать на ней все компоненты имеющие свойство font.
uses TypInfo; в цикле по всем объектам формы if GetPropInfo( nil then <твои действия> Необходимо, чтобы дочерняя форма не активизировала родительское окно.
Сделайте родительским окном рабочий стол. --- procedure TForm2.CreateParams(VAR Params: TCreateParams); begin Inherited CreateParams(Params); Params.WndParent := GetDesktopWindow; end; --- Как использовать форму из DLL ?
Это файл Form.dpr, из которого получается DLL: library Form; uses Classes, Unit1 in 'Unit1.pas' {Form1}; exports CreateMyForm, DestroyMyForm; end. Это его Unit1: unit Unit1; interface [раздел uses и определение класса Form1 поскипаны] procedure CreateMyForm(AppHandle : THandle); stdcall; procedure DestroyMyForm; stdcall; implementation {$R *.DFM} procedure CreateMyForm(AppHandle : THandle); begin Application.Handle:=AppHandle; Form1:=TForm1.Create(Application); Form1.Show end; procedure DestroyMyForm; begin Form1.Free end; end. Это UnitCall вызывающего EXE-шника: unit UnitCall; interface [раздел uses и определение класса Form1 поскипаны] procedure CreateMyForm(AppHandle : THandle); stdcall; external 'Form.dll'; procedure DestroyMyForm; stdcall; external 'Form.dll'; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin CreateMyForm(Application.Handle) end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin DestroyMyForm end; end.MDI MDI-приложение, в котором способны сливаться не только меню дочернего и главного окна,
но и полосы инструментов?
>Ваpиант 1. CoolBar. procedure TMainForm.SetBands(AControls: array of TWinControl; ABreaks: array of boolean); var i: integer; begin with CoolBar do begin for i:=0 to High(AControls) do begin if Bands.Count=succ(i) then TCoolBand.Create(Bands); with Bands[succ(i)] do begin if Assigned(Control) then Control.Hide; MinHeight:=AControls[i].Height; Break:=ABreaks[i]; Control:=AControls[i]; Control.Show; Visible:=true; end end; for i:=High(AControls)+2 to pred(Bands.Count) do Bands[i].Free end end; и procedure TMsgForm.FormActivate(Sender: TObject); begin MainForm.SetBands([ToolBar],[false]) end; Пpимечание: Оба массива pавны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я pазмешаю "глобальные" кнопки. СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу. Пpи CoolBar.AutoSize:=true возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить: AutoSize:=false; try ... finally AutoSize:=true; >Ваpиант 2. TMainForm ... object SpeedBar: TPanel ... Align = alTop BevelOuter = bvNone object ToolBar: TPanel ... Align = alLeft BevelOuter = bvNone end object RxSplitter1: TRxSplitter ... ControlFirst = ToolBar ControlSecond = ChildBar Align = alLeft BevelOuter = bvLowered end object ChildBar: TPanel .... Align = alClient BevelOuter = bvNone end end > TMdiChild {пpоподитель всех остальных} ... object pnToolBar: TPanel ... Align = alTop BevelOuter = bvNone Visible = False end procedure TMDIForm.FormActivate(Sender: TObject); begin pnToolBar.Parent:=MainForm.ChildBar; pnToolBar.Visible:=True; end; procedure TMDIForm.FormDeactivate(Sender: TObject); begin pnToolBar.Visible:=false; pnToolBar.Parent:=self {pnToolBar.Visible:=false} end; Jury Martynov (2:5020/800.21)Работа с принтером Простейший способ печати.
=== Cut === var file_ : textfile; begin AssignFile ( file_, 'prn' ); Rewrite ( file_ ); WriteLn ( file_, 'print me' ); CloseFile ( file_ ); end. === Cut === Как мне отправить на принтер чистый поток данных?
Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает последнее. Под Win32 Вы можете использовать WritePrinter. 'иже пример открытия принтера и записи чистого потока данных в принтер. Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet 5MP", чтобы функция сработала успешно. Конечно, Вы можете включать в поток данных любые необходимые управляющие коды, которые могут потребоваться. uses WinSpool; procedure WriteRawStringToPrinter(PrinterName:String; S:String); var Handle: THandle; N: DWORD; DocInfo1: TDocInfo1; begin if not OpenPrinter(PChar(PrinterName), Handle, nil) then begin ShowMessage('error ' + IntToStr(GetLastError)); Exit; end; with DocInfo1 do begin pDocName := PChar('test doc'); pOutputFile := nil; pDataType := 'RAW'; end; StartDocPrinter(Handle, 1, @DocInfo1); StartPagePrinter(Handle); WritePrinter(Handle, PChar(S), Length(S), N); EndPagePrinter(Handle); EndDocPrinter(Handle); ClosePrinter(Handle); end; procedure TForm1.Button1Click(Sender: TObject); begin WriteRawStringToPrinter('HP', 'Test This'); end; (Borland FAQ N714, переведен Акжаном Абдулиным) Как исправить ошибку, возникающую при попытке печатать из RichEdit под Windows NT?
unit PrtRichU; interface uses SysUtils, Windows, Classes, ComCtrls, RichEdit, Printers; procedure PrintRichEdit(const Caption: string; const RichEdt: TRichEdit); implementation procedure PrintRichEdit(const Caption: string; const RichEdt: TRichEdit); var Range: TFormatRange; LastChar, MaxLen, LogX, LogY, OldMap: Integer; begin FillChar(Range, SizeOf(TFormatRange), 0); with Printer, Range do begin BeginDoc; hdc := Handle; hdcTarget := hdc; LogX := GetDeviceCaps(Handle, LOGPIXELSX); LogY := GetDeviceCaps(Handle, LOGPIXELSY); if IsRectEmpty(RichEdt.PageRect) then begin rc.right := PageWidth * 1440 div LogX; rc.bottom := PageHeight * 1440 div LogY; end else begin rc.left := RichEdt.PageRect.Left * 1440 div LogX; rc.top := RichEdt.PageRect.Top * 1440 div LogY; rc.right := RichEdt.PageRect.Right * 1440 div LogX; rc.bottom := RichEdt.PageRect.Bottom * 1440 div LogY; end; rcPage := rc; Title := Caption; LastChar := 0; MaxLen := RichEdt.GetTextLen; chrg.cpMax := -1; OldMap := SetMapMode(hdc, MM_TEXT); SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0); try repeat chrg.cpMin := LastChar; LastChar := SendMessage(RichEdt.Handle, EM_FORMATRANGE, 1, Longint(@Range)); if (LastChar -1) then NewPage; until (LastChar >= MaxLen) or (LastChar = -1); EndDoc; finally SendMessage(RichEdt.Handle, EM_FORMATRANGE, 0, 0); SetMapMode(hdc, OldMap); end; end; end; end. Как отправить на принтер чистый поток данных?
Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает последнее. Под Win32 Вы можете использовать WritePrinter. 'иже пример открытия принтера и записи чистого потока данных в принтер. Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet 5MP", чтобы функция сработала успешно. Конечно, Вы можете включать в поток данных любые необходимые управляющие коды, которые могут потребоваться. uses WinSpool; procedure WriteRawStringToPrinter(PrinterName:String; S:String); var Handle: THandle; N: DWORD; DocInfo1: TDocInfo1; begin if not OpenPrinter(PChar(PrinterName), Handle, nil) then begin ShowMessage('error ' + IntToStr(GetLastError)); Exit; end; with DocInfo1 do begin pDocName := PChar('test doc'); pOutputFile := nil; pDataType := 'RAW'; end; StartDocPrinter(Handle, 1, @DocInfo1); StartPagePrinter(Handle); WritePrinter(Handle, PChar(S), Length(S), N); EndPagePrinter(Handle); EndDocPrinter(Handle); ClosePrinter(Handle); end; procedure TForm1.Button1Click(Sender: TObject); begin WriteRawStringToPrinter('HP', 'Test This'); end; (Borland FAQ N714, переведен Акжаном Абдулиным)Наиболее распространенные библиотеки компонентов rxLib
Одна из самых, если не самая лучшая библиотека общего назначения для Delphi. Огромное количество компонентов и полезных функций.
Полные исходные тексты. Совместима со всеми Delphi (1, 2 и 3), а также с ++-Builder.
Великолепные примеры использования. Исчерпывающие файлы помощи на русском языке. Авторы: Fedor Koshevnikov (kosh(at)masterbank.msk.ru) Igor Pavluk (pavluk(at)masterbank.msk.ru) Serge Korolev (korolev(at)masterbank.msk.ru)Курсоры, иконки и др. Как использовать свои курсоры в программе?
=== Cut === {$R CURSORS.RES} const crZoomIn = 1; crZoomOut = 2; Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN'); Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT'); === Cut === Как я могу использовать анимированный курсор?
Сперва Вы должны взять хэндл курсора Windows и присвоить его одному из элементов массива Cursors обьекта Screen. Предопределенные курсоры имеют отрицательный индекс, а определенные пользователем (Вами) курсоры получают положительные индексы. 'иже пример формы, использующей анимированный курсор: procedure TForm1.Button1Click(Sender: TObject); var h : THandle; begin h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE ); if h = 0 then ShowMessage('Cursor not loaded') else begin Screen.Cursors[1] := h; Form1.Cursor := 1; end; end; (Borland FAQ N696, переведен Акжаном Абдулиным)Работа с Help файлами Хелп с окошечком для поиска раздела.
WinHelp: макрос "Search()" Delphi: procedure TForm1.HelpSearchFor; var S : String; begin S := ''; Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP'; Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S)); end; Konstantin Kipa 2:5061/19.17 kotya@extranet.ru Как заставить Help-файлы нормально отображать русский под Windows 3.x?
Удалось вылечить дописыванием в файл пpоекта в гpафу Options
стpочки FORCEFONT=Arial Cyr, пpичем HC31 pугается что нет такого шpифта, но зато хелп потом ноpмально показывается на
пpактически под любой pуссифициpованной виндой. пpовеpял с [Win31+CyrWin] [Win311Rus] [Win95PE] [Win95Rus]. (на NT не пpовеpял.) Пpичем шpифты в тексте ноpмально пеpеключаются и будутне только Arial. в HPJ файл: === [OPTIONS] FORCEFONT=Arial Cyr === Andrey Kalmykov (2:5030/172.36)Графика Создание и обработка изображений Как создать disable'ный битмап из обычного (emboss etc)?
CreateMappedBitmap() :-) Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь пеpекодиpовкy, цвета подбеpешь сам из пpинципа: все самые яpкие -> в GetSysColor( COLOR_3DLIGHT ); самые темные -> GetSysColor( COLOR_3DSHADOW ); нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE ); Serge Zakharchuk (2:5060/32) Так на самом деле вот как делается данная задача: ============ procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap); var TmpImage,Monobmp:TBitmap; IRect:TRect; begin MonoBmp := TBitmap.Create; TmpImage:=Tbitmap.Create; TmpImage.Width := bmpFrom.Width; TmpImage.Height := bmpFrom.Height; IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height); TmpImage.Canvas.Brush.Color := clBtnFace; try with MonoBmp do begin Assign(bmpFrom); Canvas.Brush.Color := clBlack; if Monochrome then begin Canvas.Font.Color := clWhite; Monochrome := False; Canvas.Brush.Color := clWhite; end; Monochrome := True; end; with TmpImage.Canvas do begin Brush.Color := clBtnFace; FillRect(IRect); Brush.Color := clBlack; Font.Color := clWhite; CopyMode := MergePaint; Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp); CopyMode := SrcAnd; Draw(IRect.Left, IRect.Top, MonoBmp); Brush.Color := clBtnShadow; Font.Color := clBlack; CopyMode := SrcPaint; Draw(IRect.Left, IRect.Top, MonoBmp); CopyMode := SrcCopy; bmpTo.assign(TmpImage); TmpImage.free; end; finally MonoBmp.Free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin aaa(image1.picture.bitmap,image2.picture.bitmap); Image2.invalidate; end; ============ Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph. Как раз из него я это и выдернул). Hу а если уже совсем хорошо разобраться, то можно заметить функцию ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость (но визуально это очень плохо воспринимается). Соответственно параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что последний абзац работает только с тройкой. Denis Tanayeff denis@demo.ru Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал. ==================== #define CO_GRAY 0x00C0C0C0L hMemDC = CreateCompatibleDC(hDC); hOldBitmap = SelectObject(hMemDC, hBits); // hBits это собственно картинка, которую надо "засерить" GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap); if ( GetState(BS_DISABLED) ) // Blt disabled { hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth, Bitmap.bmHeight, PATCOPY); DeleteObject(SelectObject(hDC, hOldBrush)); lbLogBrush.lbStyle = BS_PATTERN; lbLogBrush.lbHatch =(int)LoadBitmap(hInsts, MAKEINTRESOURCE(BT_DISABLEBITS)); hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush)); BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth, Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa DeleteObject(SelectObject(hDC, hOldBrush)); DeleteObject((HGDIOBJ)lbLogBrush.lbHatch); } ================== Andy Nikishin http://www.gs.ru/~links/andy.shtml (2:5031/16.2) Как скопировать экран (или его часть) в TBitmap?
с помощью WinAPI так — var bmp: TBitmap; DC: HDC; begin bmp:=TBitmap.Create; bmp.Height:=Screen.Height; bmp.Width:=Screen.Width; DC:=GetDC(0); //Дескpиптоp экpана bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DC, 0, 0, SRCCOPY); bmp.SaveToFile('Screen.bmp'); ReleaseDC(0, DC); end; Peter Maishev (2:5020/1530.31) Или с помощью обертки TCanvas — Объект Screen[.width,height] — размеры Var Desktop :TCanvas ; BitMap :TBitMap; begin DesktopCanvas:=TCanvas.Create; DesktopCanvas.Handle:=GetDC(Hwnd_Desktop); BitMap := TBitMap.Create; BitMap.Width := Screen.Width; BitMap.Height:=Screen.Height; Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect, DesktopCanvas, DesktopCanvas.ClipRect); ........ end; Serg Lukashov serg@tnd.belpak.gomel.by, serg.d.lukashov@usa.net (2:452/9.16) Как правильно печатать любую информацию (растровые и векторные изображения),
а также как сделать режим предварительного просмотра?
Главная головная боль пpи отpисовке больших кусков, котоpые занимают весь лист или его большую часть,
надо метафайл по pазмеpам делать сpазу же в пикселах на этот самый лист.
Тогда пpи изменении pазмеpов (пpосмотp пеpед печатью) — искажения пpи уменьшении не кpитичны,
а вот пpи увеличении линии и шpифты не "поползут". Итак : Hабоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистом отдела матобеспечения СибHИИHП, г. Тюмень. Моего здесь только — пpиделывание свеpху надстpоек для личного использования. Вся pабота сводится к следующим шагам : 1. Получить необходимые коэф-ты. 2. Постpоить метафайл или bmp для последующего вывода на печать. 3. Hапечатать. Hиже пpиведенный кусок (пpошу меня не пинать, но писал я и писал для достаточно кpивой pеализации с пеpедачей паpаметpов чеpез глобальные пеpеменные) я использую для того, чтобы получить коэф-ты пеpесчета. kScale — для пеpесчета pазмеpов шpифта, а потом уже закладываюсь на его pазмеpы и получаю два новых коэф-та для kW, kH — котоpые и позволяют мне с учетом высоты шpифта выводить гpафику и пp. У меня пpи pаботе kW <> kH, что пpиходится учитывать. Решили пункт 1. procedure SetKoeffMeta; // установить коэф-ты var PrevMetafile : TMetafile; MetaCanvas : TMetafileCanvas; begin PrevMetafile := nil; MetaCanvas := nil; try PrevMetaFile := TMetaFile.Create; try MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 ); kScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) / Screen.PixelsPerInch; MetaCanvas.Font.Assign( oGrid.Font); MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale ); kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W'); kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W'); finally MetaCanvas.Free; end; finally PrevMetafile.Free; end; end; Решаем 2. ... var PrevMetafile : TMetafile; MetaCanvas : TMetafileCanvas; begin PrevMetafile := nil; MetaCanvas := nil; try PrevMetaFile := TMetaFile.Create; PrevMetafile.Width := oWidth; PrevMetafile.Height := oHeight; try MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 ); // здесь должен быть ваш код — с учетом масштабиpования. // я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок // вызываю лишь для отpисовки целой стpаницы. см. PS1. finally MetaCanvas.Free; end; ... PS1. Код, котоpый используется для отpисовки. oCanvas — TCanvas метафайла. ... var iHPage : integer; // высота страницы begin with oCanvas do begin iHPage := 3000; // залили область метайфайла белым — для дальнейшей pаботы Pen.Color := clBlack; Brush.Color := clWhite; FillRect( Rect( 0, 0, 2000, iHPage ) ); // установили шpифты — с учетом их дальнейшего масштабиpования oCanvas.Font.Assign( oGrid.Font); oCanvas.Font.Size := Round( oGrid.Font.Size * kScale ); ... xEnd := xBegin; iH := round( RowHeights[ iRow ] * kH ); for iCol := 0 to ColCount — 1 do begin x := xEnd; xEnd := x + round( ColWidths[ iCol ] * kW ); Rectangle( x, yBegin, xEnd, yBegin + iH ); r := Rect( x + 1, yBegin + 1, xEnd — 1, yBegin + iH — 1 ); s := Cells[ iCol, iRow ]; // выписали в полученный квадрат текст DrawText( oCanvas.Handle, PChar( s ), Length( s ), r, DT_WORDBREAK or DT_CENTER ); Главное, что важно помнить на этом этапе — это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите - это уже ваше дело). В данном случае — я pаботаю с пеpеделанным TStringGrid, котоpый сделал для многостpаничной печати. Последний пункт — надо сфоpмиpованный метафайл или bmp напечатать. ... var Info: PBitmapInfo; InfoSize: Integer; Image: Pointer; ImageSize: DWORD; Bits: HBITMAP; DIBWidth, DIBHeight: Longint; PrintWidth, PrintHeight: Longint; begin ... case ImageType of itMetafile: begin if Picture.Metafile<>nil then Printer.Canvas.StretchDraw( Rect(aLeft, aTop, aLeft+fWidth, aTop+fHeight), Picture.Metafile); end; itBitmap: begin if Picture.Bitmap<>nil then begin with Printer, Canvas do begin Bits := Picture.Bitmap.Handle; GetDIBSizes(Bits, InfoSize, ImageSize); Info := AllocMem(InfoSize); try Image := AllocMem(ImageSize); try GetDIB(Bits, 0, Info^, Image^); with Info^.bmiHeader do begin DIBWidth := biWidth; DIBHeight := biHeight; end; PrintWidth := DIBWidth; PrintHeight := DIBHeight; StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth, PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY); finally FreeMem(Image, ImageSize); end; finally FreeMem(Info, InfoSize); end; end; end; end; end; В чем заключается идея PreView ? Остается имея на pуках Metafila, Bmp — отpисовать с пеpесчетом внешний вид изобpажения (надо высчитать левый веpхний угол и pазмеpы "пpедваpительно пpосматpиваемого" изобpажения. Для показа изобpажения достаточно использовать StretchDraw. После того, как удалось вывести объекты на печать, пpоблему создания PreView pешили как "домашнее задание". Кстати, когда мы pаботаем с Bmp, то для пpосмотpа используем следующий хинт - записываем битовый обpаз чеpез такую пpоцедуpу : === Cut === w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),Screen.Pixels PerInch); h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),Screen.Pixel sPerInch); PrevBmp.Width:=w; PrevBmp.Height:=h; PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp); aPicture.Assign(PrevBmp); === Cut === Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи печати — пpиходится bmp печатать именно так, как описано выше.
Итог — наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но пpи этом — внешне — без каких-либо искажений и пp. Боpисов Олег Hиколаевич (ZB) panterra@sbtx.tmn.ru (2:5077/5) Как быстро нарисовать тень в заданном регионе?
procedure TForm2.DrawShadows(WDepth, HDepth : Integer); var Dst, RgnBox : TRect; hOldDC : HDC; OffScreen : TBitmap; Pattern : TBitmap; Bits : array[0..7] of WORD; begin Bits[0]:=$0055; Bits[1]:=$00aa; Bits[2]:=$0055; Bits[3]:=$00aa; Bits[4]:=$0055; Bits[5]:=$00aa; Bits[6]:=$0055; Bits[7]:=$00aa; hOldDC:=Canvas.Handle; Canvas.Handle:=GetWindowDC(Form1.Handle); OffsetRgn(ShadeRgn, WDepth, HDepth); GetRgnBox(ShadeRgn, RgnBox); Pattern:=TBitmap.Create; Pattern.ReleaseHandle; Pattern.Handle:=CreateBitmap(8, 8, 1, 1, @(Bits[0])); Canvas.Brush.Bitmap:=Pattern; OffScreen:=TBitmap.Create; OffScreen.Width:=RgnBox.Right-RgnBox.Left; OffScreen.Height:=RgnBox.Bottom-RgnBox.Top; Dst:=Rect(0, 0, OffScreen.Width, OffScreen.Height); OffsetRgn(ShadeRgn, 0, -RgnBox.Top); FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); OffsetRgn(ShadeRgn, 0, RgnBox.Top); // BitBlt работает быстрее CopyRect BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height, Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND); Canvas.Brush.Color:=clBlack; FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width, OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT); OffScreen.Free; Pattern.Free; OffsetRgn(ShadeRgn, -WDepth, -HDepth); ReleaseDC(Form1.Handle, Canvas.Handle); Canvas.Handle:=hOldDC; end; Комментарии : Функция рисует тень сложной формы на форме Form2. Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API. Титов Игорь Евгеньевич infos@obninsk.ru Как рисовать на органе управления, если свойство Canvas недоступно?
У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas. Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public. { Example. We recommend You to create this component through Component Wizard. In Delphi 1 it can be found as 'File|New Component...', and can be found as 'Component|New Component...' in Delphi 2 or above. } type TcPanel = class(TPanel) public property Canvas; end; Akzhan Abdulin (2:5040/55) Если у объекта нет свойства Canvas (у TDBEdit, вpоде-бы нет), по кpайней меpе в D3 можно использовать класс TControlCanvas. Пpимеpное использование: var cc: TControlCanvas; ... cc := TControlCanvas.Create; cc.Control := youControl; ... и далее как обычно можно использовать методы Canvas. Andrew Velikoredchanin (2:5026/29.3) Работа с изображением в памяти.
Вот кусок одного моего класса, в котором есть две интересные вещицы — проецирование файлов в память и работа с битмэпом в памяти через указатель. --------------------------------------------------------------------- type TarrRGBTriple=array[byte] of TRGBTriple; ParrRGBTriple=^TarrRGBTriple; {организует битмэп размером SX,SY;true_color} procedure TMBitmap.Allocate(SX,SY:integer); var DC:HDC; begin if BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был} BM:=0; PB:=nil; fillchar(BI,sizeof(BI),0); with BI.bmiHeader do {заполняем структуру с параметрами битмэпа} begin biSize:=sizeof(BI.bmiHeader); biWidth:=SX; biHeight:=SY; biPlanes:=1; biBitCount:=24; biCompression:=BI_RGB; biSizeImage:=0; biXPelsPerMeter:=0; biYPelsPerMeter:=0; biClrUsed:=0; biClrImportant:=0; FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)} if (biWidth or biHeight)<>0 then begin DC:=CreateDC('DISPLAY',nil,nil,nil); {замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле,
что позволяет ускорять работу и экономить память при генерировании большого битмэпа} BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0); DeleteDC(DC); {в PB получаем указатель на битмэп-----^^} if BM=0 then Error('error creating DIB'); end; end; end; {эта процедура загружает из файла true-color'ный битмэп} procedure TMBitmap.LoadFromFile(const FileName:string); var HF:integer; {file handle} HM:THandle; {file-mapping handle} PF:pchar; {pointer to file view in memory} i,j:integer; Ofs:integer; begin {открываем файл} HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite); if HF<0 then Error('open file '''+FileName+''''); try {создаем объект-проецируемый файл} HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil); if HM=0 then Error('can''t create file mapping'); try {собственно проецируем объект в адресное } PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0); {получаем указатель на область памяти, в которую спроецирован файл} if PF=nil then Error('can''t create map view of file'); try {работаем с файлом как с областью памяти через указатель PF} if PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format'); Ofs:=PBitmapFileHeader(PF)^.bfOffBits; with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do begin if (biSize<>40) or (biPlanes<>1) then Error('file format'); if (biCompression<>BI_RGB) or (biBitCount<>24) then Error('only true-color BMP supported'); {выделяем память под битмэп} Allocate(biWidth,biHeight); end; for j:=0 to BI.bmiHeader.biHeight-1 do for i:=0 to BI.bmiHeader.biWidth-1 do {Pixels — это property, возвр. указатель на соотв. RGBTriple в битмэпе} Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i]; finally UnmapViewOfFile(PF); end; finally CloseHandle(HM); end; finally FileClose(HF); end; end; {эта функция — реализация Pixels read} function TMBitmap.GetPixel(X,Y:integer):PRGB; begin if (X>=0) and (Xand (Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3) else Result:=PRGB(PB); end; ------------------------------------------------------------------ Если у вас на форме есть компонент TImage, то можно сделать так: var BMP:TMBitmap; B:TBitmap; ... BMP.LoadFromFile(..); B:=TBitmap.Create; B.Handle:=BMP.Handle; Image1.Picture.Bitmap:=B; и загруженный битмэп появится на экране. Alexander Burnashov E-mail alex@arta.spb.su (2:5030/254.36) Как преобразовать ICO в BMP?
var Icon : TIcon; Bitmap : TBitmap; begin Icon := TIcon.Create; Bitmap := TBitmap.Create; Icon.LoadFromFile('c:\picture.ico'); Bitmap.Width := Icon.Width; Bitmap.Height := Icon.Height; Bitmap.Canvas.Draw(0, 0, Icon ); Bitmap.SaveToFile('c:\picture.bmp'); Icon.Free; Bitmap.Free; end; Author>: Michael Vincze vincze@ti.com Как из HBitmap получить АДРЕС БИТМАПА В ПАМЯТИ ?
Вот кусок одного моего класса, в котором есть две интересные вещицы — проецирование файлов в память и работа с битмэпом в памяти через указатель. Сразу оговорюсь, что все это работает только Delphi 2 и Win95/NT. --------------------------------------------------------------------- type TarrRGBTriple=array[byte] of TRGBTriple; ParrRGBTriple=^TarrRGBTriple; {организует битмэп размером SX,SY;true_color} procedure TMBitmap.Allocate(SX,SY:integer); var DC:HDC; begin if BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был} BM:=0; PB:=nil; fillchar(BI,sizeof(BI),0); with BI.bmiHeader do {заполняем структуру с параметрами битмэпа} begin biSize:=sizeof(BI.bmiHeader); biWidth:=SX; biHeight:=SY; biPlanes:=1; biBitCount:=24; biCompression:=BI_RGB; biSizeImage:=0; biXPelsPerMeter:=0; biYPelsPerMeter:=0; biClrUsed:=0; biClrImportant:=0; FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)} if (biWidth or biHeight)<>0 then begin DC:=CreateDC('DISPLAY',nil,nil,nil); {замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле, что позволяет ускорять работу и экономить память при генерировании большого битмэпа} {!} BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0); DeleteDC(DC); {в PB получаем указатель на битмэп-----^^} if BM=0 then Error('error creating DIB'); end; end; end; {эта процедура загружает из файла true-color'ный битмэп} procedure TMBitmap.LoadFromFile(const FileName:string); var HF:integer; {file handle} HM:THandle; {file-mapping handle} PF:pchar; {pointer to file view in memory} i,j:integer; Ofs:integer; begin {открываем файл} HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite); if HF<0 then Error('open file '''+FileName+''''); try {создаем объект-проецируемый файл} HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil); if HM=0 then Error('can''t create file mapping'); try {собственно проецируем объект в адресное } PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0); {получаем указатель на область памяти, в которую спроецирован файл} if PF=nil then Error('can''t create map view of file'); try {работаем с файлом как с областью памяти через указатель PF} if PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format'); Ofs:=PBitmapFileHeader(PF)^.bfOffBits; with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do begin if (biSize<>40) or (biPlanes<>1) then Error('file format'); if (biCompression<>BI_RGB) or (biBitCount<>24) then Error('only true-color BMP supported'); {выделяем память под битмэп} Allocate(biWidth,biHeight); end; for j:=0 to BI.bmiHeader.biHeight-1 do for i:=0 to BI.bmiHeader.biWidth-1 do {Pixels — это property, возвр. указатель на соотв. RGBTriple в битмэпе} Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i]; finally UnmapViewOfFile(PF); end; finally CloseHandle(HM); end; finally FileClose(HF); end; end; {эта функция — реализация Pixels read} function TMBitmap.GetPixel(X,Y:integer):PRGB; begin if (X>=0) and (Xand (Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3) else Result:=PRGB(PB); end; ------------------------------------------------------------------ Если у вас на форме есть компонент TImage, то можно сделать так: var BMP:TMBitmap; B:TBitmap; ... BMP.LoadFromFile(..); B:=TBitmap.Create; B.Handle:=BMP.Handle; Image1.Picture.Bitmap:=B; и загруженный битмэп появится на экране. Alexander Burnashov E-mail alex@arta.spb.su (2:5030/254.36) Создание иконки из битового изображения
Answer: You must create two bitmaps, a mask bitmap (called the "AND" bitmap) and a image bitmap (called the XOR bitmap). You can pass the handles to the "AND" and "XOR" bitmaps to the Windows API function CreateIconIndirect() and use the returned icon handle in your application. Example: procedure TForm1.Button1Click(Sender: TObject); var IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap; XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon; begin {Get the icon size} IconSizeX := GetSystemMetrics(SM_CXICON); IconSizeY := GetSystemMetrics(SM_CYICON); {Create the "And" mask} AndMask := TBitmap.Create; AndMask.Monochrome := true; AndMask.Width := IconSizeX; AndMask.Height := IconSizeY; {Draw on the "And" mask} AndMask.Canvas.Brush.Color := clWhite; AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); AndMask.Canvas.Brush.Color := clBlack; AndMask.Canvas.Ellipse(4, 4, IconSizeX — 4, IconSizeY — 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); {Create the "XOr" mask} XOrMask := TBitmap.Create; XOrMask.Width := IconSizeX; XOrMask.Height := IconSizeY; {Draw on the "XOr" mask} XOrMask.Canvas.Brush.Color := ClBlack; XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); XOrMask.Canvas.Pen.Color := clRed; XOrMask.Canvas.Brush.Color := clRed; XOrMask.Canvas.Ellipse(4, 4, IconSizeX — 4, IconSizeY — 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); {Create a icon} Icon := TIcon.Create; IconInfo.fIcon := true; IconInfo.xHotspot := 0; IconInfo.yHotspot := 0; IconInfo.hbmMask := AndMask.Handle; IconInfo.hbmColor := XOrMask.Handle; Icon.Handle := CreateIconIndirect(IconInfo); {Destroy the temporary bitmaps} AndMask.Free; XOrMask.Free; {Draw as a test} Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); {Assign the application icon} Application.Icon := Icon; {Force a repaint} InvalidateRect(Application.Handle, nil, true); {Free the icon} Icon.Free; end; Преобразование цветного изображения в черно-белое
The following example shows how to convert an RGB color to the equivalent color of gray using the same method that a black and white television would render a color broadcast: function RgbToGray(RGBColor : TColor) : TColor; var Gray : byte; begin Gray := Round((0.30 * GetRValue(RGBColor)) + (0.59 * GetGValue(RGBColor)) + (0.11 * GetBValue(RGBColor ))); Result := RGB(Gray, Gray, Gray); end; procedure TForm1.FormCreate(Sender: TObject); begin Shape1.Brush.Color := RGB(255, 64, 64); Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color); end;Графические форматы Как работать с разными графическими форматами, кроме BMP?
Воспользуйтесь библиотекой ImageLib. Лежит на www.imagelib.com. Hа компакте с Delphi 3 в каталоге EXTRAS есть библиотека JPEG. Если сказать в модуле uses jpeg; то можно работать с .jpg как с TPicture. JPG в Visual C++ 5.0.
------------------- Start --------------------- IPictureDisp* picture; char buf[]="C:\MySuperPicture.jpg"; VARIANT variant; variant.vt = VT_BSTR; variant.bstrVal = SysAllocString(A2CW(buf)); HRESULT hRes = OleLoadPictureFile(variant,(IDispatch**)&picture); SysFreeString(variant.bstrVal); if(SUCCEEDED(hRes)) { long w,h; hRes = ((IPicture*)picture)->get_Width(&w); hRes = ((IPicture*)picture)->get_Height(&h); HDC hdc; ^^^^^^^^^ //как нибудь получаеш хендл контекста устройства hRes = ((IPicture*)picture)->Render(hdc,0,0,wid,hei,0,0,w,h,NULL); ^^^^^^^^^^^ ^^^^^^^^ // координаты в hdc ,а эти в picture picture->Release(); } ------------------- end ---------------------- GIF из RxLib 2.40
=== Cut === uses RxGIF; ... var GIFImage: tGIFImage; BMImage: tBitMap; ... GIFImage:=tGIFImage.Create; BMImage:=tBitMap.Create; ... GIFImage.LoadFromFile('чо-то'); BMImage.Assign(GIFImage); ... .Free; === Cut ===Другое Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)?
Пример: { В случае Panel1:TPanel — обработчик события OnMouseDown } procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); const SC_DragMove = $F012; { a magic number } begin ReleaseCapture; panel1.perform(WM_SysCommand, SC_DragMove, 0); end; Borland TI N2909 (перевод: Акжан Абдулин) Подскажите способ обмена информацией между приложениями Win32 — Win16.
Пользуйтесь сообщением WM_COPYDATA. Для Win16 константа определена как $004A, в Win32 смотрите в WinAPI Help. #define WM_COPYDATA 0x004A /* * lParam of WM_COPYDATA message points to... */ typedef struct tagCOPYDATASTRUCT { DWORD dwData; DWORD cbData; PVOID lpData; } COPYDATASTRUCT, *PCOPYDATASTRUCT; Alexey A Popoff(2:5020/487.26)pvax@glas.apc.org Как сказать VCL, чтобы клавиши shortcut пунктов главного меню главной формы действовали только в этой форме?
Лечится так: function WindowHook(var Message: TMessage): Boolean; procedure .FormCreate(Sender: TObject); begin // MainForm Application.HookMainWindow(WindowHook); function .WindowHook; begin Result := False; with Message do case Msg of CM_APPKEYDOWN{??????? ??????? .MainMenu ???????? ?? _????_ ??????. ?????!}, CM_APPSYSCOMMAND{????? .MainMenu ?? ?????? ????. ?????!}: Msg := WM_NULL; Александр Петросян, Зеленоград. (2:5020/468.8) Как задать в качестве фона MDIForm картинку из TBitmap?
Я делал так: type .... =class(TForm) .... procedure FormCreate(Sender:TObject); procedure FormDestroy(Sender:TObject); .... private FHBrush:HBRUSH; FCover:TBitmap; FNewClientInstance:TFarProc; FOldClientInstance:TFarProc; procedure NewClientWndProc(var Message:TMessage); .... protected .... procedure CreateWnd;override; .... end; ..... implementation {$R myRes.res} //pесуpс с битмапом фона procedure .FormCreate(...); var LogBrush:TLogbrush; begin FCover:=TBitmap.Create; FCover.LoadFromResourceName(hinstance,'BMPCOVER'); With LogBrush do begin lbStyle:=BS_PATTERN; lbHatch:=FCover.Handle; end; FHBrush:=CreateBrushIndirect(Logbrush); end; procedure .FormDestroy(...); begin DeleteObject(FHBrush); FCover.Free; end; procedure .CreateWnd; begin inherited CreateWnd; if (ClientHandle <> 0) then begin if NewStyleControls then SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or GetWindowLong(ClientHandle, GWL_EXSTYLE)); FNewClientInstance:=MakeObjectInstance(NewClientWndProc); FOldClientInstance:=pointer(GetWindowLong(ClientHandle,GWL_WNDPROC)); SetWindowLong(ClientHandle,GWL_WNDPROC,longint(FNewClientInstance)); end; end; procedure .NewClientWndProc(var Message:TMessage); procedure Default; begin with Message do Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg, wParam, lParam); end; begin with Message do case Msg of WM_ERASEBKGND: begin FillRect(TWMEraseBkGnd(Message).DC, ClientRect,FHBrush); Result := 1; end; else Default; end; end; end; Alex Miachin (2:5000/81.12) [Win32] Как вывести на экран путь файла с "красивым" обрезанием по длине?
DrawTextEx; dwDTFormat = DT_PATH_ELLIPSIS Pavel Victoroff (2:5030/219.2) Каким образом можно мзменить системное меню формы?
type TMyForm=class(TForm) procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND; end; const ID_ABOUT = WM_USER+1; ID_CALENDAR=WM_USER+2; ID_EDIT = WM_USER+3; ID_ANALIS = WM_USER+4; implementation procedure TMyForm.wmSysCommand; begin case Message.wParam of ID_CALENDAR:DatBitBtnClick(Self) ; ID_EDIT :EditBitBtnClick(Self); ID_ANALIS:AnalisButtonClick(Self); end; inherited; end; procedure TMyForm.FormCreate(Sender: TObject); var SysMenu:THandle; begin SysMenu:=GetSystemMenu(Handle,False); InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,''); InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Calendar'); InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analis'); InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edit'); end; Konstantin Suslov(2:5020/300.16) Размер рабочего стола.
1. объект screen 2. Width:=GetSystemMetrics(SM_CXFULLSCREEN); height:=GetSystemMetrics(SM_CYFULLSCREEN) { +GetSystemMetrics(SM_CYCAPTION)); это на случай если форма без строки заголовка} Эти вызовы чувствуют, когда ты прячешь тaскбaр или меняешь его размер. 3. SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0); — В R — свободнaя от тaскбaрa чaсть экрaнa. Как умертвить PC Speaker?
Это выключит спикеp: SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE); Это включит: SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE); Alexey Lesovik (2:5020/898.15) Как из программы переключать языки?
Здесь переключатели на русский и на английский. procedure SetRU; var Layout: array[0.. KL_NAMELENGTH] of char; begin LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE); end; procedure SetEN; var Layout: array[0.. KL_NAMELENGTH] of char; begin LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE); end; Anton Geleznyak (2:5000/106) Можно и так: var rus, lat: HKL; rus:=LoadKeyboardLayout('00000419', 0); lat:=LoadKeyboardLayout('00000409', 0); SetActiveKeyboardLayout(rus); Valentin Lavrinenko (2:463/566.110) Как удобнее работать с буфером обмена как последовательностью байт?
Используя потоки — === Cut === unit ClipStrm; { This unit is Copyright (c) Alexey Mahotkin 1997-1998 and may be used freely for any purpose. Please mail your comments to E-Mail: alexm@hsys.msk.ru FidoNet: Alexey Mahotkin, 2:5020/433 This unit was developed during incorporating of TP Lex/Yacc into my project. Please visit ftp://ftp.nf.ru/pub/alexm or FREQ FILES from 2:5020/433 or mail me to get hacked version of TP Lex/Yacc which works under Delphi 2.0+. } interface uses Classes, Windows; type TClipboardStream = class(TStream) private FMemory : pointer; FSize : longint; FPosition : longint; FFormat : word; public constructor Create(fmt : word); destructor Destroy; override; function Read(var Buffer; Count : Longint) : Longint; override; function Write(const Buffer; Count : Longint) : Longint; override; function Seek(Offset : Longint; Origin : Word) : Longint; override; end; implementation uses SysUtils; constructor TClipboardStream.Create(fmt : word); var tmp : pointer; FHandle : THandle; begin FFormat := fmt; OpenClipboard(0); FHandle := GetClipboardData(FFormat); FSize := GlobalSize(FHandle); FMemory := AllocMem(FSize); tmp := GlobalLock(FHandle); MoveMemory(FMemory, tmp, FSize); GlobalUnlock(FHandle); FPosition := 0; CloseClipboard; end; destructor TClipboardStream.Destroy; begin FreeMem(FMemory); end; function TClipboardStream.Read(var Buffer; Count : longint) : longint; begin if FPosition + Count > FSize then Result := FSize — FPosition else Result := Count; MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result); Inc(FPosition, Result); end; function TClipboardStream.Write(const Buffer; Count : longint) : longint; var FHandle : HGlobal; tmp : pointer; begin ReallocMem(FMemory, FPosition + Count); MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count); FPosition := FPosition + Count; FSize := FPosition; FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize); try tmp := GlobalLock(FHandle); try MoveMemory(tmp, FMemory, FSize); OpenClipboard(0); SetClipboardData(FFormat, FHandle); finally GlobalUnlock(FHandle); end; CloseClipboard; except GlobalFree(FHandle); end; Result := Count; end; function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint; begin case Origin of 0 : FPosition := Offset; 1 : Inc(FPosition, Offset); 2 : FPosition := FSize + Offset; end; Result := FPosition; end; end. === Cut === Alexey Mahotkin alexm@hsys.msk.ru (2:5020/433) Как изменить внешний вид хинтов (всплывающих подсказок)?
1. Создаем свой класс — потомок от THintWindow type TCustomHint = class (THintWindow) public constructor Create(AOwner: TComponent); override; end; Пpимечание 1. Этот способ не позволит изменить цвет шpифта — для этого пpидется пеpекpывать метод Paint; Пpимечание 2. Если пеpекpыть CreateParams, то можно, напpимеp, наpисовать Hint в фоpме облачка. Пpимечание 3. Для изменения цвета фона F1 TApplication.OnShowHint, HintInfo. 2. Меняем фонт: constructor TCustomHint.Create(AOwner: TComponent); begin inherited Create(AOwner); with Canvas.Font do // Именно так, а не пpосто Font! begin Name := 'Times New Roman Cyr'; Style := [fsBold, fsItalic]; Size := 40; end; end; 3. Устанавливаем новый хинт procedure TForm1.FormCreate(Sender: TObject); // Это может быть любой begin // обpаботчик HintWindowClass := TMyHint; // Устанавливаем глобальную пеpеменную Application.ShowHint := false; // Application.FHintWindow.Free Application.ShowHint := true; // Application.FHintWindow.Create end; Литеpатуpа: 1. <...>\Source\VCL\Forms.pas (TApplication). 2. <...>\Source\VCL\Controls.pas (THintWindow). 3. Delphi Help (OnShowHint, THintInfo). Dmitry Medved (2:464/58.7) Как проиграть Wave-ресурс?
Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV Компилишь чем-нибyдь в *.RES Далее в тексте: {$R полное_имя_файла_с_ресурсом} var WaveHandle : THandle; WavePointer : pointer; ... WaveHandle := FindResource(hInstance,'MY_WAV',RT_RCDATA); if WaveHandle<>0 then begin WaveHandle:= LoadResource(hInstance,WaveHandle); if WaveHandle<>0 then begin; WavePointer := LockResource(WaveHandle); PlayResourceWave := sndPlaySound(WavePointer,snd_Memory OR SND_ASYNC); UnlockResource(WaveHandle); FreeResource(WaveHandle); end; end; Serg Vostrikov (2:5053/15.3) Каким образом можно мзменить системное меню формы?
type TMyForm=class(TForm) procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND; end; const ID_ABOUT = WM_USER+1; ID_CALENDAR=WM_USER+2; ID_EDIT = WM_USER+3; ID_ANALIS = WM_USER+4; implementation procedure TMyForm.wmSysCommand; begin case Message.wParam of ID_CALENDAR:DatBitBtnClick(Self) ; ID_EDIT :EditBitBtnClick(Self); ID_ANALIS:AnalisButtonClick(Self); end; inherited; end; procedure TMyForm.FormCreate(Sender: TObject); var SysMenu:THandle; begin SysMenu:=GetSystemMenu(Handle,False); InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,''); InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Calendar'); InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analis'); InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edit'); end; Konstantin Suslov (2:5020/300.16) . Добавление пунктов в системное меню.
1.Create a new form. 2.Override the OnMessage event by assigning a new event handler procedure for the OnMessage event. 3.Create a constant that will be used as the ordinal identifier for your menu choice. 4.In the FormCreate, make your menu choice with the AppendMenu API call. Here's the code to show you how to do it: unit sysmenu; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } public {This declaration is of the type TMessageEvent which is a pointer to a procedure that takes two variable arguments of type TMsg and Boolean, respectively} procedure WinMsgHandler(var Msg : TMsg; var Handled : Boolean); end; var Form1: TForm1; const MyItem = 100; {Here's the menu identifier. It can be any WORD value} implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin {First, tell the application that its message handler is different from the default} Application.OnMessage := WinMsgHandler; {Add a separator} AppendMenu(GetSystemMenu(Self.Handle, False), MF_SEPARATOR, 0, ''); {Add your menu choice. Since the Item ID is high, using the MF_BYPOSITION constant will place it last on the system menu} AppendMenu(GetSystemMenu(Self.Handle, False), MF_BYPOSITION, MyItem, 'My Men&u Choice'); end; procedure TForm1.WinMsgHandler(var Msg : TMsg; var Handled : Boolean); begin if Msg.Message=WM_SYSCOMMAND then {if the message is a system one...} if Msg.wParam = MyItem then {Put handling code here. I've opted for a ShowMessage for demonstration purposes} ShowMessage('You picked my menu!!!'); end; end. As you can see, this is fairly straight-forward. Granted, the tip is not very complicated.
However, it does open up many doors to things you can do. In anticipation of some questions you might have later,
The AppendMenu command can also be used with minimized apps. For instance,
if you minimize your app, the icon represents the application, not your form.
Therefore in order to make the system menu with your changes visible
when in minimized form you would use Application.Handle instead of
Self.Handle to deal with the application's system menu. Поиск запущенной копии вашей программы.
A while ago, I put up a tip here that checked for the previous instance of an application. If it found an instance of an app already running, it brought it to the foreground, then closed the currently executing instance. This was a useful function to have to make sure that you only have one instance of your program running at any time. This functionality was accomplished by the code below. I won't go into the particular details, but in case you've never seen this code or a variation of it, then all you do is save this code to a unit file called PREVINST.PAS, then put the PREVINST.PAS file in your uses statement, call GotoPreviousInstance in your FormCreate method (make sure it's the main form), and it'll check to see if you've got another instance currently running. Here's the code: {====================================================================== PREVINST.PAS — Prevents a second instance of the program from running. Called from the program's project file. ======================================================================} unit Previnst; interface uses WinTypes, WinProcs, SysUtils; type PHWND = ^HWND; function EnumFunc(Wnd: HWND; TargetWindow: PHWND): Bool; export; procedure GotoPreviousInstance; implementation function EnumFunc(Wnd:HWND; TargetWindow: PHWND): Bool; var ClassName: Array[0..30] of Char; begin Result := TRUE; if GetWindowWord(Wnd,GWW_HINSTANCE) = hPrevInst then begin GetClassName(Wnd,ClassName,30); if StrIComp(ClassName,'TApplication') = 0 then begin TargetWindow^ := Wnd; Result := FALSE; end; end; end; procedure GotoPreviousInstance; var PrevInstWnd: HWnd; begin PrevInstWnd := 0; EnumWindows(@EnumFunc,LongInt(@PrevInstWnd)); if PrevInstWnd <> 0 then if IsIconic(PrevInstWnd) then ShowWindow(PrevInstWnd,SW_RESTORE) else BringWindowToTop(PrevInstWnd); end; end. Unfortunately, this code doesn't work with Delphi 2.0 programs!!! Why? Well it has to do with the various WinAPI calls made here. These calls are specific to the Win16 kernel, which assumes a single resource and tasking area. With WinNT and Win95, this isn't the case (well... it's still somewhat true in Win95). You're dealing with multiple threads and processes in these environments, so you can't assume that you have access to the same memory spaces. In fact, you don't. Not at all. So, how do you get around this? Well, after playing around a bit, I came up with an answer, and it's an even simpler method than the above. If you've followed my tips in the past, you might have come to realize that I don't just like to talk about coding, I really like to focus on programming concepts. In other words, why the heck do you do these things anyway?!!! And the technique I used here is something every programmer worth his or her salt should know about because there will be some instances where you'll need to apply this concept. What is it? It's a semaphore. The dictionary defines a semaphore as any mechanical signalling device. Traditionally, sempaphores were used in ship to ship signalling with two flags; each held at specific positions to denote a specific communication concept like, Get the hell out of here!!! In a general programming sense, semaphores are typically used as markers to denote the state of a program. In database programs, semaphores are widely used to keep track of the locking state of tables. In a network OS, semaphores are used to keep track of the state of shared resources. So what exactly are semaphores? Semaphores are either files or named addresses in memory whose presence or absence act as a binary identifier outside the context of a program's scope. What does this mean? Essentially, a semaphore is a boolean flag that a program can use to gain information about its state. The condition a program checks for is true if the semaphore exists; false if the semaphore doesn't exist. I mentioned above that the semaphore exists out of the context of the program. This is mostly true. It still has some context, otherwise a program would never be able to see it. However, with multiprocess/multithreading applications, semaphors play an important role because they allow different processes and threads to check the state of threads outside their scope. With respect to finding a previous instance of an application, a semaphore is vital. Why? Well, every time you start up a program in WinNT or Win95, a new process and its associated thread are spawned. Threads are mutually exclusive and occupy their own memory space (the whole idea behind protected mode memory). Unlike Win16 programs, threads cannot step on or access the memory space of other threads (well, not unless you tell them to). Therefore, the first example of enumerating open windows will not work because those functions rely on a shared resource stack. Sorry folks, it don't exist here in the land of NT. So what to do? Use a semaphore!!! With a semaphore, you create kind of a silent object that any program can look at. For our purposes, when our program sees the semaphor, it shuts itself down. It's as simple as that! I know what you're thinking... why all the verbage for just a simple thing? You'll be even more convinced of that when you see how small the function really is. However, this function is just the tip of the proverbial iceberg. I'm using a semaphore in only a single context. Once you familiarize yourself with this code, I'm sure you'll find other ways to employ semaphores. Okay, enough now... here's the code: {=================================================================================== This is a different twist on finding a previous instance of an application in a 32-bit environment. It uses a semaphore (although you could also use a mutex object) instead of performing an EnumWindows to find a previous instance, like you would have done in a 16-bit environment. This is more in line with multi-threaded app design. ===================================================================================} function DoIExist(WndTitle : String) : Boolean; var hSem : THandle; hWndMe, hWndPrev : HWnd; semNm, wTtl : Array[0..256] of Char; begin Result := False; //Copy the Pascal strings into the Arrays of Char; StrPCopy(semNm, 'SemaphoreName'); StrPCopy(wTtl, WndTitle); //Create a Semaphore in memory hSem := CreateSemaphore(nil, 0, 1, semNm); //Now, check to see if the semaphore exists if ((hSem <> 0) AND (GetLastError() = ERROR_ALREADY_EXISTS)) then begin CloseHandle(hSem); //We'll first get the currently executing window's handle then change its title //so we can look for the other instance hWndMe := FindWindow(nil, wTtl); SetWindowText(hWndMe, 'zzzzzzz'); //What we want to do now is search for the other instance of this window //then bring it to the top of the Z-order stack. hWndMe := FindWindow(nil, wTtl); if (hWndMe <> 0) then begin if IsIconic(hWndMe) then ShowWindow(hWndMe, SW_SHOWNORMAL) else SetForegroundWindow(hWndMe); end; Result := True; //Could put the Halt here, instead of in the FormCreate method, //unless you want to do some extra processing. //Halt; end; end; //This is how you'd call it. procedure TForm1.FormCreate(Sender: TObject); begin if DoIExist(Self.Caption) then Halt; end; Форма отображения величин в окне "Watch List".
Такой эффект можно достичь используя следующие спецификации формата отображения (практически совпадающие с BP 7.0),
которые указываются через запятую после идентификатора инспектируемой величины: Символ Применяется к типу Функциональность H или X Integers Отображает целые величины в 16-ричном формате с префиксом 0x C Char,strings Показывает специальные символы (ASCII 0..31). По умолчанию они отображаются в виде esc-последовательности (/n , /t , и т.п.) D Integers Отображает целые величины в десятичном формате. Fn Floating point Показывает n десятичных знаков (где n = 2..18, по умолчанию 7 ) nM All Дамп памяти, где n задает количество отображаемых байт памяти, начиная с
адреса величины. По умолчанию каждый байт представляется двумя 16-ричными
цифрами, но возможно также совместное использование nM с другими
форматами. P Pointers Отображает величину, как указатель в формате seg:ofs. R Records,classes,objects Показывает не только величины полей, но и сами поля, напрмер, как (X:2; Y:5) вместо (2, 5). S Char,strings Показывает любые неотображаемые ASCII символы в виде #nn. Используется вместе с nM. Как работать с плагинами ?
Я сделал так — выбираю все DLL из каталога с программой, загружаю каждую и пытаюсь найти в ней функцию (через API GetProcAddress) с заранее определенным жестко именем (например что нибудь типа IsPluginForMyStuff). Если нашлась — DLL считается моим плагином, если нет — выгрузить и забыть. А набор вызываемых функций по идее одинаков у всех плагинов, и программа (основная) в курсе какие именно функции она ищет в DLL. Если даже и не так, то ничего не мешает тебе определить в плагине функцию наподобие GetFeatures, возвращающую список строк-названий поддержанных плагином процедур. Вот часть моего кода по работе с плагинами... ================= ... type // Процедурные типы для хранения ссылок на функции плагинов TGetNProc=function:shortstring; TGetSProc=function:integer; TProcessProc=procedure(config:pointer; request:PRequest; var reply:PReply); TConfigProc=procedure(defcfg:PSysConfig; var config:pointer); TSaveLoadProc=procedure(inifile:pointer; var config:pointer); // Информация об отдельном плагине TPlugin=record Name:shortstring; // Полное название Filename:shortstring; // Имя файла Handle:integer; // Хэндл загруженной DLL CFGSize:integer; // Размер конфигурации в RAM ProcessProc: TProcessProc; // Адрес процедуры обработки ConfigProc: TConfigProc; // Адрес процедуры настройки LoadCFG,SaveCFG:TSaveLoadProc; // Адреса процедур чтения/записи cfg end; PPlugin=^TPlugin; // Список загруженных плагинов TPlugins=class(TList); ... var Plugins:TPlugins; sr:TSearchRec; lib:integer; pgetn:TGetNProc; pgets: TGetSProc; plugin:PPlugin; ... // Читаем плагины и создаем их список. Plugins:=TPlugins.Create; if FindFirst('*.dll',faAnyFile,sr)<>0 then begin ShowMessage('Hе найдено подключаемых модулей.'); Close; end; repeat lib:=LoadLibrary(PChar(sr.Name)); if lib<>0 then begin @pgetn:=GetProcAddress(lib, 'GetPluginName'); if @pgetn=nil then FreeLibrary(lib) // Hе плагин else begin New(plugin); @pgets:=GetProcAddress(lib, 'GetCFGSize'); plugin.Name:=pgetn; plugin.Filename:=sr.Name; plugin.CFGSize:=pgets; plugin.Handle:=lib; plugin.ConfigProc:=GetProcAddress(lib, 'Configure'); plugin.ProcessProc:=GetProcAddress(lib, 'Process'); plugin.SaveCFG:=GetProcAddress(lib, 'SaveCFG'); plugin.LoadCFG:=GetProcAddress(lib, 'LoadCFG'); Plugins.Add(plugin); end; end; until FindNext(sr)<>0; FindClose(sr); ... Имитация ввода с клавиатуры для программы выполняющейся в дос-окне?
const ExtendedKeys: set of Byte = [ // incomplete list VK_INSERT, VK_DELETE, VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_LEFT, VK_UP, VK_RIGHT, VK_DOWN, VK_NUMLOCK ]; procedure SimulateKeyDown(Key : byte); var flags: DWORD; begin if Key in ExtendedKeys then flags := KEYEVENTF_EXTENDEDKEY else flags := 0; keybd_event(Key, MapVirtualKey(Key, 0), flags, 0); end; procedure SimulateKeyUp(Key : byte); var flags: DWORD; begin if Key in ExtendedKeys then flags := KEYEVENTF_EXTENDEDKEY else flags := 0; keybd_event(Key, MapVirtualKey(Key, 0), KEYEVENTF_KEYUP or flags, 0); end; procedure SimulateKeystroke(Key : byte); var flags: DWORD; scancode: BYTE; begin if Key in ExtendedKeys then flags := KEYEVENTF_EXTENDEDKEY else flags := 0; scancode := MapVirtualKey(Key, 0); keybd_event(Key, scancode, flags, 0); keybd_event(Key, scancode, KEYEVENTF_KEYUP or flags, 0); end; Как получить результат работы консольной программы ?
Hужно использовать пайпы (CreatePipe), и работать с ними как с обычным файлом. const H_IN_READ = 1; H_IN_WRITE = 2; H_OUT_READ = 3; H_OUT_WRITE = 4; H_ERR_READ = 5; H_ERR_WRITE = 6; type TPipeHandles = array [1..6] of THandle; var hPipes: TPipeHandles; ProcessInfo: TProcessInformation; (************************************************************** CREATE HIDDEN CONSOLE PROCESS **************************************************************) function CreateHiddenConsoleProcess(szChildName: string; ProcPriority: DWORD; ThreadPriority: integer): Boolean; label error; var fCreated: Boolean; si: TStartupInfo; sa: TSecurityAttributes; begin // Initialize handles hPipes[ H_IN_READ ] := INVALID_HANDLE_VALUE; hPipes[ H_IN_WRITE ] := INVALID_HANDLE_VALUE; hPipes[ H_OUT_READ ] := INVALID_HANDLE_VALUE; hPipes[ H_OUT_WRITE ] := INVALID_HANDLE_VALUE; hPipes[ H_ERR_READ ] := INVALID_HANDLE_VALUE; hPipes[ H_ERR_WRITE ] := INVALID_HANDLE_VALUE; ProcessInfo.hProcess := INVALID_HANDLE_VALUE; ProcessInfo.hThread := INVALID_HANDLE_VALUE; // Create pipes // initialize security attributes for handle inheritance (for WinNT) sa.nLength := sizeof(sa); sa.bInheritHandle := TRUE; sa.lpSecurityDescriptor := nil; // create STDIN pipe if not CreatePipe( hPipes[ H_IN_READ ], hPipes[ H_IN_WRITE ], @sa, 0 ) then goto error; // create STDOUT pipe if not CreatePipe( hPipes[ H_OUT_READ ], hPipes[ H_OUT_WRITE ], @sa, 0 ) then goto error; // create STDERR pipe if not CreatePipe( hPipes[ H_ERR_READ ], hPipes[ H_ERR_WRITE ], @sa, 0 ) then goto error; // process startup information ZeroMemory(Pointer(@si), sizeof(si)); si.cb := sizeof(si); si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; si.wShowWindow := SW_HIDE; // assign "other" sides of pipes si.hStdInput := hPipes[ H_IN_READ ]; si.hStdOutput := hPipes[ H_OUT_WRITE ]; si.hStdError := hPipes[ H_ERR_WRITE ]; // Create a child process try fCreated := CreateProcess( nil, PChar(szChildName), nil, nil, True, ProcPriority, // CREATE_SUSPENDED, nil, nil, si, ProcessInfo ); except fCreated := False; end; if not fCreated then goto error; Result := True; CloseHandle(hPipes[ H_OUT_WRITE ]); CloseHandle(hPipes[ H_ERR_WRITE ]); // ResumeThread( pi.hThread ); SetThreadPriority(ProcessInfo.hThread, ThreadPriority); CloseHandle( ProcessInfo.hThread ); Exit; //----------------------------------------------------- error: ClosePipes( hPipes ); CloseHandle( ProcessInfo.hProcess ); CloseHandle( ProcessInfo.hThread ); ProcessInfo.hProcess := INVALID_HANDLE_VALUE; ProcessInfo.hThread := INVALID_HANDLE_VALUE; Result := False; end;Алгоритмы Как считать CRC-32 ?
unit ChkSumm; interface const CRC32INIT = $FFFFFFFF; {----------------------------------------------------------------} { Buffer — массив байтов, для которого подсчитывается CRC } { CRC — начальное значение CRC } { Count — длина буфера } {----------------------------------------------------------------} function CalculateBufferCRC32( CRC : Cardinal; const Buffer; Count : Cardinal ) : Cardinal; register; {----------------------------------------------------------------} { Расчет 32-битовой CRC, алгоритм аналогичен применяемому в } { архиваторах ZIP, ARJ. При этом начальное значение CRC должно } { быть равно CRC32INIT, а после окончания подсчета окончательная } { CRC вычисляется по формуле : } { CRC := CRC xor CRC32INIT; } { Hапример : } { var } { Buffer : array[1..8192] of Char; } { CRC : Cardinal; } { Count : Cardinal; } { ....... } { CRC := CRC32INIT; } { repeat } { BlockRead(F, Buffer, SizeOf( Buffer ), Count); } { CRC := CalculateBufferCRC32( CRC, Buffer, Count ); } { until Eof(F); } { CRC := CRC xor CRC32INIT; } { ....... } {----------------------------------------------------------------} implementation const CRC32Table : array[0..255] of Cardinal = ( $00000000, $77073096, $EE0E612C, $990951BA, $076DC419, $706AF48F, $E963A535, $9E6495A3, $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, $76DC4190, $01DB7106, $98D220BC, $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, $7807C9A2, $0F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F, $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683, $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7, $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F, $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, $9B64C2B0, $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713, $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB, $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF, $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D ); function CalculateBufferCRC32( CRC : Cardinal; const Buffer; Count : Cardinal ) : Cardinal; assembler; asm PUSH ESI PUSH EDI MOV ESI, Buffer // MOV ECX, Count // uncomment these strings // MOV EAX, CRC // if not use REGISTER calling convention CLD @@Loop: MOV EDI, EAX // copy CRC into DI LODSB // load next byte into AL XOR EDI, EAX // put array index into DL SHR EAX, 8 // shift CRC one byte right SHL DI, 2 // correct DI XOR EAX, DWORD PTR CRC32Table[EDI] // calculate next CRC value LOOP @@Loop POP EDI POP ESI end; end. Преобразование сумм в выражения прописью.
Предлагается 3 варианта. ================== unit NToText; interface { Функция NumToText возвращает словесное выражение для суммы CurrValue. Если CurrWord=true, то добавляется слово "рубль" в соотв. склонении. Если IfKopeck=true и CurrWord=true, то в выражении учитываются копейки, если CurrWord=false, копейки не учитываются при любом IfKopeck.} function NumToText(CurrValue:Currency; CurrWord:boolean; IfKopeck:boolean):string; implementation uses SysUtils; function NumToText(CurrValue:Currency; CurrWord:boolean; IfKopeck:boolean):string; function GetNumInPos(CurrValue:Currency; PosNum: Integer):Integer; var tmpstr,tmpint,tmpfrac:string; pospoint:integer; begin Result:=0; tmpstr:=CurrToStr(CurrValue); pospoint:=Pos('.',tmpstr); if PosNum>0 then begin if pospoint>0 then tmpint:=Copy(tmpstr,1,pospoint-1) else tmpint:=tmpstr; if PosNum>Length(tmpint) then exit; Result:=StrToInt(Copy(tmpint,Length(tmpint)-PosNum+1,1)); end; if PosNum<0 then begin if pospoint>0 then tmpfrac:=Copy(tmpstr,pospoint+1,Length(tmpstr)-pospoint) else tmpfrac:='00'; if Length(tmpfrac)<(-PosNum) then exit; Result:=StrToInt(Copy(tmpfrac,-PosNum,1)); end; end; function GetKopeck(CurrValue:Currency):string; var Dig1,Dig2:Integer; KWord:string; begin Dig1:=GetNumInPos(CurrValue,-1); Dig2:=GetNumInPos(CurrValue,-2); case Dig2 of 0,5..9:KWord:='копеек'; 1:KWord:='копейка'; 2..4:KWord:='копейки'; end; Result:=' '+IntToStr(Dig1)+IntToStr(Dig2)+' '+KWord; end; function GetOneVal(CurrValue:Currency;CathNum:Integer):integer; begin Result:=StrToInt(IntToStr(GetNumInPos(CurrValue,CathNum*3)) +IntToStr(GetNumInPos(CurrValue,CathNum*3-1)) +IntToStr(GetNumInPos(CurrValue,CathNum*3-2))); Result:=Result-1+1; end; function OneCathegory(OneVal,CathNum:Integer):string; function Cath000(Val000:Integer):string; begin result:=''; case Val000 of 1: result:='сто '; 2: result:='двести '; 3: result:='триста '; 4: result:='четыреста '; 5: result:='пятьсот '; 6: result:='шестьсот '; 7: result:='семьсот '; 8: result:='восемьсот '; 9: result:='девятьсот '; end; end; function Cath_00(Val_00:Integer):string; begin result:=''; case Val_00 of 1: result:='десять '; 2: result:='двадцать '; 3: result:='тридцать '; 4: result:='сорок '; 5: result:='пятьдесят '; 6: result:='шестьдесят '; 7: result:='семьдесят '; 8: result:='восемьдесят '; 9: result:='девяносто '; end; end; function Cath__0(Val__0:Integer; IfThousand:boolean):string; begin result:=''; case Val__0 of 1: if IfThousand then result:='одна ' else result:='один '; 2: if IfThousand then result:='две ' else result:='два '; 3: result:='три '; 4: result:='четыре '; 5: result:='пять '; 6: result:='шесть '; 7: result:='семь '; 8: result:='восемь '; 9: result:='девять '; end; end; begin result:=''; if OneVal=0 then exit; result:=Cath000(OneVal div 100)+Cath_00((OneVal mod 100) div 10)+Cath__0(OneVal mod 10,(CathNum=2)); end; function GetWord(OneVal,CathNum:Integer;CurrWord:boolean):string; var OneDigit:0..9; begin result:=''; OneDigit:=OneVal mod 10; if ((CathNum=1) and (not CurrWord)) then exit; if ((OneVal=0) and (CathNum<>1)) then exit; case CathNum of 1:case OneDigit of 0,5..9:result:='рублей '; 1:result:='рубль '; 2..4:result:='рубля '; end; 2:case OneDigit of 0,5..9:result:='тысяч '; 1:result:='тысяча '; 2..4:result:='тысячи '; end; 3:case OneDigit of 0,5..9:result:='миллионов '; 1:result:='миллион '; 2..4:result:='миллиона '; end; 4:case OneDigit of 0,5..9:result:='миллиардов '; 1:result:='миллиард '; 2..4:result:='миллиарда '; end; 5:case OneDigit of 0,5..9:result:='триллионов '; 1:result:='триллион '; 2..4:result:='триллиона '; end; end; end; var CathNum:1..5; OneVal:0..999; tmpstr:string; begin result:=''; if CurrValue<0 then begin raise Exception.Create('Отрицательное значение!'); Exit; end; if CurrValue=0 then exit; if ((CurrValue<1.0) and (not IfKopeck)) then exit; for CathNum:=5 downto 1 do begin OneVal:=GetOneVal(CurrValue,CathNum); result:=result+OneCathegory(OneVal,CathNum)+GetWord(OneVal,CathNum,CurrWord); end; result:=trim(result); if ((CurrValue<1.0) and CurrWord and IfKopeck) then result:='Ноль '+result; if result<>'' then begin tmpstr:=AnsiUpperCase(Copy(result,1,1)); result[1]:=tmpstr[1]; end; if (CurrWord and IfKopeck) then Result:=Result+GetKopeck(CurrValue); end; end. =========================== unit Numinwrd; interface function sMoneyInWords( Nin: double ): string; export; function szMoneyInWords( Nin: double ): PChar; export; { Денежная сумма Nin в рублях и копейках прописью 1997, в.2.0, by О.В.Болдырев} implementation uses SysUtils,Dialogs,Math; type tri=string[4]; mood=1..2; gender=(m,f); uns =array[0..9] of string[7]; tns =array[0..9] of string[13]; decs=array[0..9] of string[12]; huns=array[0..9] of string[10]; nums=array[0..4] of string[8]; money=array[1..2] of string[5]; endings=array[gender,mood,1..3] of tri;{окончания числительных и денег} const units:uns =('','один ','два ','три ','четыре ','пять ', 'шесть ','семь ','восемь ','девять '); unitsf:uns=('','одна ','две ','три ','четыре ','пять ', 'шесть ','семь ','восемь ','девять '); teens:tns= ('десять ','одиннадцать ','двенадцать ','тринадцать ', 'четырнадцать ','пятнадцать ','шестнадцать ', 'семнадцать ','восемнадцать ','девятнадцать '); decades:decs=('','десять ','двадцать ','тридцать ','сорок ', 'пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ', 'девяносто '); hundreds:huns=('','сто ','двести ','триста ','четыреста ', 'пятьсот ','шестьсот ','семьсот ','восемьсот ', 'девятьсот '); numericals:nums=('','тысяч','миллион','миллиард','триллион'); RusMon:money=('рубл','копе'); ends:endings=((('','а','ов'),('ь','я','ей')), (('а','и',''),('йка','йки','ек'))); threadvar str: string; function EndingIndex(Arg: integer): integer; begin if ((Arg div 10) mod 10) <> 1 then case (Arg mod 10) of 1: Result := 1; 2..4: Result := 2; else Result := 3; end else Result := 3; end; function sMoneyInWords( Nin: double ): string; { Число Nin прописью, как функция } var g: gender; //род Nr: comp; {целая часть числа} Fr: integer; {дробная часть числа} i,iTri,Order: longint; {триада} procedure Triad; var iTri2: integer; un, de, ce :byte; //единицы, десятки, сотни function GetDigit: byte; begin Result := iTri2 mod 10; iTri2 := iTri2 div 10; end; begin iTri := trunc(Nr/IntPower(1000,i)); Nr := Nr — int( iTri*IntPower(1000,i)); iTri2:=iTri; if iTri > 0 then begin un := GetDigit; de := GetDigit; ce := GetDigit; if i=1 then g:=f else g:=m; {женского рода только тысяча} str := TrimRight(str)+' '+Hundreds[ce]; if de = 1 then str := TrimRight(str)+' '+Teens[un] else begin str := TrimRight(str)+' '+Decades[de]; case g of m: str := TrimRight(str)+' '+Units[un]; f: str := TrimRight(str)+' '+UnitsF[un]; end; end; if length(numericals[i]) > 1 then begin str := TrimRight(str)+' '+numericals[i]; str := TrimRight(str)+ends[g,1,EndingIndex(iTri)]; end; end; //triad is 0 ? if i=0 then Exit; Dec(i); Triad; end; begin str := ''; Nr := int( Nin ); Fr := round(100*frac(Nin)+0.0000001); Order := trunc(Log10(Nr)/3); if Order > High(numericals) then raise Exception.Create('Слишком большое число для суммы прописью'); i:= Order; Triad; str := Format('%s %s%s %.2d %s%s', [Trim(str),RusMon[1],ends[m,2,EndingIndex(iTri)], Fr, RusMon[2],ends[f,2,EndingIndex(Fr)]]); str[1] := (ANSIUpperCase(copy(str,1,1)))[1]; str[Length(str)+1] := #0; Result := str; end; function szMoneyInWords( Nin: double ): PChar; begin sMoneyInWords(Nin); Result := @(str[1]); end; end. ======================== unit uSpecLib; //Copyright Zhitomirsky Mark, 1990-1997, Saratov //------------------- Russian version interface const DigNames : array[0..9,boolean,-1..4 ] of string = ({0}(('копеек','рублей ','тысяч ','миллионов ','миллиардов ','триллионов '), ('копеек','рублей ','тысяч ','миллионов ','миллиардов ','триллионов ')), {1}(('одна копейка','один рубль ','одна тысяча ','один миллион ','один миллиард ','один триллион '), ('одиннадцать копеек','одиннадцать рублей ','одиннадцать тысяч ','одиннадцать миллионов ','одиннадцать миллиардов ','одиннадцать триллионов' )), {2}(('две копейки','два рубля ','две тысячи ','два миллиона ','два миллиарда ','два триллиона '), ('двенадцать копеек','двенадцать рублей ','двенадцать тысяч ','двенадцать миллионов ','двенадцать миллиардов ','двенадцать триллионов ')), {3}(('три копейки','три рубля ','три тысячи ','три миллиона ','три миллиарда ','три триллиона '), ('тринадцать копеек','тринадцать рублей ','тринадцать тысяч ','тринадцать миллионов ','тринадцать миллиардов ','тринадцать триллионов ')), {4}(('четыре копейки','четыре рубля ','четыре тысячи ','четыре миллиона ','четыре миллиарда ','четыре триллиона '), ('четырнадцать копеек','четырнадцать рублей ','четырнадцать тысяч ','четырнадцать миллионов ','четырнадцать миллиардов ','четырнадцать триллионов ')), {5}(('пять копеек','пять рублей ','пять тысяч ','пять миллионов ','пять миллиардов ','пять триллионов '), ('пятнадцать копеек','пятнадцать рублей ','пятнадцать тысяч ','пятнадцать миллионов ','пятнадцать миллиардов ','пятнадцать триллионов ')), {6}(('шесть копеек','шесть рублей ','шесть тысяч ','шесть миллионов ','шесть миллиардов ','шесть триллионов '), ('шестнадцать копеек','шестнадцать рублей ','шестнадцать тысяч ','шестнадцать миллионов ','шестнадцать миллиардов ','шестнадцать триллионов ')), {7}(('семь копеек','семь рублей ','семь тысяч ','семь миллионов ','семь миллиардов ','семь триллионов '), ('семнадцать копеек','семнадцать рублей ','семнадцать тысяч ','семнадцать миллионов ','семнадцать миллиардов ','семнадцать триллионов ')), {8}(('восемь копеек','восемь рублей ','восемь тысяч ','восемь миллионов ','восемь миллиардов ','восемь триллионов '), ('восемнадцать копеек','восемнадцать рублей ','восемнадцать тысяч ','восемнадцать миллионов ','восемнадцать миллиардов ','восемнадцать триллионов ')), {9}(('девять копеек','девять рублей ','девять тысяч ','девять миллионов ','девять миллиардов ','девять триллионов '), ('девятнадцать копеек','девятнадцать рублей ','девятнадцать тысяч ','девятнадцать миллионов ','девятнадцать миллиардов ','девятнадцать триллионов '))); {0 — ед, 1 -тыс, 2 — млн, 3 — млрд, 4 — трл} DigNames999 : array[0..9,1..2] of string = ({0}('',''), {1}('десять ','сто '), {2}('двадцать ','двести '), {3}('тридцать ','триста '), {4}('сорок ','четыреста '), {5}('пятьдесят ','пятьсот '), {6}('шестьдесят ','шестьсот '), {7}('семьдесят ','семьсот '), {8}('восемьдесят ','восемьсот '), {9}('девяносто ','девятьсот ')); {1 -дес, 2 — сот} type TCentsType=(ctNone,ctDigit,ctSentence); function NumericToSentence(numeric: currency; CentsType: TCentsType):string; implementation uses SysUtils; function CurrInt(Curr: Currency): Currency; var ss:string; begin ss:=CurrToStrF(Curr,ffFixed,4); delete(ss,length(ss)-4,5); result:=StrToCurr(ss); end; function CurrFrac(Curr: Currency): integer; var ss:string; begin ss:=CurrToStrF(Curr,ffFixed,4); delete(ss,1,length(ss)-4); result:=StrToInt(ss); end; function GetRankGroup(Curr: Currency; RankGroupNo: shortint): integer; var i: integer; begin if RankGroupNo=-1 then result:=trunc(CurrFrac(Curr)/100) else begin for i:=0 to RankGroupNo do begin Curr:=CurrInt(Curr); Curr:=Curr/1000; end; result:=trunc(CurrFrac(Curr)/10); end; end; function NumericToSentence; var RankGroup,Dig0, Dig1, Dig2,Cents: integer; rank,rank0: shortint; begin result:=''; Cents:=CurrFrac(numeric) div 100; if CentsType=ctSentence then rank0:=-1 else rank0:=0; if CurrInt(numeric)>0 then for rank:=rank0 to 4 do begin RankGroup:=trunc(GetRankGroup(numeric,rank)); Dig0:=RankGroup mod 10; Dig1:=(RankGroup mod 100 — Dig0) div 10; Dig2:=(RankGroup mod 1000 — Dig1) div 100; if (RankGroup>0) or (rank=0) then result:=Trim(DigNames999[Dig2,2]+ DigNames999[Dig1*integer((Dig1<>1)or(Dig0=0)),1]+ DigNames[Dig0,Dig1=1,rank]+result); end else begin result:='Ноль рублей'; end; if (CentsType=ctSentence) and (Cents=0) then result:=result+' ноль копеек'; if CentsType=ctDigit then result:=trim(result+' '+IntToStr(Cents)+' коп'); if length(result)>0 then result:=AnsiUpperCase(copy(result,1,1))+ copy(result,2,length(result)-1); result:=result+'.'; end; end.Bugs Const из другого unit'а дает неверное значение.
DX.Bug: Const из другого unit'а дает неверное значение. Unit Main; | Unit VData; | ... Interface | Implementation | Uses VData; | Uses Main; | Const Wko=0.9; | Procedure ...; | Begin ... | { вот здесь Wko=...E+230 — наверное бесконечность } | End; | Похоже, это действительно bug, пpичем ОСОБО ОПАСHЫЙ, т.к. может исказить pезультаты pасчетов, не вызвав заметных наpушений pаботы пpогpаммы. В общем так. Экспеpимент показал, что любая вещественная константа, опpеделенная в интеpфейсе модуля, может быть невеpно (и не обязательно очень невеpно — напpимеp, вместо 0.7 может появиться 0.115) пpочитана в дpугом модуле. Баг особенно опасен тем, что он неустойчив и может пpопадать и возникать без видимых пpичин (напpимеp, возникнуть, если пpедыдущая компиляция была неудачной и исчезнуть после использования константы в модуле, где она опpеделена). Лечится (вpоде бы) указанием типа const Wko: double = 0.9; пpавда, тепеpь это уже не совсем константа... Dmitry Medved (2:464/58.7)