Перевод "короткого" имени файла (short filename) в "длинное" (long filename)
| Раздел Сокровищница |
Столкнулся с необходимостью перевода "короткого" имени файла (short filename) в "длинное" (long filename). Дело в том что существующая функция Win32 API GetLongFilename не поддерживается в Windows 95(r) и в Delphi по этой же причине не инкапсулирована.
Предлагаю свой вариант функии. Функция работает как с сетвыми, так и с локальными именами. Вход: short(string) filename, выход: long filename(string) или пустая строка(string), в случае некоректного имени файла. Текст оной прилагаю ниже. uses Windows, SysUtils{для функции FileExists()}; function GetLongFileName(InputName: string): string; var Root, Net: Boolean; InPath, CurP, BegP: PChar; CurItem, CurPath, OutPath: string; RootGuard: SmallInt; FindHandle: Cardinal; FindData: WIN32_FIND_DATA; begin if not FileExists(InputName) then begin Result:= ''; Exit; end;{if not FileExists(InputName) then} OutPath:= InputName; InPath:= PChar(InputName); Root:= True; Net:= False; RootGuard:= 0; CurP:= InPath; while CurP^<>#0 do begin BegP:= CurP; while (CurP^<>'\') and (CurP^<>#0) do CurP := CharNext(CurP); SetString(CurItem, BegP, CurP - BegP); if CurItem='' then CurPath:= CurPath+'\' else begin CurPath:= CurPath+CurItem; if Root then begin OutPath:= CurPath; CurPath:= CurPath+'\'; end;{if Root then} end;{if CurItem='' then CurPath:= CurPath+'\' else} if (CurPath='\\') or (CurPath='\') then Net:= True; if Root then begin if Net then begin RootGuard:= -1; Net:= False; end;{if Net then} Inc(RootGuard); if RootGuard>0 then Root:= False; end{if Root then} else begin FindHandle:= FindFirstFile(PChar(CurPath), FindData); OutPath:= OutPath+'\'+FindData.cFileName; Windows.FindClose(FindHandle); CurPath:= CurPath+'\'; end;{if Root then ... else} CurP := CharNext(CurP); end;{while CurP^ <> #0 do} Result:= OutPath; end;{GetLongFileName}
По мотивам обсуждения :
Не столько в качестве "ответов", сколько в качестве самостоятельного дополнения и пояснения к статье. >>Еще куча всяких "бонусов", просто лень описывать
>Никаких других бонусов не наблюдаю. Ну, что же, перечислю...
Первоначальный вариант Игоря Василенко
| with TMyDlg.Create(nil) do try if execute then ... begin end; finally free; end; |
Мой вариант
| ShowMessage('Вы ввели '+InputString('Начальное значение')); |
Другие Бонусы: Лаконичность вызова. Краткая форма - "SomeVar:=InputString;" - что, согласитесь, гораздо лаконичнее... Если вам нужен ввод данных в одном-двух местах программы, это особого значения не имеет, но в случае, когда таких мест в программе 100-150... Экономия 8 строк может показаться весьма ощутимой... ДО показа формы определяются начальные значения контролов. Поверьте, иногда это ОЧЕНЬ важно! Возможна работа практически с любым кол-вом и качеством данных. Видимо не все понимают как это делается. Поясню: например надо передать 10 строковых переменных (поля какой-нить формы). Делаем вот так: (пример переехал выше. в первую часть письма :-))
> К тому же проверка правильности введенного значения будет производится,
> как я понял на основе исходников, после выхода из формы диалога.
> Я предпочитаю делать это до, чтобы дать пользователю возможность исправить
> ошибку без повторного открытия диалога. Итак. Оговорка №1 - это концепт!!! Я специально сидел и удалял незначащий код! Проверки, защиту от ошибок и т.д.!
Кроме того, а это что???
| If ShowModal = mrOk Then Result:=Edit1.Text Else Result:='"Отмена"'; |
Итак...
Во первых, основная цель написания такого рода диалогов - СТАНДАРТИЗАЦИЯ процедур и интерфейсов ввода.
Вторая задача - РАЗГРУЗИТЬ код ОСНОВНЫХ модулей программы. Т.е. Чем короче вызов диалога - тем лучше. Крайне желательно, чтобы основной модуль получал ТОЛЬКО результат ввода (успех/НЕуспех) и, в случае успешного ввода - данные. Все. Все проверки, защита и т.д. ДОЛЖНЫ быть ВЫНЕСЕНЫ из рабочих модулей программы. Если ввод с ограничением диапазонов и т.д. - пишите диалог, принимающий на вход список ограничений и реализующий их! Не тащите это в основной модуль! > Возвращает единственное строковое значение, а зачастую их должно быть > несколько.
> Что делать? Запихивать все в строку, а после проводить разбор на мой взгляд
> неприемлемо. Ок. Приведу пример ввода МНОГИХ переменных. Да еще и по именам, да еще и в разных комбинациях и количествах...
| function InputStringsByName(BeginVal: TStrings): TModalResult; Var i: Integer; Cmpnt: TComponent; begin With TOptionsDlg.Create(Application.MainForm) do Try //Иницализируем поля начальными значениями For i:= 0 to BeginVal.Count - 1 do begin Cmpnt:=FindComponent(BeginVal.Names[i]); If Cmpnt is TEdit Then (Cmpnt as TEdit).Text:=BeginVal.ValueFromIndex[i] Else Try If Cmpnt is TSpinEdit Then (Cmpnt as TSpinEdit).Value:=StrToInt(BeginVal.ValueFromIndex[i]) Except End; end; //Показываем диалог Result:=ShowModal; //Если ввод успешен - копируем введенные значения на место начальных If Result = mrOk Then For i:= 0 to BeginVal.Count - 1 do begin Cmpnt:=FindComponent(BeginVal.Names[i]); If Cmpnt is TEdit Then BeginVal.ValueFromIndex[i]:=(Cmpnt as TEdit).Text Else Try If Cmpnt is TSpinEdit Then BeginVal.ValueFromIndex[i]:=IntToStr((Cmpnt asTSpinEdit).Value); Except End; end; Finally Free; End; end; |
добавлено 19.12.02
Скачать: Исходный код (3K) Откомпилированный пример (218K) Исходники - для Delphi 6.
Главное отличие - формат файлов форм... Остальное должно работать "на ура"
Получение адреса из входящего сообщения в MS Outlook
| Раздел Сокровищница | ров Алекс, дата публикации 30 апреля 2002г. |
Функция демонстрирует решение проблемы, связанной с получением адреса из входящего сообщения в MS Outlook Function GetEAddr(InputMailItem : Variant {mailitem}) : String; Var MapiFile: TextFile; FirstLine, MailAddress : String; StrLength, Index : Integer; begin MailAddress := ''; // Сохраняем сообщение в текстовом файле... InputMailItem.SaveAs(WideString(ExtractFilePath(Application.EXEName) + 'mailitem.txt'), $00000000); // Если рассмотреть структуру созданного файла, то в первой строке кроме всего прочего, // содержится электронный адрес отправителя. Задача состоит в том, чтобы прочитать его... AssignFile(MapiFile, ExtractFilePath(Application.EXEName) + 'mailitem.txt'); Reset(MapiFile); Readln(MapiFile, FirstLine); CloseFile(MapiFile); If Pos('@', Trim(FirstLine)) > 0 Then Begin StrLength := Length(Trim(FirstLine)); Index := StrLength; While FirstLine[Index] <> ' ' Do Dec(Index); MailAddress := Copy(FirstLine, Index + 1, StrLength - Index); For Index := 1 To Length(Trim(MailAddress)) Do If (MailAddress[Index] = '[') Or (MailAddress[Index] = ']') Then MailAddress[Index] := ' '; MailAddress := Trim(MailAddress); End Else MailAddress := Trim(InputMailItem.SenderName); Result := MailAddress; // В том случае, если адрес все же не определен, возвращаем известный нам SenderName... end;
Поверхностный подход
| Раздел Сокровищница |
При работе с полями в формате "дата-время" объектов типа TDataSet мои коллеги неоднократно сталкивались с проблемой поведения маски. Недавно у меня тоже возникла задача работы с такими полями. Возможно, ни один из нас просто не разобрался, как нужно делать правильно, но нужно было действовать.
Проблема заключается в том, что при вводе с клавиатуры требуется обязательно указывать все знаки, включая ненужные в конкретном случае (временную часть). В противном случае генерируется ошибка:
'Invalid input value. Use escape key to abandon changes'
После часа, потраченного на разбирательство с маской, возникло желание написать собственный компонент. Спросив у коллег, которые уже ходили этим путем, я решил посмотреть в исходниках - вдруг получится быстро обойти этот вопрос.
Не буду брать на себя смелость комментировать, что и как делается в модуле Mask.pas. Кто хочет, может разобраться самостоятельно - ничего особо сложного там нет.
Для начала в свойстве EditMask замените символ BlankChar с '_' на '0'. В результате получится маска вроде
!99/99/99 99:99:99;1;0
Чтобы при редактировании и просмотре значение выглядело одинаково, укажите свойство DisplayFormat
dd.mm.yy hh:nn:ss
Далее нужно добавить в проект файлы Consts.pas, Sysconsts.pas и Mask.pas. После внесения изменений закройте Дельфи, и открыв снова, перекомпилируйте проект. Затем указанные файлы можно исключить из проекта. Пример приведен для Дельфи 5.
Изменения следующие:
Consts.pas //SMaskEditErr = 'Invalid input value. Use escape key to abandon changes'; SMaskEditErr = 'Введено некорректное значение. Нажмите Esc для отмены'; SysConsts.pas
//SInvalidDateTime = '''%s'' is not a valid date and time'; SInvalidDateTime = '''%s'' - некорректное значение даты и времени'; Mask.pas
function TCustomMaskEdit.RemoveEditFormat(const Value: string): string; … {шестая строка снизу} {так было} // if Result[I] = FMaskBlank then // Result[I] := ' '; {так стало} if Result[I] = FMaskBlank then if FMaskBlank='0' then Result[I] := FMaskBlank else Result[I] := ' '; … function TCustomMaskEdit.Validate(const Value: string; var Pos: Integer): Boolean; … {одинадцатая строка снизу} {так было} // if (Value [Offset] = FMaskBlank) or // ((Value [Offset] = ' ') and (EditMask[MaskOffset] <> mMskAscii)) then if (FMaskBlank<>'0') and ((Value [Offset] = FMaskBlank) or ((Value [Offset] = ' ') and (EditMask[MaskOffset] <> mMskAscii))) then … В завершении хочу поделиться полезной и простой функцией. Как правило, при создании документа, мы вставляем текущие дату и время. При этом секунды как правило не нужны. function GetDateTimeWOSec(DateTime: TDateTime): TDateTime; begin Result:=StrToDateTime(FormatDateTime('dd.mm.yy hh:nn',DateTime)); end;
После проведения описанных манипуляций с полем в формате дата-время становиться так же приятно работать, как с компонентом TRXDateEdit.
Житель без титула Виктор Светлов
Практический пример
Также я сделал небольшой пример того, как можно использовать этот модуль на практике. Программа Drawing рисует картику по уже готовым математическим формулам, находящимся в файле Drawing.dat. Вы можете его открыть при помощи блокнота. Вы также можете вписать туда свои формулы. При создании этой программы мне пришлось зарегистрировать несколько новых функций. Первая из них (x) используется для расчета координаты X, вторая (y) используется для получения координыты Y, функция index возвращает индекс текущего пикселя. Напоминаю, что начало координат находится в верхнем левом углу. Кстати, если формула написана неправильно, то она будет проигнорирована, а для расчета картинки требуется как минимум три правильных формулы, по одной для кажного цвета: красного, зеленого и синего. Программа каждый раз при расчете картики выбирает случайные формулы. При стандартном разрешении 1024 : 768 получаем, что для вычисления одного составляющего всех пикселей картинки требуется произвести 1024 * 768 = 786432 операций, а всего 786432 * 3 = 2359296 операций. На моем компьютере расчет всей картинки занимает 1 - 3 секунды. На старых компьютерах расчет будет занимать намного больше времени, например, я был неприятно удивлен, когда запустил эту же программу на компьютере Celeron-400, там картинка расчитывалась 5 - 10 секунд.
Правильные диалоги от Борланда
| рбань С.В., дата публикации 16 декабря 2002г. |
Почитал тут статью . Гммм.. Все в целом верно, но неудобно. Не хочу обижать РАЗДО более удачную конструкцию (которую, кстати, я уже давно использую).
Еще раз подчеркну - это не моя придумка, а ребят из Борланда.
Эта конструкция позволяет: Возвращать ЛЮБЫЕ значения; ДИНАМИЧЕСКИ создавать форму; Еще куча всяких "бонусов", просто лень описывать :-) Итак, смотрим исходники...
В этом примере я привел два наиболее типичных случая. 1-й - InputString - просто ввод, без анализа отмены, второй - MrInputString - с анализом отмены ввода (ModalResult).
Оба случая используют начальные значения. Без них - Еще проще...
В принципе - ваша фантазия ничем не ограничивается. Я, например, храню последние вводившиеся значения в реестре и читаю их оттуда после создания формы. Удобно.
Пользователь не мается вводя по 10 раз одно и то же, а у меня не болит голова с инициализацией полей (есть специальный класс, который этим занимается, но это отдельная тема...)
ИСХОДНИКИ:
| //************************************************************** //Основной модуль Обратите Внимание! "uses Dialog;" implementation {$R *.dfm} uses Dialog; procedure TForm1.BitBtn1Click(Sender: TObject); begin ShowMessage('Вы ввели '+InputString('Начальное значение')); end; procedure TForm1.BitBtn2Click(Sender: TObject); Var Str: String; begin Str:='Начальное значение'; If MrInputString(Str) = mrOk Then ShowMessage('Вы ввели '+Str) Else ShowMessage('Вы отменили ввод'); end; //******************************************************** //Модуль диалога unit Dialog; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Buttons; type TOptionsDlg = class(TForm) Bevel1: TBevel; BitBtn1: TBitBtn; BitBtn2: TBitBtn; Edit1: TEdit; Label1: TLabel; Bevel2: TBevel; Label3: TLabel; procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); private { Private declarations } public { Public declarations } end; var OptionsDlg: TOptionsDlg; function InputString(BeginVal: String): String; function MrInputString(Var Str: String): TModalResult; implementation {$R *.dfm} function InputString(BeginVal: String): String; begin With TOptionsDlg.Create(Application.MainForm) do Try Edit1.Text:=BeginVal; If ShowModal = mrOk Then Result:=Edit1.Text Else Result:='"Отмена"'; Finally Free; End; end; function MrInputString(Var Str: String): TModalResult; begin With TOptionsDlg.Create(Application.MainForm) do Try Edit1.Text:=Str; Result:=ShowModal; Str:=Edit1.Text; Finally Free; End; end; procedure TOptionsDlg.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin Case Key of 27: ModalResult:=mrCancel; 13: ModalResult:=mrOk; End; end; end. |
| Невизуальный компонент для преобразования денежной суммы в пропись. За образец был взят метод, используемый в 1С. Т.е. вся сумма хранится в текстовом файле. Подгружая этот файл, можно управлять выводом суммы. Таким образом в примере реализована многоязыковая "сумма прописью". В MInWord.zip находятся: MInWord.pas - компонент TInWord для вывода суммы прописью. Project1.* и Unit1.* - файлы примера работы компонента. *.lng - подгружаемые языковые описания для компонента. |   |
NetShareAdd , NetShareDel для Win9x
| Раздел Сокровищница | ан Николаевич, дата публикации 14 мая 2002г. |
Предлагается еще один пример реализации функций создания(удаления) расшаренного диска для Win9x
Procedure NetShareDriveC(SetShared: Boolean); const LM20_NNLEN = 12; SHPWLEN = 8; SHI50F_RDONLY = 1; SHI50F_FULL = 2; SHI50F_DEPENDSON = (SHI50F_RDONLY or SHI50F_FULL); SHI50F_ACCESSMASK = (SHI50F_RDONLY or SHI50F_FULL); SHI50F_PERSIST = 256; SHI50F_SYSTEM = 512; STYPE_DISKTREE = 0; ACCESS_NONE = 0; ACCESS_READ = $01; ACCESS_WRITE = $02; ACCESS_CREATE = $04; ACCESS_EXEC = $08; ACCESS_DELETE = $10; ACCESS_ATRIB = $20; ACCESS_PERM = $40; ACCESS_GROUP = $8000; ACCESS_ALL = (ACCESS_READ or ACCESS_WRITE or ACCESS_CREATE or ACCESS_EXEC or ACCESS_DELETE or ACCESS_ATRIB or ACCESS_PERM); type share_info_2= record shi2_netname : PWideChar; shi2_type : DWORD; shi2_remark : PWideChar; shi2_permissions : DWORD; shi2_max_uses : DWORD; shi2_current_uses : DWORD; shi2_path : PWideChar; shi2_passwd : PWideChar; end; share_info_50 = packed record shi50_netname : array [0..LM20_NNLEN] of Char; shi50_type : Byte; shi50_flags : Short; shi50_remark : PChar; shi50_path : PChar; shi50_rw_password: array [0..SHPWLEN] of Char; shi50_ro_password: array [0..SHPWLEN] of Char; end; var hDll : THandle; NetShareAddWin9x : function(pszServer : PChar; sLevel : Short; pbBuffer : Pointer; cbBuffer : Short):DWORD;stdcall; NetShareDelWin9x : Function(pszServer : PChar; pszNetName : PChar; usReserved : Short):DWORD;stdcall; si50 : share_info_50; si2 : share_info_2; tamano : Short; res, err : DWORD; EsNT: Boolean; Begin If SetShared then begin hDll := LoadLibrary('SvrApi.dll'); if hDll > 32 then begin // NetShareAdd NetShareAddWin9x := GetProcAddress(hDll, 'NetShareAdd'); tamano := sizeof(si50); FillChar(si50, tamano, 0); StrCopy(si50.shi50_netname, 'SH_ACCESS'); si50.shi50_type := STYPE_DISKTREE; si50.shi50_flags := SHI50F_Full; //SHI50F_RDONLY; si50.shi50_path := 'C:\'; StrCopy( si50.shi50_rw_password, 'siemensw'); StrCopy( si50.shi50_ro_password, 'siemens'); res := NetShareAddWin9x(nil, 50, @si50, tamano); Showmessage('NetShare added to C:\Test .'); FreeLibrary(hDll); end; end else begin hDll := LoadLibrary('SvrApi.dll'); if hDll > 32 then begin // NetShareDel NetShareDelWin9x := GetProcAddress(hDll, 'NetShareDel'); res := NetShareDelWin9x(nil, PChar('SH_ACCESS'), 0); Showmessage('NetShare deleted. Check C:\test .'); FreeLibrary(hDll); end; end; End;
Смотрите по теме:
Пример работы по последовательному порту
| Раздел Сокровищница | атьев, дата публикации 22 марта 2001г. |
Модуль для работы с весами (ПетВес серия EB4) по последовательному порту
Реально работающий "драйвер" и может быть использован по назначению.
Скачать модуль (2K) ... type ComPort = 1..4; const ComPortName : array [ComPort] of string = ('COM1','COM2','COM3','COM4'); type TWeightAdapter = class ( TComponent ) private FPort : ComPort; FTimeOut : integer; function GetWeight: double; procedure SetPort(const Value: ComPort); public constructor Create( AOwner : TComponent );override; function AsString: string; published property Weight : double read GetWeight; property Port : ComPort read FPort write SetPort; property TimeOut : Integer read FTimeOut write FTimeOut; end; function GetWeight ( Port : integer = 1 ): double; procedure Register; implementation uses SysUtils,Windows; function GetWeight ( Port : integer = 1 ): double; var A : TWeightAdapter; Begin A := TWeightAdapter.Create(nil); A.Port := Port; Result := A.Weight; A.Free; End; const SIncorrectPort = 'Неверный номер порта'; SPortNotOpen = 'Невозможно открыть порт'; { TWeightAdapter } function TWeightAdapter.AsString: string; begin result := Format('%f',[weight]); end; constructor TWeightAdapter.Create(AOwner: TComponent); begin inherited Create( AOwner ); FTimeOut := 2; FPort := 1; end; function TWeightAdapter.GetWeight: double; var S : string; hComm,Readed : Cardinal; Buffer : byte; Mode : TDCB; TimeOuts : COMMTIMEOUTS; StartTime,Finish : TDateTime; Done : boolean; const Numbers = ['0'..'9','.',',']; Function GetString : string ; var B,E : integer; Begin B := 0; E := Length(S); While (E>0) and (S[E]<>#13) do Dec(E); If E>0 then B := E; While (B>0) and (S[B]<>#10) do Dec(B); If B>0 then Result := Copy(S,B+1,E-1) else Result := ''; End; function ParseString : extended; var T,S : string; // 'ST, 102,12kgG'#13#10 begin result := -1; S := GetString; // Формат : ST. 100.05 kgG // ST/US/OL : Стабильно / нестабильно / перегруз // Число : вес // KG : Единица измерения ( других похоже нет ) // H/G/L : Верхний предел/норма/нижний предел T := UpperCase(Copy(S,1,2)); If (T='US') or (T='OL') then Exit; If (T='ST') or (T='+ ') or (T='- ') then Begin While ((Length(S)>0) and (not (S[1] in ['0'..'9']))) do Delete(S,1,1); T := ''; While (Length(S)>0) and (S[1] in Numbers) do Begin If (S[1] = ',') then T := T+'.' else T := T+S[1]; Delete(S,1,1); End; Val(T,Result,Readed); Done := true; End; end; begin Result := 0; if csDesigning in ComponentState then Exit; Finish := FTimeOut / 86400; Done := false; // Открываем HComm := CreateFile( PChar(ComPortName[Port]), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0); if hComm = INVALID_HANDLE_VALUE then raise Exception.Create(SPortNotOpen); with Mode do Begin BaudRate := 9600; ByteSize := 8; Parity := NOPARITY; StopBits := ONESTOPBIT; Flags := EV_RXCHAR + EV_EVENT2; End; SetCommState ( hComm, Mode ); // Устанавливаем таймауты with TimeOuts do Begin ReadIntervalTimeout := MAXDWORD; ReadTotalTimeoutMultiplier := 0; ReadTotalTimeoutConstant := 0; End; SetCommTimeOuts(hComm,TimeOuts); // Собираем строку StartTime := Now; repeat ReadFile(hComm,Buffer,1,Readed,nil); If Readed>0 then Begin S := S+Char(Buffer); Result := ParseString; End; until (Now-StartTime>Finish ) or Done; // Заметаем следы CloseHandle(HComm); // Закрываем хэндл файла end; procedure TWeightAdapter.SetPort(const Value: ComPort); begin If (Value>0) and (Value<5) then FPort := ComPort(Value) else raise Exception.Create(SIncorrectPort); end; ...
дата публикации 10 ноября 2001г.
| Раздел Сокровищница | тов, дата публикации 10 ноября 2001г. |
В этом архиве представлены 3 версии программы, которая демонстрирует работу со слоями(Layers) в Windows 2000: Берется форма, на нее накладывается рисунок (любой). Форма окна подгоняется под рисунок (цвет точки в координатах [0,0] считаем прозрачным).
Потом - две новые прикольные WinAPI функции. Первая располагает окно на отдельном Layer-е в Windows 2000+ SetWindowLong Вторая - она там в цикле по таймеру крутится - устанавливает степень прозрачности Layer-а с использованием Alpha-канала. SetLayeredWindowAttributes В результате - окно по форме скина (кто-то интересовался) и демонстрация новых функций API Windows 2000.
Прозрачными формами тоже кто-то развлекался.
В каталоге D5 - версия для Delphi5 с объявлением внешних функций API Windows 2000. Написана Ярославом Богатовым (aka AnorAglar)
Аскетизм и прямолинейность кода демонстрируют не только соответствующие качества мозга программиста, но и позволяют запихать всё в один модуль, где всё понятно и без комментариев.
В каталоге NewLayer - версия для Delphi5. Оптимизирована Андреем Пляко (aka EinWill) По скорости создания региона По логичности кода По структурированности и комментированности. В каталоге D6 - версия для Delphi6 с использованием новых свойств формы. Почувствуйте разницу между D5 и D6. И ужас от того, что скоро все будут это использовать.
P.S.
Код Андрея Пляко опубликован с согласия чной теме смотрите проекты Антона Григорьева: Окно с изменяемой степенью прозрачности.
Пример работы с окнами средствами Win API
| Раздел Сокровищница | анович Олег, дата публикации 21 марта 2002г. |
| Приложенные файлы: (216 K) - программа откомпилированная Delphi 6, (3.8 K) - исходный код программы, для Delphi 6. Программа распространяется свободно, разработана в обучающих целях на Delphi 6. Всю информацию по работе смотрите в исходных кодах.
Смотрите материалы Королевства по этой теме: |  |
Принцип работы
Компонент ищет таблицу по ячейкам ее верхнего ряда (шапка таблицы). Существует структура типа TTableInfo, которая описывает критерии поиска:
TFilterOption = (foCaseInsensitive, foSoftFiltration);
THeadLine = record Cells: array of string; FilterOptions: array of TFilterOption; end;
TBorderOption = (boRight, boBottom);
TBorderOptions = set of TBorderOption;
TTableInfo = record HeadLine: THeadLine; Rect: TRect; BorderOptions: TBorderOptions; TableIndex, BottomIndex: Integer; end; Описание шапки таблицы находится в элементе TTableInfo.HeadLine, где TTableInfo.HeadLine.Cells это строковый массив верхнего ряда ячеек, а TTableInfo.HeadLine.FilterOptions это массив, который соответствует каждой ячейки массива TTableInfo.HeadLine.Cells и определяет способ сравнения элементов массива TTableInfo.HeadLine.Cells с ячейками таблицы Excel. TTableInfo.HeadLine.FilterOptions может быть двух типов:
foCaseInsensitive означает, что соответствующий элемент массива Cells должен в точности совпадать с ячейкой в документе Excel. Регистр не учитывается.
foSoftFiltration означает, что каждая ячейка из документа Excel может содержать в себе соответствующий элемент массива Cells. Регистр не учитывается. Если массив TTableInfo.HeadLine.FilterOptions пустой, то для сравнения используется свойство DefaultFilter компонента ExcelManager. Задавать этот массив не обязательно, а в большинстве случает вообще не нужно. Тем не менее он позволяет определять достаточно гибкие критерии поиска.
Элемент TTableInfo.Rect обозначает координаты и размеры таблицы по отношению к шапке таблицы:
Left обозначает смещение влево относительно левой верхней ячейки таблицы (шапки таблицы). Right обозначает количество колонок таблицы.
Top обозначает смещение вниз относительно левой верхней ячейки таблицы (шапки таблицы).
Bottom обозначает количество рядов таблицы.
Задавать ширину (Rect.Right) и высоту (Rect.Bottom) таблицы не обязательно, так как компонент сам может определять размеры таблицы. Для автоопределения ширины таблицы, элемент TTableInfo.BorderOptions должен содержать boRight и, соответственно, для автоопределения высоты таблицы TTableInfo.BorderOptions должен содержать boBottom. Определение границы осуществляется путем нахождение первой пустой ячейки. Просмотр таблицы в документе Excel происходит сверху вниз, слева направо. Для изменения способа обнаружения нижней границы таблицы используется еще один элемент: TTableInfo.BottomIndex. Он определяет колонку, которая должна содержать пустую ячейку. Например, если TTableInfo.BorderOptions включает в себя boBottom и TTableInfo.BottomIndex равен 0, то определение высоты таблицы будет находиться по первой пустой ячейке колонки 0, на рисунке это колонка "A":
В таком случае высота таблицы будет равна 7, то есть будет содержать в себе 7 рядов. Если же TTableInfo.BorderOptions включает boBottom и TTableInfo.BottomIndex равен 1, то определение высоты таблицы будет находиться по первой пустой ячейке колонки 1, на рисунке это колонка "B" и высота таблицы будет равна 5, то есть будет содержать в себе 5 рядов.
Так как в документе Excel может быть найдена более чем одна таблица, удовлетворяющая условиям структуры TTableInfo, то существует элемент: TTableInfo.TableIndex. Он указывающий на индекс нужной таблицы. Чаще всего документ Excel содержит в себе только одну искомую таблицу, поэтому целесообразно задавать значение TTableInfo.TableIndex равным 0.
Для импорта таблицы используется функция:
function ImportTable(Table: TTable; TableInfo: TTableInfo): Boolean; virtual;
В ней указывается таблица Table, которая будет заполнена соответствующими данными и информация о таблице, которую необходимо найти. Если все прошло успешно, то функция возвращает истину. Прежде чем импортировать таблицу, нужно открыть документ Excel. Это делается с помощью процедуры:
procedure Open(const FileName: string); virtual;
Параметр FileName содержит путь к файлу Excel. Соответственно, после открытия файла его нужно закрыть. Делается это с помощью процедуры:
procedure Close(SaveChanges: Boolean); virtual;
Параметр SaveChanges определяет, нужно ли сохранять изменения.
Процесс экспотра таблицы намного проще процесса импорта. Для задания условий экспортирования используется структура:
TExportTableInfo = record Cell1, Cell2: string; Rect: TRect; end; Элементы TExportTableInfo.Cell1 и TExportTableInfo.Cell2 задают координаты левой верхней ячейки экспортируемой таблицы в формате Excel. То есть, например, если необходимо экспортировать таблицу в самое начало документа Excel, то задаем значение TExportTableInfo.Cell1 равным "A", значение TExportTableInfo.Cell2 равным "1", в таком случае левая верхняя ячейка таблицы разместиться в документе Excel по адресу "A1". Элемент TExportTableInfo.Rect определяет смещение экспортируемой таблицы относительно координат TExportTableInfo.Cell1 и TExportTableInfo.Cell2. Используются только элементы Left и Top структуры TExportTableInfo.Rect. На первый взгляд это кажется бессмысленным. Действительно, зачем нужно смещение, если и так можно задать любую координату элементами TExportTableInfo.Cell1 и TExportTableInfo.Cell2? Все дело в том, что в Excel специфическая система координат. Для пользователя она весьма удобна, а для программиста это небольшая проблема. Горизонтальная координата - это система исчисления, состоящая из английского алфавита. То есть, двадцатишестиричная система исчисления. Но беда в том, что в этой системе исчисления нет нуля. То есть если использовать двадцатишестиричную систему исчисления по правилам, то A это 0, B это 1, C это 2 и так далее. Но в любом документе присутствуют такие координаты, как AA, AB, AC и так далее. По всем правилам они должны выглядеть, как A, B, C и так далее, так как первым числом ноль (A) никогда не ставится. Но это все философия. Вернусь к тому, от чего я ушел. Если нужно задать координату, скажем 100:200, то не нужно пересчитывать горизонтальную координату в формат Excel, достаточно установить, скажем, TExportTableInfo.Cell1 в "A", TExportTableInfo.Cell2 в "1", TExportTableInfo.Rect.Left в 100 и TExportTableInfo.Rect.Top в 200.
Проблемы копирования русского текста в clipboard и обратно
| рь Цысь ( Igoreha ), дата публикации 24 апреля 2003г. |
У многих возникает проблема с копированием русского текста в буфер обмена на ОС Win2000 и WinXP а может и Win9x. Простого и надежного решения данной проблемы найти, к сожалению, не удалось :-( Представляю модуль который поможет решить проблему копирования русского текста в clipboard и обратно.
Спасибо всем, кто помог решить эту проблему !!!
Нужно просто добавить в проект ...
| unit RusClipboard; interface uses Clipbrd; type TRusClipboard = class(TClipboard) private procedure SetCodePage(const CodePage: longint); public procedure Open; override; procedure Close; override; end; implementation uses Windows; { TRusClipboard } procedure TRusClipboard.Close; begin SetCodePage($0419); inherited; end; procedure TRusClipboard.Open; begin inherited; SetCodePage($0419); end; procedure TRusClipboard.SetCodePage(const CodePage: longint); var Data: THandle; DataPtr: Pointer; begin // Назначить кодовую страницу для буфера обмена Data:= GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, 4); try DataPtr := GlobalLock(Data); try Move(CodePage, DataPtr^, 4); SetClipboardData(CF_LOCALE, Data); finally GlobalUnlock(Data); end; except GlobalFree(Data); end; end; var FClipboard: TClipboard; OldClipboard: TClipboard; initialization // Установить клипборд FClipboard:= TRusClipboard.Create; OldClipboard:= SetClipboard(FClipboard); if OldClipboard <> nil then OldClipboard.Free; end. |
Процедура печати TStringList на принтер
Процедура печатает TStringList на принтер, переносит на следующий лист бумаги, если список не помещается.
Поля - фиксированные в пол-дюйма.
procedure PrintStrings(S: TStrings; Font: TFont; Title: string); var LeftMargin, TopMargin, LineCoord, LineOnPage, LinesOnDoc, CurrentLine, TextHeight, LinesPerPage, LineInterval: integer; procedure StartDoc; begin LinesOnDoc := S.Count; Printer.Canvas.Font.Assign(Font); Printer.Canvas.TextOut(0, 0, ' '); LeftMargin := (Printer.Canvas.Font.PixelsPerInch) div 2; TopMargin := (Printer.Canvas.Font.PixelsPerInch) div 2; TextHeight := Abs(Printer.Canvas.Font.Height); LineInterval := TextHeight + (TextHeight div 2); LinesPerPage := (Printer.PageHeight - TopMargin) div LineInterval; CurrentLine := 0; end; function MorePages:boolean; begin Result := (CurrentLine < LinesOnDoc) and not Printer.Aborted; end; procedure StartPage; begin LineOnPage := 0; LineCoord := TopMargin; end; procedure NextPage; begin if MorePages then Printer.NewPage; end; function MoreLines:boolean; begin Result := (LineOnPage < LinesPerPage) and (LineOnPage < LinesOnDoc) and not Printer.Aborted; end; procedure NextLine; begin Inc(LineOnPage); Inc(LineCoord, LineInterval); Inc(CurrentLine); end; procedure PrintLine; begin Printer.Canvas.TextOut(LeftMargin, LineCoord, S.Strings[CurrentLine]); end; begin Printer.Title := Title; Printer.BeginDoc; StartDoc; while MorePages do begin StartPage; while MoreLines do begin PrintLine; NextLine; Application.ProcessMessages; end; NextPage; end; Printer.EndDoc; end;
Алексей Еремеев
Смотрите так же:
Процедура выравнивает "уехавшую" форму внутри рабочей части экрана
procedure SafeFormPlace(Form: TForm); var R: TRect; L,T: integer; begin if not SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0) then with Screen do R := Bounds(0, 0, Width, Height); L := Form.Left; if L < R.Left then L := R.Left else if (L + Form.Width) > R.Right then L := R.Right - Form.Width; T := Form.Top; if T < R.Top then T := R.Top else if (T + Form.Height) > R.Bottom then T := R.Bottom - Form.Height; Form.SetBounds(L, T, Form.Width, Form.Height); end;
Алексей Еремеев
Проект "Warp Button". Иллюстрация к статье "Пространство имен оболочки Windows"
| Раздел Сокровищница | н , дата публикации 23 августа 2001г. |
Этот фриварный проект может принести как практическую, так и теоретическую пользу. Фактически это иллюстрация к статье известного гуру Акжана Абдулина (есть в Свитках и на его личном сайте). Именно она послужила толчком и основанием для этой разработки.
Идея проста. Хотелось получить в Windows функциональность кнопки Warp оболочки WarpCenter операционной системы OS/2 Warp 4.0 Merlin. Отличается она от кнопки Start Explorer'а тем, что показывает не отдельно формируемое меню, а иерархическое содержимое десктопа. То есть, все, что есть на десктопе и во вложенных папках, она разворачивает в виде меню и позволяет запускать.
Скачать проект: exe-файл + исходные коды (52 K)
Программа ставится в автостарт и помещает свой значок в System Tray.
Исходные тексты могут ответить на массу часто задаваемых вопросов о программировании в Windows. Вот некоторые темы: - Получение и использование папок рабочего стола, перечисление всех объектов. - Работа без VCL, использование Win32API. - Организация неконсольной программы без видимого окна. - Работа с "иконкой в Tray" без компонентов ;) - Использование меню из ресурса и меню "ручной сборки", иконки в меню (стиль OWNERDRAW). - Отслеживание изменений в директории (в частности - папка десктопа). - Получение иконок для объектов рабочего стола. - Контекстное меню для объектов рабочего стола. - Операции с идентификаторами объектов оболочки (pidl). - Хранение опций в реестре. - И многое другое. Единственный большой недостаток - отсутствие комментариев.
В основу положен принцип "Лучше день потерять, потом за пять минут долететь" (с) мультик. При старте зачитываются все объекты, зато потом меню работает быстро. Некоторые известные спецпапки десктопа по-умолчанию не развертываются во вложенное меню (можно отключить в конфигурации). Диски в "My Computer" тоже не развертываются - было бы слишком много объектов. Изменения на самом десктопе контролируются и запускается процедура перечитывания объектов (во вложенных папках контроля нет).
Горячая клавиша вызова меню - Ctrl-Alt-F12. Вызов контекстного меню для выбранного объекта - Ctrl-Enter или правая кнопка мыши.
Проект компилируется в D5, первоначально был написан в среде D3 (есть различия в инициализации COM). Программа была разработана в 1999 году в порядке изучения Delphi и методов работы с API и объектами эсплорера.
Отдельное спасибо Акжану Абдулину за вышеупомянутую статью о пространстве имен, а также Анатолию Тенцеру за его "конструктор юного любителя иконок в SysTray" (модуль TaskBar.pas - его, без изменений).
Программа для тестирования скорости расчета
Программа предназначена для расчета скорости вычисления формул (как математических, так и логических) на Вашем компьютере. В ниспадающем списке я уже приготовил несколько формул различной сложности. Как Вы увидите, скорость вычисления простых и сложных формул различается. Программа также показывает структуру сценария. Структура отображается числами по 4 байта, разделенных между собой знаком пробела. Количество выполняемых операций также можно регулировать.
Программа для установки параметров экрана из командной строки
| Агранович, дата публикации 09 января 2003г. |
Утилита, которая меняет параметры экрана на заданные в командной строке.
Может пригодиться дизайнерам, разработчикам софта, а так же тем, кто работает на компьютере не один, и предпочитает пользоваться своими настройками экрана. Достаточно запустить ярлык программы и параметры экрана мгновенно изменятся на указанные в командной строке.
Например команда "ScreenSet.exe 800 600 8 100" установит: разрешение в 800 на 600, глубину цвета в 8 бит на пиксель, а частоту экрана в 100Гц. Запуск программы: "ScreenSet.exe Ширина Высота Цвет Частота" Пример: "ScreenSet.exe 800 600 8 100"
Для изменения параметров экрана используется следующая функция:
| function SetFullscreenMode(PelsWidth, PelsHeight, BitsPerPixel, DisplayFrequency: Integer):Boolean; var DeviceMode : TDevMode; begin with DeviceMode do begin dmSize:=SizeOf(DeviceMode); dmBitsPerPel:=BitsPerPixel; dmPelsWidth:=PelsWidth; dmPelsHeight:=PelsHeight; dmDisplayFrequency:=DisplayFrequency; dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT or DM_DISPLAYFREQUENCY; Result:=ChangeDisplaySettings(DeviceMode,CDS_UPDATEREGISTRY) = DISP_CHANGE_SUCCESSFUL; end; end; |
Скачать исходный код: (12.8 K)
| Для данного материала нет комментариев. |
Программная настройка DCOM
Для программной настройки DCOM можно воспользоваться процедурами модуля BDcomPrm
DefaultProperties
| Элемент | Процедура | Описание | 9x | NT |
| Enable Distributed COM on this computer | IsDCOMOk | Проверяет наличие поддержки DCOM | + | + |
| IsEnabledDCOM | Проверяет разрешен ли DCOM на данной машине | + | + | |
| SetEnableDCOM | Разрешает DCOM на данной машине | + | + | |
| IsDCOMProtocolsEnabled | Проверяет наличие протоколов DCOM | - | + | |
| Default Authentication LevelDefault Impersonation Level | IsInitializeSecurityOk | Проверяет можно ли устанавливать параметры Security. Возвращает True для платформы NT и False для 9x | - | + | InitializeDefaultSecurity | Устанавливает параметры Security по умолчанию.Вызов данной процедуры необходимо поместить перед Application.Initialize в клиентской и серверной программе.Процедуру можно вызывать только один раз для текущего процесса.Процедура должна быть вызвана до первого обращения к COM-объекта, требующего маршалинга | .+ | + |
| SetDefaultDCOMCommunicationProperties | Устанавливает параметры по умолчанию для Authentication Level, Impersonation Level | + | + | |
| CreateRemoteComObjectEx | Определяет Authentication Level, Impersonation Level запускаемого серверного приложения.Данная процедура может использоваться вместо CreateRemoteComObject | + | + | |
| Provide additional security for reference tracking | RemoveLegacySecure-References | При разрешении DCOM необходимо вызвать эту процедуру, чтобы сбросить флажок Повышенной безопасности для отслеживания ссылок | + | + |
DefaultSecurity
| Элемент | Процедура | Описание | 9x | NT |
| Enable remote connection | IsDCOMOk, IsEnabledDCOM, SetEnabledDCOM | + | + | |
| Default access permissions | ListDefaultAccessACL | Возвращает в строке описание разрешений доступа к DCOM приложениям по умолчанию. Данное описание может быть выведено в Memo. | - | + |
| ChangeDefaultAccessACL | ChangeDefaultAccessACL Изменяет параметры доступ к DCOM приложениям по умолчанию.Principal - имя пользователя (например Everyone)SetPrincipal - True добавить пользователя в список, False - удалить.Permit - разрешить параметры для указанного пользователя | - | + | |
| Default launch permissions | ListDefaultLaunchACL | Возвращает в строке описание разрешений запуска DCOM приложений по умолчанию. Данное описание может быть выведено в Memo | - | + |
| ChangeDefaultLaunchACL | ChangeDefaultLaunchACL Изменяет параметры запуска DCOM приложений по умолчанию - + | - | + | |
| IsDefaultLaunchAccess-Allowed | Возвращает True, если разрешен запуск DCOM приложений по умолчанию. | - | + |
Application Security
Все процедуры и функции данной категории получают в качестве входного параметра AppID - CLSID объекта сервера.
| Элемент | Процедура | Описание | 9x | NT |
| Access permissions | ListAppIDAccessACL | Возвращает в строке описание разрешений доступа к DCOM приложению. Данное описание может быть выведено в Memo.AppID - CLSID объекта сервера. | - | + |
| ChangeAppIDAccessACL | Изменяет параметры доступ к DCOM приложениям по умолчанию.AppID - CLSID объекта сервера.Principal - имя пользователя (например Everyone)SetPrincipal - True добавить пользователя в список, False - удалить.Permit - разрешить параметры для указанного пользователя | - | + | |
| Default launch permissions | ListAppIDLaunchACL | Возвращает в строке описание разрешений запуска DCOM приложения. Данное описание может быть выведено в Memo.AppID - CLSID объекта сервера. | - | + |
| ChangeAppIDLaunchACL | Изменяет параметры запуска DCOM приложений по умолчанию.AppID - CLSID объекта сервера. | - | + | |
| IsLaunchAccessAllowed | Возвращает True, если разрешен запуск DCOM приложения. | - | + | |
| AllowLaunchAccess | Разрешает запуск DCOM приложения | - | + |
Все процедуры и функции данной категории получают в качестве входного параметра AppID - CLSID объекта сервера.
| Элемент | Процедура | Описание | 9x | NT |
| Which user account do you want to use to run this application | IsInteractiveUser | Проверяет, используется ли для запуска приложения учетная запись взаимодействующего пользователя | - | + |
| SetInteractiveUser | Устанавливает параметр: использовать для запуска приложения учетную запись взаимодействующего пользователя | - | + |
Все остальные процедуры и функции модуля BDcomPrm носят служебный характер.
Абдулин Марат
,
руководитель отдела программирования
Скачать исходные коды: (28 K)
Статьи по теме:
Работа с БД: Поиск и фильтрация.
| Раздел Сокровищница | Автор Александр Мефодьев дата публикации 31 января 2000г. |
П О И С К
1. Метод Locate: function Locate(const KeyFields: String; const KeyValues: Variant; Options: TLocateOptions): Boolean; Метод Locate ищет первую запись, удовлетворяющую критерию поиска, и если такая запись найдена, делает ее текущей. В этом случае в качестве результата возвращается True. Если запись не найдена - False.
Список KeyFields указывает поле, или несколько полей, по которым ведется поиск. В случае нескольких поисковых полей их названия разделяются точкой с запятой. Критерии поиска задаются в вариантном массиве KeyValues так, что i-е значение KeyValues ставится в соответствие i-му полю в KeyFields.
Options позволяет указать необязательные значения режимов поиска: type TLocateOption = (loCaseInsensitive, loPartialKey); TLocateOptions = set of TLocateOption; loCaseInsensitive - поиск ведется без учета регистра букв, т.е. KeyValues будет считать слова "принтер" и "ПРИНТЕР", а также "ПрИнТеР" одинаковыми. loPartialKey - запись считается удовлетворяющей условию поиска, если она содержит часть поискового контекста, например, удовлетворяющими контексту "Ма" будут признаны слова: "Мама", "Машина" и т.д. Locate производит поиск по любому полю; полк или поля, по которым производится поиск, могут не только не входить в текущий индекс, но и не быть индексированными вообще.
В случае, если поля входят в какой-либо индекс, Locate использует этот индекс при поиске. Если искомые поля входят в несколько индексов, трудно сказать, какой из них будет использован. Соответственно трудно предсказать, какая запись из множества записей, удовлетворяющих критерию поиска, будет сделана текущей - особенно в случае, если поиск ведется не по текущему индексу.
При поиске по полям, не входящим ни в один индекс, применяется фильтр BDE. Вот пример использования Locate: procedure TForm1.LocateButtonClick(Sender: TObject); begin Table1.Locate('Field1;Field2', VarArrayOf(['Ма','Зд']), [loPartialKey]); end; В этом примере поиск произведен при помощи одной строчки кода:
2. Метод Lookup
function Lookup( const KeyFields: String; const KeyValues: Variant; const ResultFields: String): Variant; Метод Lookup находит находи нужную запись, но не делает ее текущей, а возвращает значения некоторых полей этой записи. Тип результата - Variant или вариантный массив. Независимо от успеха поиска записи, указатель текущей записи в таблице не меняется. В отличие от Locate, Lookup осуществляет поиск только на точное соответствие критерия поиска и значения полей записи. В KeyFields указывается список полей, по которым необходимо осуществлять поиск. При наличии в этом списке более чем одного поля соседние поля разделяются точкой с запятой. KeyValues указывает поисковые значения полей, список которых содержится в KeyFields.
Если имеется несколько поисковых полей, каждому i-му полю в KeyFields ставится в соответствие i-ое значение в KeyValues. При наличии одного поля его поисковое значение можно указывать в качестве KeyValues непосредственно; в случае нескольких полей их необходимо приводить к типу вариантного массива при помощи VarArrayOf.
В качестве поисковых полей можно указывать поля как входящие в какой-либо индекс, так и не входящие в него; тип текущего индекса не имеет значения. Если поисковые поля входят в какие-либо индексы, их использование производится автоматически; в противном случае используются фильтры BDE.
Если в результате поиска запись не найдена, метод Lookup возвращает Null, что можно проверить с помощью оператора: If VarType(LookupResults) = varNull then ... В противном случае Lookup возвращает из этой записи значения полей, список которых содержит ResultFields. При этом размерность результата зависит от того, сколько результирующих полей указано в ResultFields: одно поле - результатом будет значение соответствующего типа или Null, если поле найденной записи содержит пустое значение; несколько полей - результатом будет вариантный массив, число элементов в котором меньше или равно числу результирующих полей (некоторые поля найденной записи могут содержать пустые значения). Пример: Одно результирующее поле procedure TForm1.LookupButtonClick(Sender: TObject); var LookUpResults: Variant; begin LookupResults:=Table1.Lookup('Name', Edit1.Text, 'Phone'); Case varType(LookUpResults) of varEmpty : Label1.caption:='Пустой результат'; varNull : Label1.Caption:='Запись не найдена'; else Label1.Caption:=LookUpResults; end; end; Пример: Несколько результирующих полей procedure TForm1.LookupButtonClick(Sender: TObject); var LookUpResults: Variant; begin LokUpResults:=Table1.Lookup('Name', Edit1.Text, 'TabNum;Doljnost;Phone'); If VarIsArray(LookUpResults) then begin Label1.Caption:=LookUpResults[0]; If LookUpResults[1] <> Null then Label2.Caption:=LookUpResults[1]; If LookUpResults[2] <> Null then Label3.Caption:=LookUpResults[2]; end else case VarType(LookUpResults) of varEmpty : Label1.caption:='Пустой результат'; varNull : Label1.Caption:='Запись не найдена'; end; end; Если запись не найдена, VarType(LookUpResults) возвращает значение varNull. Если поиск по какой-либо причине не был произведен, VarType(LookUpResults) возвращает значение VarEmpty. Если какое-либо из полей, что значения возвращаются в результате поиска в вариантном массиве, содержит пустое значение, соответствующий элемент вариантного массива также будет содержать пустое значение (Null). В этом случае обращение к нему приведет к исключительной ситуации, поэтому нужна предварительная проверка.
Ф И Л Ь Т Р А Ц И Я
Свойство Filter
Свойство Filter компонента TTable позволяет задать критерий фильтрации. В этом случае база будет отфильтрована, как только свойство Filtered будет равно TRUE. Синтаксис описания критерия похож на синтаксис секции WHERE SQL-запроса с тем исключением, что имена переменных программы указывать нельзя, можно указывать имена полей и литералы (явно заданные значения); можно использовать обычные операции отношения и логические операторы AND, NOT и OR, например:
Эта запись фильтра оставит в таблице записи, в которых поля Doljnost='доцент' и TabNum больше 3000 Filter:='([Doljnost]=''доцент'') and ([TabNum] > 3000)'; Filtered:=True; Строку критерия фильтрации можно ввести во время прогона программы или на этапе конструирования. Например, с помощью такого обработчика события OnChecked компонента CheckBox1 критерий фильтрации считывается из поля Edit1 и помещается в свойство Filter компонента Table1: procedure TForm1.CheckBox1Click(Sender: TObject); begin Table1.Filter := Edit1.Text; Table1.Filtered := CheckBox1.Checked; end; С помощью свойства type TFilterOption = (foCaseInsensitive, foNoPartialCompare); property FilterOptions: TFilterOptions; можно определить дополнительные свойства фильтрации строковых полей: foCaseInsensitive - фильтрация производится без учета разницы регистра foNoPartialCompare - поиск производится на точное соответствие.
Событие OnFilterRecord
Событие OnFilterRecord возникает при установке значения True в свойство Filtered. Обработчик события имеет два параметра: имя фильтруемого набора данных и переменную Accept, в которую программа должна поместить True, если текущая запись удовлетворяет условию фильтрации.
В отличие от критерия в строке Filtered, ограниченного рамками синтаксиса условного выражения, критерий, реализуемый в обработчике события OnFilterRecord, определяется синтаксисом Object Pascal и может организовать сложные алгоритмы фильтрации. Однако следует помнить, что в обработчике OnFilterrecord последовательно перебираются все записи БД, в то время как методы SetRange, ApplyRange и им сопутствующие методы компонента TTable используют индексно-последовательный метод, т.е. работают с частью записей в физической БД. Это делает использование обработчика OnFilterRecord предпочтительным для фильтрации небольших объемов записей и сильно ограничивает его применение при больших объемах данных.
Всякий раз, когда приложение обрабатывает событие OnFilterRecord, набор данных переводится из состояния dsBrowse в состояние dsFilter. Это предотвращает модификацию набора данных во время фильтрации. После завершения текущего вызова обработчика события ObFilterRecord набор данных переводится в состояние dsBrowse.
Пример: чтобы создать набор данных из тех записей базы данных, в которых поле "Должность" содержит значение "преподаватель", можно использовать такой обработчик: procedure TForm1.Table1FilterRecord(DataSet: TDataSet; var Accept: Boolean); begin Accept := DataSet['Должность'] = 'преподаватель'; end; Еще один пример: отфильтровать базу "Сотрудники" по условию "Отобрать всех, у кого табличный номер (поле "#") больше значения, вводимого пользователем в Edit1, и в поле "ФИО" есть подстрока символов, вводимых пользователем в Edit2":
procedure TForm1.Table1FilterRecord(DataSet: TDataSet; var Accept: Boolean); begin Accept := (DataSet['#'] > Edit1.Text) and (Pos(Edit2.Text, DataSet['ФИО']) > 0); end; Если в строке Filter и обработчике события OnFilterRecord заданы разные критерии фильтрации, выполняются оба.
Методы расширенной фильтрации
1. Методы фильтрации
Помимо описываемых ниже методов, присущих только TTable, наборы данных имеют также общие свойства, методы и события для фильтрации - Filter, Filtered, OnFilteredRecord, FindFirst, FindLast, FindNext, FindPrior.
Для фильтрации записей TTable имеет следующие методы: SetRangeStart - устанавливает нижнюю границу фильтра; EditRangeEnd - утанавливает верхнюю границу фильтра; ApplyRange - осуществляет фильтрацию записей в TTable; SetRange - имеет тот же эффект, что и последовательное выполнение методов SetRangeStart, EditRangeEnd и ApplyRange. В качестве параметров используются массивы констант, каждый из которых содержит значения ключевых полей.
Фильтрация методами ApplyRange, SetRange должно проводиться по ключевым полям.По умолчанию берется текущий индекс, определяемый свойством TTable.IndexName или TTable.IndexFieldNames. Если значения этих свойств не установлены, по умолчанию используется главный индекс. Поэтому, если нужно использовать индекс, отличный от главного, необходимо явно переустановить значение свойства TTable.IndexName (имя текущего индекса) или TTable.IndexFieldNames (список полей текущего индекса).
2. Использование SetRange
Метод procedure SetRange( const StartValues, EditValues: array of const); показывает не только записи, индексные поля которых лежат в диапазоне [StartValues..EndValues].
Пример: Пусть в наборе данных Table1 показываются все записи. Включим в структуру записи набора данных два поля: "Номер группы" и "Наименование товара". Пусть текущий индекс построен по полю "Номер группы".
Напишем такой обработчик события: CheckBox1.Click: procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp: Integer; begin If CheckBox1.Checked then begin GrNumTmp := StrToInt(Edit1.Text); With Table1 do begin CancelRange; SetRange([GrMunTmp],[GrNumTmp]); end; end else Table1.CancelRange; end; В отфильтрованном наборе данных показываются только те записи, индексное поле текущего индекса у которых (в нашем случае "Номер группы") имеет значение, лежащее в заданном диапазоне. В данном случае диапазон определяется переменной GrNumTmp. Поэтому для GrNumTmp = 3 будут показаны записи, принадлежащие к группе 3.
Если бы мы захотели, чтобы в наборе данных фильтровались записи из нескольких групп, то нам следовало бы добавить в форму второй компонент Edit2, в котором вводился бы номер конечной группы, в то время как в Edit1 вводился бы номер начальной группы: procedure TForm1.CheckBox1Click(Sender: TObject); var GrNumTmp1, GrNumTmp2: Integer; begin If CheckBox.Checked then begin GrNumTmp1 := StrToInt(Edit1.Text); GrNumTmp2 := StrToInt(Edit2.Text); With Table1 do begin CancelRange; SetRange([GrNumTmp1],[GrNumTmp2]); end; end else Table1.CancelRange; end;
Александр Мефодьев,
ICQ 56666220
31 января 2000г. Специально для
Работа с локальной сетью - NetShareAdd
| Раздел Сокровищница |
Долго и упорно мучался по освоению этой функции и, наконец, решил эту проблему (не без помощи добрых людей :).
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; procedure Button1Click(Sender: TObject); end; Share_INFO_2= record shi2_netname:PWideChar; // ОБЯЗАТЕЛЬНО PWideChar иначе работать не будет... shi2_type:DWORD; shi2_remark:LPTSTR; shi2_permissions:DWORD; shi2_max_uses:DWORD; shi2_current_uses:DWORD; shi2_path:PWideChar; shi2_passwd:LPTSTR; end; PShare_INFO_2 = ^Share_INFO_2; LPShare_INFO_2 = ^Share_INFO_2; SHARE_INFO_502 =record shi502_netname: PCHAR; shi502_type: DWORD; shi502_remark: PCHAR; shi502_permissions: DWORD; shi502_max_uses: DWORD; shi502_current_uses: DWORD; shi502_path: PCHAR; shi502_passwd: PCHAR; shi502_reserved: DWORD; shi502_security_descriptor: PSECURITY_DESCRIPTOR; end; PSHARE_INFO_502= ^SHARE_INFO_502; LPSHARE_INFO_502=^SHARE_INFO_502; const STYPE_DISKTREE = $0001; ACCESS_READ = $0001; var Form1: TForm1; F:Cardinal; function NetShareAdd( Server : PwideChar; level : cardinal; Buf : Pointer; var Parm_Err : DWORD):Cardinal;stdcall; external 'netapi32.dll' name 'NetShareAdd'; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var buf:Pointer; UserInf:Share_INFO_2; UserInf502:Share_INFO_502; err:dWord; begin err:=0; f:=0; UserInf.shi2_netname:='test'; UserInf.shi2_type:=0; UserInf.shi2_remark:='test'; UserInf.shi2_permissions:=1; UserInf.shi2_max_uses:= 1; UserInf.shi2_current_uses:=0; UserInf.shi2_path:='C:\test'; UserInf.shi2_passwd:=nil; GetMem(Buf ,sizeof(UserInf)); F:=NetSHAREAdd(nil,2,@UserInf,err); FreeMem(Buf); end; end.
Расширение возможностей стандартной функции MessageDlg
| рякин Руслан, дата публикации 04 июля 2003г. |
Функция TimedMessageBox представляет собой расширение возможностей стандартной функции MessageDlg (большая часть кода взята из нее же). Дополнительной является возможность закрытия окна сообщения по таймеру без участия пользователя (в случае его отсутствия за компьютером).
Может пригодиться при длительных обработках, когда нужно и вывести какое-либо сообщение пользователю, и продолжить работу, даже если он его проигнорировал (например в файловых менеджерах при копировании большого количества файлов: если какой-то из них не читается, весь процесс останавливается, хотя логичнее было бы просто пропустить этот файл и записать информацию об ошибке в лог, если пользователь не ответил на сообщение).
Скачать: (230K)
В архиве содержится сам модуль, демонстрационная программа (dpr и exe) и картинки, используемые в кнопках.
| Для данного материала нет комментариев. |
Реализация шаблонов в Delphi
| Раздел Сокровищница | ркуша Алексей, дата публикации 07 сентября 2001г. |
Многие скажут что сабж невозможен. Но...посмотрите что у меня получилось (На примере простого списка).
Итак.
Необходимо создать два пустых ((Через File-> New->Text или в файловой системе) без interface, implementation, uses... и т.д.) .pas файла.
Первый назовем InterfaceTemp.pas(заголовок), второй ImplementTemp.pas(реализация). Далее копируем, соответственно, в них в InterfaceTemp.pas (заголовочный файл шаблона): TemplateList = class // заголовочный файл шаблона (для ordinal types или real types, shortstring) private FList: PIntList; FCount: Integer; FCapacity: Integer; protected procedure Grow; function Get(Index: Integer): _DATA_TYPE_; // Вот оно чудо :-) procedure Put(Index: Integer; Item: _DATA_TYPE_); procedure SetCapacity(NewCapacity: Integer); procedure SetCount(NewCount: Integer); public destructor Destroy; override; class procedure Error(const Msg: string; Data: Integer); overload; virtual; class procedure Error(Msg: PResStringRec; Data: Integer); overload; function Add(Item: _DATA_TYPE_): Integer; procedure Clear; function Last: _DATA_TYPE_; function First: _DATA_TYPE_; procedure Delete(Index: Integer); procedure Exchange(Index1, Index2: Integer); function IndexOf(Item: _DATA_TYPE_): Integer; procedure Insert(Index: Integer; Item: _DATA_TYPE_); procedure Move(CurIndex, NewIndex: Integer); procedure Sort; function Min: _DATA_TYPE_; function Max: _DATA_TYPE_; property Count: Integer read FCount write SetCount; property Items[Index: Integer]: _DATA_TYPE_ read Get write Put; default; end; в ImplementTemp.pas (файл реализации шаблона): function TemplateList.Add(Item: _DATA_TYPE_): Integer; begin Result := FCount; if Result = FCapacity then Grow; FList^[Result] := Item; Inc(FCount); end; procedure TemplateList.Clear; begin SetCount(0); SetCapacity(0); end; procedure TemplateList.Delete(Index: Integer); begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Dec(FCount); if Index < FCount then System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(_DATA_TYPE_)); end; destructor TemplateList.Destroy; begin Clear; end; procedure TemplateList.Exchange(Index1, Index2: Integer); var Item: _DATA_TYPE_; begin if (Index1 < 0) or (Index1 >= FCount) then Error(@SListIndexError, Index1); if (Index2 < 0) or (Index2 >= FCount) then Error(@SListIndexError, Index2); Item := FList^[Index1]; FList^[Index1] := FList^[Index2]; FList^[Index2] := Item; end; function TemplateList.Get(Index: Integer): _DATA_TYPE_; begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Result := FList^[Index]; end; procedure TemplateList.Grow; var Delta: Integer; begin if FCapacity > 64 then Delta := {371053//}FCapacity div 4 else if FCapacity > 8 then Delta := 16 else Delta := 4; SetCapacity(FCapacity + Delta); end; function TemplateList.IndexOf(Item: _DATA_TYPE_): Integer; begin Result := 0; while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result); if Result = FCount then Result := -1; end; procedure TemplateList.Insert(Index: Integer; Item: _DATA_TYPE_); begin if (Index < 0) or (Index > FCount) then Error(@SListIndexError, Index); if FCount = FCapacity then Grow; if Index < FCount then System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(_DATA_TYPE_)); FList^[Index] := Item; Inc(FCount); end; function TemplateList.Max: _DATA_TYPE_; var i: Integer; begin if Fcount=0 then Error(@SListCountError, 0); Result:=Flist^[0]; for i:=0 to Fcount-1 do if Result < Flist^[i] then Result:=Flist^[i]; end; function TemplateList.Min: _DATA_TYPE_; var i: Integer; begin if Fcount=0 then Error(@SListCountError, 0); Result:=Flist^[0]; for i:=0 to Fcount-1 do if Result>Flist^[i] then Result:=Flist^[i]; end; procedure TemplateList.Move(CurIndex, NewIndex: Integer); var Item: _DATA_TYPE_; begin if CurIndex <> NewIndex then begin if (NewIndex < 0) or (NewIndex >= FCount) then Error(@SListIndexError, NewIndex); Item := Get(CurIndex); Delete(CurIndex); Insert(NewIndex, Item); end; end; procedure TemplateList.Put(Index: Integer; Item: _DATA_TYPE_); begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); FList^[Index] := Item; end; procedure TemplateList.SetCapacity(NewCapacity: Integer); begin if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then Error(@SListCapacityError, NewCapacity); if NewCapacity <> FCapacity then begin ReallocMem(FList, NewCapacity * SizeOf(_DATA_TYPE_)); FCapacity := NewCapacity; end; end; procedure TemplateList.SetCount(NewCount: Integer); begin if (NewCount < 0) or (NewCount > MaxListSize) then Error(@SListCountError, NewCount); if NewCount > FCapacity then SetCapacity(NewCount); if NewCount > FCount then FillMemory(@(FList^[FCount]), (NewCount - FCount) * SizeOf(_DATA_TYPE_),0); FCount := NewCount; end; procedure QuickIntSort(ia: PIntList; iLo,iHi : integer); var Lo, Hi : Integer; // индексы Mid, T : _DATA_TYPE_; // значения begin Lo := iLo; Hi := iHi; Mid := ia[(Lo+hi) shr 1]; repeat while ia[Lo] < Mid do Inc(Lo); while ia[Hi] > Mid do Dec(Hi); if Lo Hi; if Hi > iLo then QuickIntSort(ia,iLo,Hi); if Lo < iHi then QuickIntSort(ia,Lo,iHi); end; procedure TemplateList.Sort; begin if (FList <> nil) and (FCount > 0) then QuickIntSort(FList, 0, FCount - 1); end; class procedure TemplateList.Error(const Msg: string; Data: Integer); function ReturnAddr: Pointer; asm MOV EAX,[EBP+4] end; begin raise Exception.CreateFmt(Msg, [Data]) at ReturnAddr; end; class procedure TemplateList.Error(Msg: PResStringRec; Data: Integer); begin TemplateList.Error(LoadResString(Msg), Data); end; function TemplateList.Last: _DATA_TYPE_; begin Result := Get(FCount - 1); end; function TemplateList.First: _DATA_TYPE_; begin Result := Get(0); end; Теперь необходимо создать файл для так называемого "typedef" (Файл указания конкретного типа). На примере типа Currency (ImplCurrencyList.pas), для другого типа создайте еще один файл с другим названием, например (ImplIntegerList.pas)
Итак Currency:
unit ImplCurrencyList; interface uses windows, sysutils; {$H-} // длинные строки недопустимы type _DATA_TYPE_ = Currency; // здесь указывается настоящий тип {$H+} const MaxListSize = Maxint div (4*sizeof(_DATA_TYPE_)); type PIntList = ^TIntList; TIntList = array[0..MaxListSize - 1] of _DATA_TYPE_; {$I InterfaceTemp} // соответственно тип уже обозначен и реален type TCurrencyList = TemplateList; // здесь задается тип реального класса списка implementation uses Consts; {$I ImplementTemp} // соответственно тип уже обозначен и реален end.
Вот собственно и все. Теперь подключате модуль нужного типа uses ImplCurrencyList или ImplIntegerList.
И
var cyr: TCurrencyList или
var intlist: TIntegerList; где то. (если вы создали два или более "typedef" файла для других типов byte, Extended).
Данный пример работает с обычными типами данных (не объектными). Для объектов можно завернуть "перегрузку операторов"
Например: TBase = class // это пример для дальнейших обсуждений function doPlus(value: TBase): TBase; overload; // для выполнения оператора+ (если конечно договорится, что doPlus подразумеывает оператор +) function doPlus(value: integer): TBase; overload; function doPlus(value: real): TBase; overload; end; Соответсвенно где то в шаблоне (очень примитивный пример) function TemplateClass.Add(Item: _DATA_TYPE_): Integer; // например TemplateClass и _DATA_TYPE_ есть TBase; begin self.doPlus(Item); {для TBase} Result:=self.a; // какое-то внутреннее поле (пример) end; Вот такие дела в Delphi творятся. Любая критика и предложения принимаются.
Скачать пример (6.2K)
Регистрация приложения в SimpleService в Win9x
| Раздел Сокровищница |
Функция регистрирует свое приложение (откуда вызвана) в SimpleService в Win9x (не будет видно в TaskManager и может работать до того, как пользователь вошел в систему, запуская из ключа реестра
HKLM\Software\Microsoft\Windows\CurrentVersion\RunServices
или HKLM\...\RunServicesOnce и продолжает работать после окончания сессии пользователя)
Булевый параметр - включение или выключение режима
Возвращаемое значение - True в случае успеха
Особенность - функция не критична к операционной системе, программа запустится даже под WinNT (где такая функция не существует в принципе), а результат работы будет False.
function RegisterServiceProcessEx(Enable: boolean): boolean; type TRSP = function (H: THandle; K: dword): dword; stdcall; var RSP: TRSP; begin @RSP := GetProcAddress(GetModuleHandle(PChar('kernel32.dll')), PChar('RegisterServiceProcess')); Result := Assigned(@RSP); if Result then begin if Enable then Result := (RSP(0, 1) = 1) else Result := (RSP(0, 0) = 1); end; end;
Алексей Еремеев
Системное меню по произвольному событию в произвольном месте
| Раздел Сокровищница |
Может кому пригодится....
Событие OnFilterRecord
Событие OnFilterRecord возникает при установке значения True в свойство Filtered. Обработчик события имеет два параметра: имя фильтруемого набора данных и переменную Accept, в которую программа должна поместить True, если текущая запись удовлетворяет условию фильтрации.
В отличие от критерия в строке Filtered, ограниченного рамками синтаксиса условного выражения, критерий, реализуемый в обработчике события OnFilterRecord, определяется синтаксисом Object Pascal и может организовать сложные алгоритмы фильтрации. Однако следует помнить, что в обработчие OnFilterrecord последовательно перебираются все записи БД, в то время как методы SetRange, ApplyRange и им сопутствующие методы компонента TTable используют индексно-последовательный метод, т.е. работаютс частью записей в физической БД. Это делает использование обработчика OnFilterRecord предпочтительным для фильтрации небольших объемов записей и сильно ограничивает его приминение при больших объемах данных.
Всякий раз, когда приложение обрабатывает событие OnFilterRecord, набор данных переводится из состояния dsBrowse в состояние dsFilter. Это предотвращает модификацию набора данных во время фильтрации. После завершения текущего вызова обработчика события ObFilterRecord набор данных переводится в состояние dsBrowse.
Пример: чтобы создать набор данных из тех записей базы данных, в которых поле "Должность" содержит значение "преподаватель", можно использовать такой обработчик:
| procedure TForm1. Table1FilterRecord(DataSet: TDataSet; var Accept: Boolena); begin Accept := DataSet['Должность'] = 'преподаватель'; end; |
Еще один пример: отфильтровать базу "Сотрудники" по условию "Отобрать всех, у кого табличный номер (поле "#") больше значения, вводимого пользователем в Edit1, и в поле "ФИО" есть подстрока символов, вводимых пользователм в Edit2":
| procedure TForm1.Table1FilterRecord(DataSet: TDataSet; var Accept: Boolena); begin Accept := (DataSet['#'] > Edit1.Text) and (Pos(Edit2.Text, DataSet['ФИО']) > 0); end; |
Если в строке Filter и обработчике события OnFilterRecord заданы разные критерии фильтрации, выполняются оба.
Сокровищница:
Секреты ListBox.
| Раздел Сокровищница | Автор статьи Кейт Вуд, Delphi Developer 11/99, Перевод с английского: Владимир Татарчевский. дата публикации 01.12.99 |
Предисловие не от автора
Предлагаемый материал показывает два способа, которыми можно представить данные в компоненте ListBox в виде нескольких колонок. Задача эта не представляется сложной и поэтому мне хотелось бы кое-что пояснить перед прочтением этой страницы.
Статья с названием "Секреты ListBox" была опубликована в ноябрьском номере журнала "Delphi Developer". Помещая ее перевод в Сокровищницу мы преследовали две цели: во-первых ответить на вопрос о нескольких колонках и, во-вторых, желая повеселить наших жителей романтичным повествованием на тему "Хотелось ли вам когда-либо отображать табулированный список...?".
Автор статьи представлен как независимый технический писатель и программист-аналитик. Оставим на его совести выражения типа "Другая малоизвестная особенность ListBox заключается в том, что он может отображать несколько колонок...", возможно эта особенность и малоизвестна, если не заглядывать в Help, не говоря уже о наличии свойства Columns прямо в ObjectInspector'е.
Но несмотря ни на что, ответ на вопрос "как отображать в ListBox несколько колонок" эта статья дает исчерпывающий.
Приятного чтения! Секреты ListBox
ListBox - скромный компонент, появившийся еще в Delphi 1.0. Он показывает список строк и позволяет вам выбрать одну или несколько из них. Однако, как показывает в этой статье Кейт Вуд (Keith Wood), этот компонент имеет редко используемые возможности, которые могут сделать интерфейс вашего приложения более информативным.
Хотелось ли вам когда-либо отображать табулированный список - несколько колонок текста? Как же нам сделать ровные колонки? Вы можете попробовать использовать пробелы, но такой метод не будет работать с пропорциональными шрифтами. Вы можете сделать owner-draw и сформировать колонки самостоятельно. Но вся эта работа не нужна! ListBox уже имеет свойство, которое позволит разершить данную ситуацию.
Свойство TabWidth устанавливает табуляционные интервалы в ListBox. Они измеряются в единицах диалогового окна (dialog box unit), четыре единицы равны сердней ширине символа. Когда это свойство установлено в 0 (по умолчанию), интервалы табуляции в ListBox отсутствуют и символы табуляции отображаются в виде вертикальных линий. Установленное в ненулевое значение, это свойство определяет расстояние между табуляционными метками, расставленными по всей ширине ListBox.
Колонки различной ширины
Что если вы захотите сделать колонки переменной ширины?
Разумеется, нет свойства, позволяющего вам легко сделать это, но это легко делается с помощью кода. Все, что вам нужно сделать - это послать сообщение LB_SETTABSTOPS, передав количество табуляций и указатель на массив с их позициями:
const iStops : array [1..3] of Integer = ( 20, 60, 80 ); begin SendMessage( ListBox1.Handle, LB_SETTABSTOPS, High( iStops ), LongInt( @iStops )); end;
Функция High возвращает индекс последнего элемента в массиве. Если массив индексирован с единицы, вы можете увеличивать количество табуляций, просто добавляя к массиву новые элементы.
Вы также должны установить свойство TabWidth в ненулевое значение, только в этом случае ListBox будет готов принять это сообщение.
Для вставки символа табуляции в ваш текст просто используйте ASCII-символ 9, к примеру так:
ListBox1.Items.Add( Format( '%d'#9'%s'#9'%0:d'#9'%s', [i, Chr( i + Ord( 'A' ) - 1 )] ) ); Несколько колонок
Другая малоизвестная особенность ListBox заключается в том, что он может отображать несколько колонок, стоит вам установить их количество в свойстве Columns.
Теперь строки в ListBox будут расположены по типу газетных столбцов, с горизонтальной полосой прокрутки, появляющейся при необходимости. Строки, не помещающиеся в отведенное для них место обрезаются.
Обе эти возможности просто изменяют вид ListBox. Все остальные функции компонента при этом работают как обычно.
 |
| Рисунок 1 |
Заключение
Итак, наш скромный ListBox имеет скрытые таланты. Мы увидели, как сделать табулированный список с помощью свойства TabWidth и сообщения LB_SETTABSTOPS. Мы также увидели, как создать мультиколонный список с помощью свойства Columns. Запомните это до следующего раза, когда вы будете использовать ListBox.
Кейт Вуд - австралиец, находящийся в данное время в США. Он программист-аналитик в фирме CCSC, базирующейся в Атланте и независимый технический писатель. Его опыт работы с продуктами Borland ведет свое начало с Turbo Pascal для CP/M.
Создание базы данных Interbase во время выполнения программы.
| Раздел Сокровищница | ров Алексей, дата публикации 01 августа 2002г. |
# - разделитель инструкций Sql; Можете ставить, какой нравится... CREATE TABLE MAILTREE( CODE INTEGER NOT NULL PRIMARY KEY, APARENT VARCHAR(255), ACURRENT VARCHAR(255));# CREATE TABLE MAILBASE( CODE INTEGER NOT NULL PRIMARY KEY, FOLDER VARCHAR(255), ISUNREAD SMALLINT DEFAULT 0, AUTHOR VARCHAR(255), SENDERNAME VARCHAR(1000), SENDERSTYLE VARCHAR(1000), RECIPIENT VARCHAR(1000), SUBJECT VARCHAR(255), MSGSIZE DECIMAL(10, 5), MSGRECIEVED VARCHAR(50), ATTACHMENTS SMALLINT, FILELIST VARCHAR(1000), MSGBODY BLOB);# CREATE GENERATOR MTCODE;# SET GENERATOR MTCODE TO 0;# CREATE GENERATOR MBCODE;# SET GENERATOR MBCODE TO 0;# CREATE TRIGGER ADD_MAILTREE FOR MAILTREE ACTIVE BEFORE INSERT AS BEGIN NEW.CODE = GEN_ID(MTCODE, 1); END;# CREATE TRIGGER ADD_MAILBASE FOR MAILBASE ACTIVE BEFORE INSERT AS BEGIN NEW.CODE = GEN_ID(MBCODE, 1); END;# CREATE TRIGGER UPDATE_MAILTREE FOR MAILTREE ACTIVE BEFORE UPDATE AS BEGIN IF (OLD.ACURRENT <> NEW.ACURRENT) THEN UPDATE MAILBASE SET FOLDER = NEW.ACURRENT WHERE FOLDER = OLD.ACURRENT; END;#
Создание системы голосовых сообщений из подручных средств
Смотря, очередной фантастический боевик, в котором “умная” система управления приятным женским или мужским голосом сообщает герою, что если он не выполнит какие-то важные действия то дальше ему (ей) придется передвигаться без удобств на своих двоих или вообще дожидаться завершения фильма в виде горстки атомов.
Вы не раз задумывались, вот бы сделать себе подобную сообщалку о всяческих опасных ситуациях возникающих в вереной Вам компьютерной системе или сети.
Наметим себе цели, которые мы хотим достичь: организовать проверку критических для нашей системы событий; голосовые сообщения о них; не очень перетрудится.
События, которые можно проверять ограничиваются исключительно Вашей фантазией. Можно организовать каждые 5 минут с 9:00 до 18:00 c перерывом на обед посылку сигнала PING на конечные компьютеры сети и если не получен ответ поднимать тревогу. Каждые пол часа проверять количество свободного места на HDD. Наличие одновременно включенного (и при этом работающего) комплекта аппаратных средств (сервера, мосты, печатающие устройства). Или организовать на компьютере шефа проверку базы данных с информацией о заработной плате, если она не увеличилась в течении месяца на оговоренное заранее число “президентов” сообщать шефу, мнение о нем как о руководителе и о фирме в целом.
На простых пользователей производит неизгладимое впечатление, когда компьютер сообщает им о том, что они посмели запустить ПО на которое у них нет позволения.
Практически у каждого уважающего себя производителя компьютерного железа в стандартной конфигурации присутствует звуковая карта, которая наиболее часто используются исключительно для воспроизведения audio CD и МР3 файлов. Дополнительно из техники нужно будет приобрести микрофон.
Для облегчения себе задачи в вопросы синтезирования речи вникать не будем, а необходимые нам сообщения попросту запишем в файлы WAV при помощи стандартной программы Windows Звукозапись (понятно, что для этого нужно микрофон воткнуть в соответствующее гнездо звуковой карты).
Как видно без необходимости контролировать время наступления события не обойтись поэтому для сокращения затрат сил и времени все задачи отслеживания времени для наступления проверки условий возложим на почему-то незаслуженно игнорируемую стандартную программу Windows планировщик заданий. Это такая маленькая пиктограмма справа внизу экрана .
Естественно никто не запрещает Вам написать эту часть кода программы, самим, увеличивая размер исполнительного модуля, но думаю программисты фирмы MICROSOFT сделали это лучше .
Для воспроизведения WAV файлов используем описанную почти во всех солидных учебниках по программированию на DELPHI функцию WIN API BOOL sndPlaySound(LPCSTR lpszSound, UINT fuSound);, полное описание которой находится в файле WIN32S.HLP
Откроем новый проект (да будет прощено мне WINDOWхульство) для уменьшения размера уничтожим в файле проекта код, отвечающий за создание окна
Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run;
Удаление этого кода даст нам дополнительный эффект: активное окно не будет терять фокус при воспроизведении звукового сообщения. В качестве примера проверим наличие файлов в указанной папке при помощи простого кода
| rez:=FindFirst(‘c:/*.*’, faAnyFile-16, SearchRec); FindClose(SearchRec); IF rez=0 then {--Возпроизведение звука---} sndplaysound(pchar(‘mysound.wav’),SND_SYNC); |
Существует альтернативный путь, описать сообщения которым можно присвоить звуки в реестре WINDOWS вызывая их потом из программы. Но для этого нужно иметь познания в структуре реестра и WIN API.
Простой пример программы анализа наличия файлов в папке.
| program sexsot; uses Forms,Windows,SysUtils,MMsystem,inifiles,classes, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} var REZ,i:integer; erasefolder:Tstringlist; inifilefolder:tinifile; strpath,strmax,strcount,strsound:string; SearchRec: TSearchRec; begin if FileExists(paramstr(1)) then begin erasefolder:=Tstringlist.create; inifilefolder:=Tinifile.create(extractfilepath(paramstr(0))+paramstr(1)); inifilefolder.readsections(erasefolder); for i:=0 to erasefolder.count-1 do begin strpath:=inifilefolder.readstring(erasefolder[i],'Pathlook','C:\*.*'); strmax:=inifilefolder.readstring(erasefolder[i],'maxcount','1'); strcount:=inifilefolder.readstring(erasefolder[i],'count','0'); strsound:=inifilefolder.readstring(erasefolder[i],'filesound','1.wav'); {---- Проверка наличия файлов------} rez:=0; rez:=FindFirst(strpath, faAnyFile-16, SearchRec); FindClose(SearchRec); {---------------------------------------------} if rez=0 then begin inifilefolder.writestring(erasefolder[i],'count',inttostr(strtoint(strcount)+1)); end else begin inifilefolder.writestring(erasefolder[i],'count','0'); end; strcount:=inifilefolder.readstring(erasefolder[i],'count','0'); if strtoint(strcount)>=strtoint(strmax) then {--Возпроизведение звука---} sndplaysound(pchar(strsound),SND_SYNC); end; end; end. |
| [modem] PathLOOK=f:\mail\out\*.* filesound=nosend.wav maxcount=3 count=0 [email] PathLOOK=с:\unlx\out\*.* filesound=atasunlx.wav maxcount=2 count=0 |
март 2003г.
| Для данного материала нет комментариев. |
Sqlw
 | источник информации: |
| Техническая документация - список зарезервированных слов Local SQL BDE | |
| Версия: Все Платформа: Windows 3.1, Windows 95, Windows NT | |
| Список зарезервированных слов «Local SQL in the Borland Database Engine» в алфавитном порядке. ACTIVE, ADD, ALL, AFTER, ALTER, AND, ANY, AS, ASC, ASCENDING, AT, AUTO, AUTOINC, AVG BASE_NAME, BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN, BOTH, BY, BYTES CACHE, CAST, CHAR, CHARACTER, CHECK, CHECK_POINT_LENGTH, COLLATE, COLUMN, COMMIT, COMMITTED, COMPUTED, CONDITIONAL, CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING, CURRENT, CURSOR DATABASE, DATE, DAY, DEBUG, DEC, DECIMAL, DECLARE, DEFAULT, DELETE, DESC, DESCENDING, DISTINCT, DO, DOMAIN, DOUBLE, DROP ELSE, END, ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE, EXISTS, EXIT, EXTERNAL, EXTRACT FILE, FILTER, FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION GDSCODE, GENERATOR, GEN_ID, GRANT, GROUP, GROUP_COMMIT_WAIT_TIME HAVING, HOUR IF, IN, INT, INACTIVE, INDEX, INNER, INPUT_TYPE, INSERT, INTEGER, INTO, IS, ISOLATION JOIN KEY LONG, LENGTH, LOGFILE, LOWER, LEADING, LEFT, LEVEL, LIKE, LOG_BUFFER_SIZE MANUAL, MAX, MAXIMUM_SEGMENT, MERGE, MESSAGE, MIN, MINUTE, MODULE_NAME, MONEY, MONTH NAMES, NATIONAL, NATURAL, NCHAR, NO, NOT, NULL, NUM_LOG_BUFFERS, NUMERIC OF, ON, ONLY, OPTION, OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD, PLAN, POSITION, POST_EVENT, PRECISION, PROCEDURE, PROTECTED, PRIMARY, PRIVILEGES RAW_PARTITIONS, RDB$DB_KEY, READ, REAL, RECORD_VERSION, REFERENCES, RESERV, RESERVING, RETAIN, RETURNING_VALUES, RETURNS, REVOKE, RIGHT, ROLLBACK SECOND, SEGMENT, SELECT, SET, SHARED, SHADOW, SCHEMA, SINGULAR, SIZE, SMALLINT, SNAPSHOT, SOME, SORT, SQLCODE, STABILITY, STARTING, STARTS, STATISTICS, SUB_TYPE, SUBSTRING, SUM, SUSPEND TABLE, THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE, TO, TRAILING, TRANSACTION, TRIGGER, TRIM UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER, USER VALUE, VALUES, VARCHAR, VARIABLE, VARYING, VIEW WAIT, WHEN, WHERE, WHILE, WITH, WORK, WRITE YEAR OPERATORS: , -, *, /, <>, <, >, ,(comma), =, <=, >=, ~=, !=, ^=, (, ) | |
Странный Microsoft IIS или SSI своими руками
| Раздел Сокровищница |
Server Side Include (SSI) полезная и удобная вещь. Только вот почему-то ограничены ее возможности в IIS всего несколькими директивами. И тем более странно ведет себя #exec если в качестве выполнимого скрипта подставить ISAPI написанную на Delphi.
Ошибки выдаются разные, но смысл их один - Не могу выполнить скрипт, файл не найден :-( Данные мучения в связке IIS 5.0, Windows 2000 Prof, Delphi 6 Enterprise продолжались несколько дней, пока не родилась мысль написать свой SSI.
Задача:Написать свой SSI. Условия:Имеем Microsoft IIS 5.0, Delphi Решение: ШАГ 1. Создание DLL которая служит интерпретатором SSI. Для этого в Delphi меню File/New/Other... Выбираем <Web Server Application>. В появившемся окне выбираем жмем кнопку OK.
В созданном WebModule добавляем одну Action Устанавливаем ее свойство Default:=True.
Создаем обработчик события OnAction. Туда можно вставить например следующий код var i: TStringList; begin i:=TStringList.Create; i.LoadFromFile(Request.PathTranslated); Response.Content:= i.Text+ Request.PathTranslated; end; или такой var i: TStringList; begin Response.Content:= 'Пользователь запросил файл: ' + Request.PathTranslated; end; Компилируем модуль.
Полученную DLL можно уложить в директорий C:\WINNT\system32\inetsrv\ ШАГ 2. Настройка IIS. Запускаем Internet Service Manager (для IIS 5.0) Щелкаем правой клавишей мышки на Web-сервере, выбираем Properties. В появившимся окне переходим на закладку HomeDirectory. Смотрим на раздел Apllication Settings. Если там доступна только кнопка Create, то нажимаем на нее. В противном случае только сверяем установки и при несоответствии с ними изменяем на необходимые. Выбираем в поле со списком Execute Permissions значение Scripts and Executables. Нажимаем на кнопку Configuration. Появляется окно, где необходимо в закладке App Mappings нажать кнопку Add. В поле Executable прописываем имя и путь к созданной dll. В поле Extension указываем расширение .html (или любое другое например .aaa) Устанавливаем группу переключателей Verbs в значение All Verbs. Устанавливаем флажок Script engine. Жмем кнопку Ok. Результат. Теперь при запросе у IIS файла с расширением .html (или которое вы указали выше) будет вызываться ваша DLL. А там уж что хотите с этим, то и делайте. Самое главное вызываемый файл может реально и не существовать.
С помощью свойств объекта Request можно получить локальное имя запрашиваемого файла: Request.PathTranslated (Например c:\winnt\demo.html).
Также в свойствам данного объекта доступна куча другой информации (см. Help).
А где же SSI спросит Читатель?
Так вот же! У Вас есть координаты запрашиваемого файла, с помощью средств Delphi обрабатывайте его и отсылайте клиенту.
Кстати используя данную технологию возможно создание очень интересной модели, когда файла самого на диске нет, а запрос пользователя используется только для поиска самого файла в базе данных.
А если взглянуть на это чуть шире - ведь это путь создания динамического WWW-сайта с помощью одной DLL... ;-)
Пащенко Андрей (Big Bibigon)
Архангельск, 2002.
Структура формул
Любая формула должна быть составлена с учетов некоторых правил, а также при ее составления необходимо знать из чего она может состоять. Функции, типы, а также другие составляющие приведены ниже: single: тип, означает вещественное 32 битное число double: тип, означает вещественное 64 битное число int64: тип, означает целое знаковое 64 битное число integer: тип, означает целое знаковое 32 битное число longword: тип, означает целое беззнаковое 32 битное число smallint: тип, означает целое знаковое 16 битное число word: тип, означает целое беззнаковое 16 битное число shortint: тип, означает целое знаковое 8 битное число byte: тип, означает целое беззнаковое 8 битное число bool: зарезервированное слово, обозначает логическое выражение. and : операнд, используется для связывания двух логических выражений. Аналогично логическому and в Delphi. or : операнд, используется для связывания двух логических выражений. Аналогично логическому or в Delphi. xor : операнд, используется для связывания двух логических выражений. Аналогично логическому xor в Delphi. not : операнд, меняет логическое значение на противоположное. > функция, если первое математическое выражение больше второго, то возвращает истину, в противном случае возвращает ложь. : функция, если первое математическое выражение меньше второго, то возвращает истину, в противном случае возвращает ложь. <>: функция, если первое математическое выражение не равно второму, то возвращает истину, в противном случае возвращает ложь. =>: функция, если первое математическое выражение больше или равно второму, то возвращает истину, в противном случае возвращает ложь. : функция, если первое математическое выражение меньше или равно второму, то возвращает истину, в противном случае возвращает ложь. =: функция, если первое математическое выражение равно второму, то возвращает истину, в противном случае возвращает ложь. true: функция. Возвращает истину. Это величина может принимать значение 1 false: функция. Возвращает ложь. Это величина может принимать значение 0 +: операнд, сложение -: операнд, вычитание *: функция, вычитание /: функция, деление sqrt: функция, возвращает квадратный корень числа div: функция, возвращает целочисленное деление mod: функция, возвращает остаток от деления int: функция, возвращает целая часть числа frac: функция, возвращает дробная часть числа random: функция, возвращает произвольное число в пределах от 0 до 1 trunc: функция, возвращает целую часть числа round: функция, округляет число arcsec: функция, возвращает арксеканс числа sec: функция, возвращает секанс числа arccsc: функция, возвращает арккосеканс числа csc: функция, возвращает косеканс числа arcsin: функция, возвращает арксинус числа sin: функция, возвращает синус числа arccos: функция, возвращает арккосинус числа cos: функция, возвращает косинус числа arctan: функция, возвращает арктангенс числа tan: функция, возвращает тангенс числа abs: функция, возвращает абсолютную величину числа ln: функция, возвращает натуральный логарифм числа lg: функция, возвращает десятичный логарифм числа log: функция, возвращает логарифм двух числа pi: функция, возвращает число Пи !: функция, возвращает факториал числа ^: функция, возвращает степень числа. Степень не может быть дробной. В любом случае логическая формула должна начинаться с зарезервированного слова "bool". Оно означает, что текущее выражение является логическим. В формуле можно использовать любое количество вложенных формул, которые представляют собой содержимое пары скобок, а содержимое каждой из этих пар скобок может быть как логическим выражением, так и математическим. Соответственно внутри скобок при обозначения логического выражения нужно также ставить зарезервированное слово "bool". Если его нет, то считается, что выражение является математическим.
Например: "bool (2 log 4) = (4 sqrt 2) or (bool (2 * 2) = 4)". В формуле каждая функция должна быть заключена в круглые скобки. Что является функцией, а что нет можно узнать вышеприведенного списка. Как я уже сказал, логические выражения в некоторых случаях могут возвращать числовые значения. Это работает только в том случае, если выражение заключено в скобки, например: "bool (bool true) = 1". Логические выражения возвращающие истину принимают значение 1, а содержащие ложь - 0.
Структура сценария
Как уже было сказано, формула переводится в цифровой вид - сценарий. Существуют два вида сценариев - математический и логический. Математический сценарий может содержать внутри себя только математические сценарии, в то время как логический сценарий может содержать внутри себя как логические, так и математическии сценарии. Они по своей структуре очень близки друг к другу. У каждого сценария есть заголовок, который содерит некоторую начальную информацию:
Кстати, в логическом сценарии результат занимает 4 байта и содержит логическое выражение. Это, конечно, очень нерационально тратить целых 4 байта на хранение логической переменной, но так проще. А основное внимание при создании этого модуля я уделял на достижении максимальной скорости вычисления формулы. Работа внутри модуля производится с вещественными числами, что, например, позволяет без проблем использовать тригонометрические функции. При расчете сценария сначала происходит расчет всех вложенных сценариев, в которых, в свою очередь, также происходит расчет вложенных сценариев и так далее. После расчета вложенного сценария в его начало записывается результат. Адреса вложенных сценариев задаются в байтах относительно начала содержащего их сценария. Сама формула при переводе в сценарий делится на части (единицы), которые определяются наличием положительго или отрицательного знака (в случае с логическим сценарием деление на единицы происходит несколько иначе, формула разбивается по логическим операндам xor, or, and).
Единицы содержат в себе 3 составляющие: функции, числа и вложенные сценарии. Это также справедливо и для логического сценария. Функции классифицируются между собой. Они отличаются тем, что некоторые требуют до себя параметр (например факториал: "10!"), некоторые требуют после себя параметр (например косинус: "cos 0"), некоторые требуют и до и после себя параметры (например умножение: "2 * 2"), некоторые не требуют вообще никаких параметров (например число пи: "pi"). У них также есть общее свойство - они все возвращают какой-то результат. Это также касается и логических функций. Каждая единица начинается с заголовка:
Суть действий модуля
В памяти, соответствующей переменной типа "массив байтов", создается машинный код, соответствующий входной строке, после чего переменной типа "function:extended" присваивается адрес начала массива.
Свойство Filter
Свойство Filter компонента TTable позволяет задать критерий фильтрации. В этом случае база будет отфильтрована, как только свойство Filtered будет равно TRUE. Синтаксис описания критерия похож на синтаксис секции WHERE SQL-запроса с тем исключением, что имена переменных программы указывать нельзя, можно указывать имена полей и литералы (явно заданные значения); можно использовать обычные операции отношения и логические операторы AND, NOT и OR, например:
Эта запись фильтра оставит в таблице записи, в которых поля Doljnost='доцент' и TabNum больше 3000
| Filter:=([Doljnost]='доцент') and ([TabNum] > 3000); Filtered:=True; |
Строку критерия фильтрации можно ввести во время прогона программы или на этапе конструирования. Например, с помощью такого обработчика события OnChecked компонента CheckBox1 критерий фильтрации считывается из поля Edit1 и помещается в свойство Filter компонента Table1:
| procedure TForm1.CheckBox1Click(Sender: TObject); begin Table1.Filter := Edit1.Text; Table1.Filtered := CheckBox1.Checked; end; |
С помощью свойства
| type TFilterOption = (foCaseInsensitive, foNoPartialCompare); property FilterOptions: TFilterOptions; |
можно определить дополнительные свойства фильтрации строковых полей:
foCaseInsensitive - фильтрация производится без учетра разницы регистра
foNoPartialCompare - поиск производится на точное соответствие.
Так зачем же это нужно.
В силу своей огромной нескромности я полагаю, что кому-нибудь это все может быть интересно как пример непосредственного формирования кода в памяти и его исполнения.
Техническая документация - список ошибок BDE
| Раздел Сокровищница | источник информации: |
| Версия: Все Платформа: Windows 3.1, Windows 95, Windows NT |
Примечание: Можно использовать DbiGetErrorString() для получения текста любой ошибки.
Список ошибок:
System Related (Fatal Error) 8449 : $2101 : Cannot open a system file. 8450 : $2102 : I/O error on a system file. 8451 : $2103 : Data structure corruption. 8452 : $2104 : Cannot find Engine configuration file. 8453 : $2105 : Cannot write to Engine configuration file. 8454 : $2106 : Cannot initialize with different configuration file. 8455 : $2107 : System has been illegally re-entered. 8456 : $2108 : Cannot locate IDAPI32 .DLL. 8457 : $2109 : Cannot load IDAPI32 .DLL. 8458 : $210A : Cannot load an IDAPI service library. 8459 : $210B : Cannot create or open temporary file. 8460 : $210C : Trying to load multiple IDAPIxx.DLL 8461 : $210D : Shared Memory Conflict Object of Interest not Found 8705 : $2201 : At beginning of table. 8706 : $2202 : At end of table. 8707 : $2203 : Record moved because key value changed. 8708 : $2204 : Record/Key deleted. 8709 : $2205 : No current record. 8710 : $2206 : Could not find record. 8711 : $2207 : End of BLOB. 8712 : $2208 : Could not find object. 8713 : $2209 : Could not find family member. 8714 : $220A : BLOB file is missing. 8715 : $220B : Could not find language driver. Physical Data Corruption 8961 : $2301 : Corrupt table/index header. 8962 : $2302 : Corrupt file - other than header. 8963 : $2303 : Corrupt Memo/BLOB file. 8965 : $2305 : Corrupt index. 8966 : $2306 : Corrupt lock file. 8967 : $2307 : Corrupt family file. 8968 : $2308 : Corrupt or missing .VAL file. 8969 : $2309 : Foreign index file format. I/O related error 9217 : $2401 : Read failure. 9218 : $2402 : Write failure. 9219 : $2403 : Cannot access directory. 9220 : $2404 : File Delete operation failed. 9221 : $2405 : Cannot access file. 9222 : $2406 : Access to table disabled because of previous error. Resource or Limit error 9473 : $2501 : Insufficient memory for this operation. 9474 : $2502 : Not enough file handles. 9475 : $2503 : Insufficient disk space. 9476 : $2504 : Temporary table resource limit. 9477 : $2505 : Record size is too big for table. 9478 : $2506 : Too many open cursors. 9479 : $2507 : Table is full. 9480 : $2508 : Too many sessions from this workstation. 9481 : $2509 : Serial number limit (Paradox). 9482 : $250A : Some internal limit (see context). 9483 : $250B : Too many open tables. 9484 : $250C : Too many cursors per table. 9485 : $250D : Too many record locks on table. 9486 : $250E : Too many clients. 9487 : $250F : Too many indexes on table. 9488 : $2510 : Too many sessions. 9489 : $2511 : Too many open databases. 9490 : $2512 : Too many passwords. 9491 : $2513 : Too many active drivers. 9492 : $2514 : Too many fields in Table Create. 9493 : $2515 : Too many table locks. 9494 : $2516 : Too many open BLOBs. 9495 : $2517 : Lock file has grown too large. 9496 : $2518 : Too many open queries. 9497 : $2519 : Too many threads for client. 9498 : $251A : Too many BLOBs. 9499 : $251B : File name is too long for a Paradox version 5.0 table. 9500 : $251C : Row fetch limit exceeded. 9501 : $251D : Long name not allowed for this tablelevel. 9502 : $251E : Insufficient shared memory available. Integrity Violation 9729 : $2601 : Key violation. 9730 : $2602 : Minimum validity check failed. 9731 : $2603 : Maximum validity check failed. 9732 : $2604 : Field value required. 9733 : $2605 : Master record missing. 9734 : $2606 : Master has detail records. Cannot delete or modify. 9735 : $2607 : Master table level is incorrect. 9736 : $2608 : Field value out of lookup table range. 9737 : $2609 : Lookup Table Open operation failed. 9738 : $260A : Detail Table Open operation failed. 9739 : $260B : Master Table Open operation failed. 9740 : $260C : Field is blank. 9741 : $260D : Link to master table already defined. 9742 : $260E : Master table is open. 9743 : $260F : Detail table(s) exist. 9744 : $2610 : Master has detail records. Cannot empty it. 9745 : $2611 : Self referencing referential integrity must be entered one at a time with no other changes to the table 9746 : $2612 : Detail table is open. 9747 : $2613 : Cannot make this master a detail of another table if its details are not empty. 9748 : $2614 : Referential integrity fields must be indexed. 9749 : $2615 : A table linked by referential integrity requires password to open. 9750 : $2616 : Field(s) linked to more than one master. 9751 : $2617 : Expression validity check failed. Invalid Request 9985 : $2701 : Number is out of range. 9986 : $2702 : Invalid parameter. 9987 : $2703 : Invalid file name. 9988 : $2704 : File does not exist. 9989 : $2705 : Invalid option. 9990 : $2706 : Invalid handle to the function. 9991 : $2707 : Unknown table type. 9992 : $2708 : Cannot open file. 9993 : $2709 : Cannot redefine primary key. 9994 : $270A : Cannot change this RINTDesc. 9995 : $270B : Foreign and primary key do not match. 9996 : $270C : Invalid modify request. 9997 : $270D : Index does not exist. 9998 : $270E : Invalid offset into the BLOB. 9999 : $270F : Invalid descriptor number. 10000 : $2710 : Invalid field type. 10001 : $2711 : Invalid field descriptor. 10002 : $2712 : Invalid field transformation. 10003 : $2713 : Invalid record structure. 10004 : $2714 : Invalid descriptor. 10005 : $2715 : Invalid array of index descriptors. 10006 : $2716 : Invalid array of validity check descriptors. 10007 : $2717 : Invalid array of referential integrity descriptors. 10008 : $2718 : Invalid ordering of tables during restructure. 10009 : $2719 : Name not unique in this context. 10010 : $271A : Index name required. 10011 : $271B : Invalid session handle. 10012 : $271C : invalid restructure operation. 10013 : $271D : Driver not known to system. 10014 : $271E : Unknown database. 10015 : $271F : Invalid password given. 10016 : $2720 : No callback function. 10017 : $2721 : Invalid callback buffer length. 10018 : $2722 : Invalid directory. 10019 : $2723 : Translate Error. Value out of bounds. 10020 : $2724 : Cannot set cursor of one table to another. 10021 : $2725 : Bookmarks do not match table. 10022 : $2726 : Invalid index/tag name. 10023 : $2727 : Invalid index descriptor. 10024 : $2728 : Table does not exist. 10025 : $2729 : Table has too many users. 10026 : $272A : Cannot evaluate Key or Key does not pass filter condition. 10027 : $272B : Index already exists. 10028 : $272C : Index is open. 10029 : $272D : Invalid BLOB length. 10030 : $272E : Invalid BLOB handle in record buffer. 10031 : $272F : Table is open. 10032 : $2730 : Need to do (hard) restructure. 10033 : $2731 : Invalid mode. 10034 : $2732 : Cannot close index. 10035 : $2733 : Index is being used to order table. 10036 : $2734 : Unknown user name or password. 10037 : $2735 : Multi-level cascade is not supported. 10038 : $2736 : Invalid field name. 10039 : $2737 : Invalid table name. 10040 : $2738 : Invalid linked cursor expression. 10041 : $2739 : Name is reserved. 10042 : $273A : Invalid file extension. 10043 : $273B : Invalid language Driver. 10044 : $273C : Alias is not currently opened. 10045 : $273D : Incompatible record structures. 10046 : $273E : Name is reserved by DOS. 10047 : $273F : Destination must be indexed. 10048 : $2740 : Invalid index type 10049 : $2741 : Language Drivers of Table and Index do not match 10050 : $2742 : Filter handle is invalid 10051 : $2743 : Invalid Filter 10052 : $2744 : Invalid table create request 10053 : $2745 : Invalid table delete request 10054 : $2746 : Invalid index create request 10055 : $2747 : Invalid index delete request 10056 : $2748 : Invalid table specified 10058 : $274A : Invalid Time. 10059 : $274B : Invalid Date. 10060 : $274C : Invalid Datetime 10061 : $274D : Tables in different directories 10062 : $274E : Mismatch in the number of arguments 10063 : $274F : Function not found in service library. 10064 : $2750 : Must use baseorder for this operation. 10065 : $2751 : Invalid procedure name 10066 : $2752 : The field map is invalid. Locking/Contention related 10241 : $2801 : Record locked by another user. 10242 : $2802 : Unlock failed. 10243 : $2803 : Table is busy. 10244 : $2804 : Directory is busy. 10245 : $2805 : File is locked. 10246 : $2806 : Directory is locked. 10247 : $2807 : Record already locked by this session. 10248 : $2808 : Object not locked. 10249 : $2809 : Lock time out. 10250 : $280A : Key group is locked. 10251 : $280B : Table lock was lost. 10252 : $280C : Exclusive access was lost. 10253 : $280D : Table cannot be opened for exclusive use. 10254 : $280E : Conflicting record lock in this session. 10255 : $280F : A deadlock was detected. 10256 : $2810 : A user transaction is already in progress. 10257 : $2811 : No user transaction is currently in progress. 10258 : $2812 : Record lock failed. 10259 : $2813 : Couldn't perform the edit because another user changed the record. 10260 : $2814 : Couldn't perform the edit because another user deleted or moved the record. Access Violation - Security related 10497 : $2901 : Insufficient field rights for operation. 10498 : $2902 : Insufficient table rights for operation. Password required. 10499 : $2903 : Insufficient family rights for operation. 10500 : $2904 : This directory is read only. 10501 : $2905 : Database is read only. 10502 : $2906 : Trying to modify read-only field. 10503 : $2907 : Encrypted dBASE tables not supported. 10504 : $2908 : Insufficient SQL rights for operation. Invalid context 10753 : $2A01 : Field is not a BLOB. 10754 : $2A02 : BLOB already opened. 10755 : $2A03 : BLOB not opened. 10756 : $2A04 : Operation not applicable. 10757 : $2A05 : Table is not indexed. 10758 : $2A06 : Engine not initialized. 10759 : $2A07 : Attempt to re-initialize Engine. 10760 : $2A08 : Attempt to mix objects from different sessions. 10761 : $2A09 : Paradox driver not active. 10762 : $2A0A : Driver not loaded. 10763 : $2A0B : Table is read only. 10764 : $2A0C : No associated index. 10765 : $2A0D : Table(s) open. Cannot perform this operation. 10766 : $2A0E : Table does not support this operation. 10767 : $2A0F : Index is read only. 10768 : $2A10 : Table does not support this operation because it is not uniquely indexed. 10769 : $2A11 : Operation must be performed on the current session. 10770 : $2A12 : Invalid use of keyword. 10771 : $2A13 : Connection is in use by another statement. 10772 : $2A14 : Passthrough SQL connection must be shared Os Error not handled by Idapi 11009 : $2B01 : Invalid function number. 11010 : $2B02 : File or directory does not exist. 11011 : $2B03 : Path not found. 11012 : $2B04 : Too many open files. You may need to increase MAXFILEHANDLE limit in IDAPI configuration. 11013 : $2B05 : Permission denied. 11014 : $2B06 : Bad file number. 11015 : $2B07 : Memory blocks destroyed. 11016 : $2B08 : Not enough memory. 11017 : $2B09 : Invalid memory block address. 11018 : $2B0A : Invalid environment. 11019 : $2B0B : Invalid format. 11020 : $2B0C : Invalid access code. 11021 : $2B0D : Invalid data. 11023 : $2B0F : Device does not exist. 11024 : $2B10 : Attempt to remove current directory. 11025 : $2B11 : Not same device. 11026 : $2B12 : No more files. 11027 : $2B13 : Invalid argument. 11028 : $2B14 : Argument list is too long. 11029 : $2B15 : Execution format error. 11030 : $2B16 : Cross-device link. 11041 : $2B21 : Math argument. 11042 : $2B22 : Result is too large. 11043 : $2B23 : File already exists. 11047 : $2B27 : Unknown internal operating system error. 11058 : $2B32 : Share violation. 11059 : $2B33 : Lock violation. 11060 : $2B34 : Critical DOS Error. 11061 : $2B35 : Drive not ready. 11108 : $2B64 : Not exact read/write. 11109 : $2B65 : Operating system network error. 11110 : $2B66 : Error from NOVELL file server. 11111 : $2B67 : NOVELL server out of memory. 11112 : $2B68 : Record already locked by this workstation. 11113 : $2B69 : Record not locked. Network related 11265 : $2C01 : Network initialization failed. 11266 : $2C02 : Network user limit exceeded. 11267 : $2C03 : Wrong .NET file version. 11268 : $2C04 : Cannot lock network file. 11269 : $2C05 : Directory is not private. 11270 : $2C06 : Directory is controlled by other .NET file. 11271 : $2C07 : Unknown network error. 11272 : $2C08 : Not initialized for accessing network files. 11273 : $2C09 : SHARE not loaded. It is required to share local files. 11274 : $2C0A : Not on a network. Not logged in or wrong network driver. 11275 : $2C0B : Lost communication with SQL server. 11277 : $2C0D : Cannot locate or connect to SQL server. 11278 : $2C0E : Cannot locate or connect to network server. Optional parameter related 11521 : $2D01 : Optional parameter is required. 11522 : $2D02 : Invalid optional parameter. Query related 11777 : $2E01 : obsolete 11778 : $2E02 : obsolete 11779 : $2E03 : Ambiguous use of ! (inclusion operator). 11780 : $2E04 : obsolete 11781 : $2E05 : obsolete 11782 : $2E06 : A SET operation cannot be included in its own grouping. 11783 : $2E07 : Only numeric and date/time fields can be averaged. 11784 : $2E08 : Invalid expression. 11785 : $2E09 : Invalid OR expression. 11786 : $2E0A : obsolete 11787 : $2E0B : bitmap 11788 : $2E0C : CALC expression cannot be used in INSERT, DELETE, CHANGETO and SET rows. 11789 : $2E0D : Type error in CALC expression. 11790 : $2E0E : CHANGETO can be used in only one query form at a time. 11791 : $2E0F : Cannot modify CHANGED table. 11792 : $2E10 : A field can contain only one CHANGETO expression. 11793 : $2E11 : A field cannot contain more than one expression to be inserted. 11794 : $2E12 : obsolete 11795 : $2E13 : CHANGETO must be followed by the new value for the field. 11796 : $2E14 : Checkmark or CALC expressions cannot be used in FIND queries. 11797 : $2E15 : Cannot perform operation on CHANGED table together with a CHANGETO query. 11798 : $2E16 : chunk 11799 : $2E17 : More than 255 fields in ANSWER table. 11800 : $2E18 : AS must be followed by the name for the field in the ANSWER table. 11801 : $2E19 : DELETE can be used in only one query form at a time. 11802 : $2E1A : Cannot perform operation on DELETED table together with a DELETE query. 11803 : $2E1B : Cannot delete from the DELETED table. 11804 : $2E1C : Example element is used in two fields with incompatible types or with a BLOB. 11805 : $2E1D : Cannot use example elements in an OR expression. 11806 : $2E1E : Expression in this field has the wrong type. 11807 : $2E1F : Extra comma found. 11808 : $2E20 : Extra OR found. 11809 : $2E21 : One or more query rows do not contribute to the ANSWER. 11810 : $2E22 : FIND can be used in only one query form at a time. 11811 : $2E23 : FIND cannot be used with the ANSWER table. 11812 : $2E24 : A row with GROUPBY must contain SET operations. 11813 : $2E25 : GROUPBY can be used only in SET rows. 11814 : $2E26 : Use only INSERT, DELETE, SET or FIND in leftmost column. 11815 : $2E27 : Use only one INSERT, DELETE, SET or FIND per line. 11816 : $2E28 : Syntax error in expression. 11817 : $2E29 : INSERT can be used in only one query form at a time. 11818 : $2E2A : Cannot perform operation on INSERTED table together with an INSERT query. 11819 : $2E2B : INSERT, DELETE, CHANGETO and SET rows may not be checked. 11820 : $2E2C : Field must contain an expression to insert (or be blank). 11821 : $2E2D : Cannot insert into the INSERTED table. 11822 : $2E2E : Variable is an array and cannot be accessed. 11823 : $2E2F : Label 11824 : $2E30 : Rows of example elements in CALC expression must be linked. 11825 : $2E31 : Variable name is too long. 11826 : $2E32 : Query may take a long time to process. 11827 : $2E33 : Reserved word or one that can't be used as a variable name. 11828 : $2E34 : Missing comma. 11829 : $2E35 : Missing ). 11830 : $2E36 : Missing right quote. 11831 : $2E37 : Cannot specify duplicate column names. 11832 : $2E38 : Query has no checked fields. 11833 : $2E39 : Example element has no defining occurrence. 11834 : $2E3A : No grouping is defined for SET operation. 11835 : $2E3B : Query makes no sense. 11836 : $2E3C : Cannot use patterns in this context. 11837 : $2E3D : Date does not exist. 11838 : $2E3E : Variable has not been assigned a value. 11839 : $2E3F : Invalid use of example element in summary expression. 11840 : $2E40 : Incomplete query statement. Query only contains a SET definition. 11841 : $2E41 : Example element with ! makes no sense in expression. 11842 : $2E42 : Example element cannot be used more than twice with a ! query. 11843 : $2E43 : Row cannot contain expression. 11844 : $2E44 : obsolete 11845 : $2E45 : obsolete 11846 : $2E46 : No permission to insert or delete records. 11847 : $2E47 : No permission to modify field. 11848 : $2E48 : Field not found in table. 11849 : $2E49 : Expecting a column separator in table header. 11850 : $2E4A : Expecting a column separator in table. 11851 : $2E4B : Expecting column name in table. 11852 : $2E4C : Expecting table name. 11853 : $2E4D : Expecting consistent number of columns in all rows of table. 11854 : $2E4E : Cannot open table. 11855 : $2E4F : Field appears more than once in table. 11856 : $2E50 : This DELETE, CHANGE or INSERT query has no ANSWER. 11857 : $2E51 : Query is not prepared. Properties unknown. 11858 : $2E52 : DELETE rows cannot contain quantifier expression. 11859 : $2E53 : Invalid expression in INSERT row. 11860 : $2E54 : Invalid expression in INSERT row. 11861 : $2E55 : Invalid expression in SET definition. 11862 : $2E56 : row use 11863 : $2E57 : SET keyword expected. 11864 : $2E58 : Ambiguous use of example element. 11865 : $2E59 : obsolete 11866 : $2E5A : obsolete 11867 : $2E5B : Only numeric fields can be summed. 11868 : $2E5C : Table is write protected. 11869 : $2E5D : Token not found. 11870 : $2E5E : Cannot use example element with ! more than once in a single row. 11871 : $2E5F : Type mismatch in expression. 11872 : $2E60 : Query appears to ask two unrelated questions. 11873 : $2E61 : Unused SET row. 11874 : $2E62 : INSERT, DELETE, FIND, and SET can be used only in the leftmost column. 11875 : $2E63 : CHANGETO cannot be used with INSERT, DELETE, SET or FIND. 11876 : $2E64 : Expression must be followed by an example element defined in a SET. 11877 : $2E65 : Lock failure. 11878 : $2E66 : Expression is too long. 11879 : $2E67 : Refresh exception during query. 11880 : $2E68 : Query canceled. 11881 : $2E69 : Unexpected Database Engine error. 11882 : $2E6A : Not enough memory to finish operation. 11883 : $2E6B : Unexpected exception. 11884 : $2E6C : Feature not implemented yet in query. 11885 : $2E6D : Query format is not supported. 11886 : $2E6E : Query string is empty. 11887 : $2E6F : Attempted to prepare an empty query. 11888 : $2E70 : Buffer too small to contain query string. 11889 : $2E71 : Query was not previously parsed or prepared. 11890 : $2E72 : Function called with bad query handle. 11891 : $2E73 : QBE syntax error. 11892 : $2E74 : Query extended syntax field count error. 11893 : $2E75 : Field name in sort or field clause not found. 11894 : $2E76 : Table name in sort or field clause not found. 11895 : $2E77 : Operation is not supported on BLOB fields. 11896 : $2E78 : General BLOB error. 11897 : $2E79 : Query must be restarted. 11898 : $2E7A : Unknown answer table type. 11926 : $2E96 : Blob cannot be used as grouping field. 11927 : $2E97 : Query properties have not been fetched. 11928 : $2E98 : Answer table is of unsuitable type. 11929 : $2E99 : Answer table is not yet supported under server alias. 11930 : $2E9A : Non-null blob field required. Can't insert records 11931 : $2E9B : Unique index required to perform changeto 11932 : $2E9C : Unique index required to delete records 11933 : $2E9D : Update of table on the server failed. 11934 : $2E9E : Can't process this query remotely. 11935 : $2E9F : Unexpected end of command. 11936 : $2EA0 : Parameter not set in query string. 11937 : $2EA1 : Query string is too long. 11946 : $2EAA : No such table or correlation name. 11947 : $2EAB : Expression has ambiguous data type. 11948 : $2EAC : Field in order by must be in result set. 11949 : $2EAD : General parsing error. 11950 : $2EAE : Record or field constraint failed. 11951 : $2EAF : When GROUP BY exists, every simple field in projectors must be in GROUP BY. 11952 : $2EB0 : User defined function is not defined. 11953 : $2EB1 : Unknown error from User defined function. 11954 : $2EB2 : Single row subquery produced more than one row. 11955 : $2EB3 : Expressions in group by are not supported. 11956 : $2EB4 : Queries on text or ascii tables is not supported. 11957 : $2EB5 : ANSI join keywords USING and NATURAL are not supported in this release. 11958 : $2EB6 : SELECT DISTINCT may not be used with UNION unless UNION ALL is used. 11959 : $2EB7 : GROUP BY is required when both aggregate and non-aggregate fields are used in result set. 11960 : $2EB8 : INSERT and UPDATE operations are not supported on autoincrement field type. 11961 : $2EB9 : UPDATE on Primary Key of a Master Table may modify more than one record. 11962 : $2EBA : Queries on MS ACCESS tables are not supported by local query engines. 11963 : $2EBB : Preparation of field-level constraint failed. 11964 : $2EBC : Preparation of field default failed. 11965 : $2EBD : Preparation of record-level constraint failed. 11972 : $2EC4 : Constraint Failed. Expression: Version Mismatch Category 12033 : $2F01 : Interface mismatch. Engine version different. 12034 : $2F02 : Index is out of date. 12035 : $2F03 : Older version (see context). 12036 : $2F04 : .VAL file is out of date. 12037 : $2F05 : BLOB file version is too old. 12038 : $2F06 : Query and Engine DLLs are mismatched. 12039 : $2F07 : Server is incompatible version. 12040 : $2F08 : Higher table level required Capability not supported 12289 : $3001 : Capability not supported. 12290 : $3002 : Not implemented yet. 12291 : $3003 : SQL replicas not supported. 12292 : $3004 : Non-blob column in table required to perform operation. 12293 : $3005 : Multiple connections not supported. 12294 : $3006 : Full dBASE expressions not supported. 12295 : $3007 : Nested transactions not supported. System configuration error 12545 : $3101 : Invalid database alias specification. 12546 : $3102 : Unknown database type. 12547 : $3103 : Corrupt system configuration file. 12548 : $3104 : Network type unknown. 12549 : $3105 : Not on the network. 12550 : $3106 : Invalid configuration parameter. Warnings 12801 : $3201 : Object implicitly dropped. 12802 : $3202 : Object may be truncated. 12803 : $3203 : Object implicitly modified. 12804 : $3204 : Should field constraints be checked? 12805 : $3205 : Validity check field modified. 12806 : $3206 : Table level changed. 12807 : $3207 : Copy linked tables? 12809 : $3209 : Object implicitly truncated. 12810 : $320A : Validity check will not be enforced. 12811 : $320B : Multiple records found, but only one was expected. 12812 : $320C : Field will be trimmed, cannot put master records into PROBLEM table. Miscellaneous 13057 : $3301 : File already exists. 13058 : $3302 : BLOB has been modified. 13059 : $3303 : General SQL error. 13060 : $3304 : Table already exists. 13061 : $3305 : Paradox 1.0 tables are not supported. 13062 : $3306 : Update aborted. Compatibility related 13313 : $3401 : Different sort order. 13314 : $3402 : Directory in use by earlier version of Paradox. 13315 : $3403 : Needs Paradox 3.5-compatible language driver. Data Repository related 13569 : $3501 : Data Dictionary is corrupt 13570 : $3502 : Data Dictionary Info Blob corrupted 13571 : $3503 : Data Dictionary Schema is corrupt 13572 : $3504 : Attribute Type exists 13573 : $3505 : Invalid Object Type 13574 : $3506 : Invalid Relation Type 13575 : $3507 : View already exists 13576 : $3508 : No such View exists 13577 : $3509 : Invalid Record Constraint 13578 : $350A : Object is in a Logical DB 13579 : $350B : Dictionary already exists 13580 : $350C : Dictionary does not exist 13581 : $350D : Dictionary database does not exist 13582 : $350E : Dictionary info is out of date - needs Refresh 13584 : $3510 : Invalid Dictionary Name 13585 : $3511 : Dependent Objects exist 13586 : $3512 : Too many Relationships for this Object Type 13587 : $3513 : Relationships to the Object exist 13588 : $3514 : Dictionary Exchange File is corrupt 13589 : $3515 : Dictionary Exchange File Version mismatch 13590 : $3516 : Dictionary Object Type Mismatch 13591 : $3517 : Object exists in Target Dictionary 13592 : $3518 : Cannot access Data Dictionary 13593 : $3519 : Cannot create Data Dictionary 13594 : $351A : Cannot open Database Driver related 15873 : $3E01 : Wrong driver name. 15874 : $3E02 : Wrong system version. 15875 : $3E03 : Wrong driver version. 15876 : $3E04 : Wrong driver type. 15877 : $3E05 : Cannot load driver. 15878 : $3E06 : Cannot load language driver. 15879 : $3E07 : Vendor initialization failed. 15880 : $3E08 : Your application is not enabled for use with this driver.ТЕХНОЛОГИЯ DCOM
Настройка системы безопасности DCOM сервера Как я понял, основная проблема в DCOM, с которой сталкиваются разработчики - настройка системы безопасности. Далее описано, как были сделаны настройки безопасности у меня.
Создана группа, в которую включены пользователи, которым нужен доступ к данному DCOM серверу (назовем ее DCOM_DEBUG).
В DCOMCNFG : (это было добавлено и на сервере и на клиенте) DefaultSecurity -> Default Access Permissions DCOM_DEBUG: Allow Access SYSTEM: Allow Access Everyone: Allow Access 2.DefaultSecurity -> Default Launch Permissions DCOM_DEBUG: Allow Launch SYSTEM: Allow Launch INTERACTIVE: Allow Launch Everyone: Allow Launch 3.DefaultSecurity -> Default Configuration Permissions SYSTEM: Full Control DCOM_DEBUG: Full Control Everyone: Full Control Установка этих параметров необходима, по-моему, потому, что контекст безопасности интерфейса передаваемого на сервер для нотификации клиента берется из установок по умолчанию.
Только на сервере.
Установки параметров безопасности для объекта были установлены точно такие же, за исключением того, что Everyone включена не была. На вкладке Identity был выбран пользователь, от имени которого запускается COM сервер. Одна тонкость: у пользователя, от имени которого запускается COM сервер должно быть право "Log on as batch job", иначе сервер не запустится (это право было дано всей группе DCOM_DEBUG). Если выбрать Interactive User, то сервер не запустится, в том случае если пользователь делает Logoff. В случае с Launching User происходили какие-то невнятные проблемы (видимо это было связано со спецификой решаемой мной задачи - DCOM сервер с поддержкой множественных клиентских соединений).
Алексей Вуколов
Статьи по теме:
TExcelManager
Компонент предназначен для работы с таблицами Excel. Он позволяет находить любые таблицы в любом месте документа Excel и импортировать их в таблицы компонента TTable. Можно также экспортировать таблицы из TTable в документы Excel. Существует две версии компонента - для Microsoft Office 2000 и для Microsoft Office XP.
TPrintService
Комментарий Дмитрия Васильева: Как было уже сказано: Компонент предназначен для реализации всех функций, связанных с выводом на печать: выбор принтера, его настройка, предварительный просмотр и собственно печать.
Ключевым событием для TPrintService является OnDraw(Sender: TObject; Canvas: TCanvas; PageNumber: Integer; DrawTarget: TDrawTarget), где TDrawTarget = (dtPreview, dtPrint). Именно в этом событии производится определение содержимого документа. В минимальном варианте использования компонента пользователю достаточно определить только это событие. При выводе должны использоваться свойства PageWidth и PageHeight объекта Printer для определения ширины и высоты листа. Преобразование координат для предварительного просмотра происходит без участия пользователя. Все, что нужно сделать, это вывести изображение на передаваемую Canvas в масштабе принтера. Шрифты масштабируются автоматически (это уже дело Windows), поэтому, вне зависимости от модели принтера и установленного разрешения, шрифт размером, скажем, 10, будет выглядеть одинаково при печати из CorelDraw, Word97 и PrintService. Следует использовать именно размер шрифта (Size), т.к. высота (Heigth) изменяется в зависимости от текущего разрешения принтера. В PageNumber передается номер страницы. При многостраничной печати пользователь может определить вывод для всех страниц с номерами 1..PageCount. В DrawTarget содержится информация о том, куда в данный момент производится вывод - в окно предварительного просмотра или на принтер. Эта информация, вообще говоря, не является необходимой, НО, вдруг кому-нибудь захочется проанализировать количество цветов принтера и сделать черно-белый вывод на черно-белый принтер при цветном изображении в окне предварительного просмотра?
Комментарий Алексея Румянцева: Короче говоря, в OnDraw, вы сами определяете то что выводится на принтер (или в окно предварительного просмотра), просто рисуя это на канве.
TRyMenu — собственная отрисовка меню
| Раздел Сокровищница |
| Перестала мне тут на днях нравиться борландовская прорисовка меню... Вот вобщем-то и все что можно сказать о представленном Вашему вниманию классе TRyMenu.
Никаких дочерних классов, вешаемся на OnAdvancedDrawItem и далее чисто рисование по канве. Ну а художественные фантазии они у каждого свои и чуть напрягшись на ней(на канве) можно и переливы и пейзаж нарисовать, но кто этим балуется наверняка уже свои классы имеет, а это так минимальный набор для прорисовки меню в новом стиле. Демо прилагается. Написано на Delphi5. Тестировалось на Win98. WinXP. Ваши вопросы и замечания присылайте. |  |
Скачать проект (10K) 22.04.02
Алексей Румянцев
.
Специально для
TRyPrintService
Основное отличие от TPrintService - это наличие "буфера печати", т.е. вам остается заполнить его содержимым (линиями, прямоугольниками, текстом, картинками...) причем не связывая себя какими-либо рамками (в частности размером и положением или вообще отсутствием необходимого элемента в данном конкретном месте отчета), т.е. каждый лист отчета может быть оформлен по своим правилам или без правил. Весь результат работы хранится в этом "буфере" откуда может быть предворительно просмотрен в окне предварительного просмотра, распечатан, скопирован, сохранен, экспортирован (надеюсь вскоре добраться до этой функции) и т.п. Для этого были созданы специальные объекты (RptRect, RptLine, RptEdit, RptBitmap, список легко может быть расширен), параметры (property) которых заполняются пользовательскими значениями (Left, Top..., Color..., Text и т.д.) в соответствии с которыми будет меняться их положение на странице, цвет, текст и т.д.
RptOбъекты создаются только один раз, после чего у них меняются лишь значения параметров и затем отправляются с новыми значениями в очередь на печать, где и дожидаются своего звездного часа. RptОбъекты могут отправляться в буфер отчета в любой последовательности, в любом кол-ве и с любым положением на странице. В демонстрационном примере показано, как создавать новый отчет, заполнить его некоторой информацией (прямоугольники, текст, картинки); сохранять в файле и загружать из него отчет, а также как вызывать предварительный просмотр и печатать.
Скачать: (193 K)
С уважением, Алексей Румянцев.
Специально для
TRySharedSream — класс упрощающий работу с файлом подкачки
| Раздел Сокровищница |
TSharedStream (версия 1).
Когда-то (кажется год назад) на страницах "королевства" я прочитал статью об использовании файла подкачки как о временном хранилище данных. ( Имеется ввиду статья Дмитрия Логинова ) После этой статьи я заинтересовался работой с Swap'ом.
Некотое время в работе я пользовался чисто FileMappingFun'кциями, что оказалось нудно и трудоемко (не так чтобы очень, но согласитесь, что легче хранить всю информацию в одном месте[классе], чем иметь несколько переменных и помнить когда и как их надо использовать).
Написал первую версию класса-обертки над FileMappingFun'кциями и все как-будто было нормально, но убивало одно НО - не было возможности изменять размер области["страницы"] под данные выделенной при ее создании, т.е. надо было заранее знать размер информации, которую вы собираетесь в нее записать. В TSharedStream я решил эту проблему, плохо или хорошо трудно сказать - по сравнению с невозможностью изменить размер - хорошо, а по качеству реализации - не очень.
Подробнее ...
Прошло н-ное кол-во времени, появилось желание сделать работу класса правильней, действенней, качественней (нужного слова не подобрать).
TSelectableTree - TTreeView с возможностью MultiSelect'а
TSelectableTree - наследник от TCustomTreeView, обладает возможностью множественного выбора ( свойство MultiSelect ).
Соответственно дополнительные методы - procedure SelectAll; procedure UnSelectAll; procedure InvertSelection; Свойство DefaultPopup = True назначает для дерева PopUp-меню (по правой кнопке мыши) со следующими пунктами: Отметить все Снять все пометки Инверсия выделения И еще всякие полезные мелочи. Например, очень удобная процедура для обработки каждой ветки дерева: procedure TraverseTree(TreeView: TCustomTreeView; Node: TTreeNode; ATraverseTreeEvent : TTVTraverseEvent; AInfo : Pointer); var CNode: TTreeNode; begin if Assigned(ATraverseTreeEvent) then begin if Node = nil then CNode := TTreeView(TreeView).Items.GetFirstNode else CNode := Node; repeat ATraverseTreeEvent(CNode, AInfo); CNode := CNode.GetNext; until (CNode = nil) or (not CNode.HasAsParent(Node)); end; end;
Скачать исходный код (4 K)
Сергей Королев
TSharedSream — класс упрощающий работу с файлом подкачки
| Раздел Сокровищница |
Когда-то (кажется год назад) на страницах "королевства" я прочитал статью об использовании файла подкачки как временном хранилище данных. ( Имеется ввиду статья Дмитрия Логинова ) После этой статьи я заинтересовался Swap'ом. Некотое время я пользовался чисто File Mapping Func'циями, что оказалось нудно и трудоемко(не так чтобы очень, но согласитесь, что легче хранить всю информацию в одном месте[классе], чем иметь несколько переменных и помнить когда и как их надо использовать).
Написал первую версию класса-обертки над File Mapping Func'циями и все как-будто было нормально, но убивало одно НО - не было возможности изменять размер области["страницы"] под данные выделенной при ее создании, т.е. надо было заранее знать размер информации, которую вы собираетесь в нее записать - в данной версии я считаю что мне удалось обойти это недоразумение (подробности в исходнике).
Итак...
Класс TSharedSream — класс упрощающий работу с файлом подкачки. Более того, скрывающий все сложности обращения к File Mapping Func'циям. Этот класс является потомком TStream, следовательно он наследует его поведение, а изучение работы с ним сводится к внимательному прочтению хелпа по TStream'у.
Описание: Реализует и упрощает процесс создания и работу с файлом подкачки. Расширяет возможности работы с объектом отображения данных. Может рассматриваться как альтернатива TFileStream, TMemoryStream. Близкие темы : Глава 12 из книги ми версиями Delphi и Windows, просьба сообщить ется демонстрационный пример использования TSharedStream : (6.2K)
| Раздел Сокровищница | нов, дата публикации 13 февраля 2002г. |
| Компонент TVertGrid представляет собой модифицированный TStringGrid.
В стандартный компонент добавлена возможность в режиме Design-time заполнять первую колонку (property Labels) и первую строку (property Titles) грида. Если набранных строк в Labels больше, чем задано количество строк самого TVertGrid, то они будут автоматически добавлены. Аналогично и с количеством колонок (Titles). На скриншоте показано редактирование списка заголовков колонок. Количество строк в Titles это количество заполненных колонок первой строки. Компонент очень прост и вы можете модифицировать его по своему собственному желанию. |  |
Скачать (1K)
Исходный код компонента:
| unit VertGrid; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, stdctrls; type TVertGrid = class(TStringGrid) protected { Protected declarations } procedure SetLines(Value: TStrings); function GetLines : TStrings; procedure SetTitles(Value: TStrings); function GetTitles : TStrings; public constructor Create(AOwner: TComponent); override; published // Первая колонка property Labels: TStrings read GetLines write SetLines; // Первая строка property Titles: TStrings read GetTitles write SetTitles; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TVertGrid]); end; constructor TVertGrid.Create(AOwner: TComponent); begin inherited Create(AOwner); ColCount := 2; DefaultRowHeight := 16; end; procedure TVertGrid.SetLines(Value: TStrings); begin if Value.Count > RowCount then RowCount := Value.Count; Cols[0].Assign( Value ); end; procedure TVertGrid.SetTitles(Value: TStrings); begin if Value.Count > ColCount then ColCount := Value.Count; Rows[0].Assign( Value ); end; function TVertGrid.GetLines : TStrings; begin result := Cols[0]; end; function TVertGrid.GetTitles : TStrings; begin result := Rows[0]; end; end. |
ULogs.pas
Скачать (2.3 K) unit uLogs; interface uses Classes,Controls,StdCtrls,ComCtrls,Forms; {-------раздел для генерации сообщений----------} {всего одна процедура} procedure (Channel:byte;Mes:String); {номер канала (0 - 255) и текст сообщения} {----------раздел для обработки сообщений----------} Type TChannels = set of byte; TLog = class {абстрактный базовый класс} protected FChannels:TChannels; {множество обрабатываемых каналов} procedure (Channel:byte;Mes:String);virtual;abstract; {InternalToLog - для каждого наследника определяет способ обработки.} {Номер канала передается, чтобы его можно было учесть при обработке,} {например, при выводе диагностических сообщений менять цвет текста} {в зависимости от номера канала} public procedure (Channel:byte;Status:boolean); procedure (Channel:byte;Mes:String);{общий механизм проверки номера канала} constructor Create(AChannels:TChannels); {множество обрабатываемых каналов задается при создании лога} property Channels:TChannels read FChannels write FChannels; {множество обрабатываемых каналов доступно в процессе работы} end; TStringsLog = class(TLog) {добавление строки к содержимому любого наследника абстрактного базового класса TStrings} FStrings:TStrings; {ссылка на объект в который будет добавлена строка} procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;AStrings:TStrings); end; TFileLog = class(TLog) {добавление строки к содержимому файла} FFile:Text; {имя файла} procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;FileName:String); end; TCaptionLog = class(TLog) {вывод текста сообщения в Caption любого компонента - наследника TControl} FControl:TControl; {компонент для отображения} procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;AControl:TControl); end; TStatusBarLog = class(TLog){вывод текста сообщения в StatusPanel} FStatusPanel:TStatusPanel; procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;AStatusPanel:TStatusPanel); end; TMessageBoxLog = class(TLog) {вывод текста сообщения в MessageBox} fCaption:String; fFlags: Longint; procedure (Channel:byte;Mes:String);override; constructor Create(AChannels:TChannels;Caption:String;Flags: Longint); end; function (ALog:TLog):word; {Регистрация нового лога в списке} function (ALog:TLog;Name:string):integer; {Регистрация нового лога в списке под заданным именем, чтобы можно было его удалить} function (Name:string):integer; {Удаление из списка лога с заданным именем} implementation uses Windows; var LogList:TStrings; lLog:TLog; procedure ToLog(Channel:byte;Mes:String); var i:integer; Begin if LogList.Countthen exit; for i:=0 to LogList.Count-1 do TLog(LogList.Objects[i]).toLog(Channel,Mes); End; function SetLog(ALog:TLog):word;{Регистрация нового лога в списке} Begin result:=LogList.AddObject('',ALog); End; function SetNamedLog(ALog:TLog;Name:string):integer; {Регистрация нового лога в списке под заданным именем, чтобы можно было его удалить} var i:integer; Begin result:=-1; {лог под таким именем уже есть} i:=LogList.IndexOf(Name); if i=-1 then result:=LogList.AddObject(Name,ALog); End; function ReSetNamedLog(Name:string):integer; {Удаление из списка лога с заданным именем} var i:integer; Begin result:=LogList.IndexOf(Name); { -1 если лога под таким именем нет} if result<>-1 then LogList.Delete(result); End; { TLog } constructor TLog.Create(AChannels: TChannels); begin FChannels:=AChannels; end; procedure TLog.SetChannel(Channel: byte; Status: boolean); begin if status then FChannels:=FChannels+[channel] else FChannels:=FChannels-[channel]; end; procedure TLog.toLog(Channel: byte; Mes: String); begin if (Channel in FChannels) then InternalToLog(Channel,Mes); end; { TStringsLog } constructor TStringsLog.Create(AChannels: TChannels; AStrings: TStrings); begin inherited Create(AChannels); FStrings:=AStrings; end; procedure TStringsLog.InternalToLog(Channel: byte; Mes: String); begin FStrings.Add(Mes); end; { TFileLog } constructor TFileLog.Create(AChannels: TChannels; FileName: String); begin inherited Create(AChannels); AssignFile(FFile,FileName); Rewrite(FFile); Writeln(FFile, 'Log file start'); CloseFile(FFile); end; procedure TFileLog.InternalToLog(Channel: byte; Mes: String); begin Append(fFile); Writeln(fFile, mes); Flush(fFile); CloseFile(fFile); end; { TCaptionLog } constructor TCaptionLog.Create(AChannels: TChannels; AControl: TControl); begin inherited Create(AChannels); FControl:=AControl; end; procedure TCaptionLog.InternalToLog(Channel: byte; Mes: String); begin TLabel(FControl).Caption:=Mes; // FControl.Caption:=Mes; end; { TStatusBarLog } constructor TStatusBarLog.Create(AChannels: TChannels; AStatusPanel: TStatusPanel); begin inherited Create(AChannels); FStatusPanel:=AStatusPanel; end; procedure TStatusBarLog.InternalToLog(Channel: byte; Mes: String); begin FStatusPanel.text:=Mes; end; { TMassageBoxLog } constructor TMessageBoxLog.Create(AChannels: TChannels; Caption: String; Flags: Integer); begin inherited create(AChannels); fCaption:=Caption; fFlags:=Flags; end; procedure TMessageBoxLog.InternalToLog(Channel: byte; Mes: String); begin Application.MessageBox(PChar(Mes), PChar(fCaption), fFlags); end; initialization LogList:=TStringList.create; lLog:=TMessageBoxLog.Create([0..5],'Ошибка инициализации', MB_OK); // Каналы с 0 по 5 зарезервированы для ошибок инициализации модулей SetLog(lLog); finalization LogList.free; end.
Управление чужим приложением средствами WinAPI
Просмотрев в королевстве на данную тему множество вопросов, оставшихся без ответов, сам нашел решение проблеммы управления чужим приложением. Данный код ищет чужое приложение,запускает в нем 2 пункт 7 подпункт меню, в появившемся диалоге выбора файла ищет класс Edit c текстом '', вводит в класс Edit строку с именем файла и отсылает команду Enter. Далее ищет появление диалогового окна с предложением подтвердить загрузку. После ищет кнопку "Да" и отсылает команду Enter.
Напомню, что все диалоговые окна — это главные окна, которые ищутся FindWindow, а всякие Edit,Button,ComboBox и т.д. - это дочерние окна, которые ищутся функцией FindWindowEx.
| procedure TForm1.Button9Click(Sender: TObject); Var Men :HMenu; Hnd,HndDialog,HndControl,HndAsc,HndBtn :HWnd; HndMen,HndSMen :HMenu; StrClass :PChar; StrBase :string; IdBtn,idMen :integer; begin Hnd:=FindWindow(nil, 'Конфигуратор - 2345'); if Hnd <>0 then begin //фокусируем: windows.SetForegroundWindow(Hnd); //или можно так:windows.BringWindowToTop(Hnd); //Работа с меню: //=============================================================================== HndMen:=GetMenu(Hnd);//получили описатель главного меню окна. HndSMen:=GetSubMenu(HndMen,1);//получили описатель второго пункта главного меню (0 -первый пункт) //получили идентификатор 7 пункта подменюменю (черты в меню - это также пункты) idMen:=GetMenuItemID(HndSMen,6); //в данном случае idMen это word(33206) if idMen<>0 then begin //запускаем пункт меню. Именно PostMessage, SendMessage - не работает. PostMessage(Hnd,WM_COMMAND,idMen,0); //=============================================================================== //Инициализируем переменные диалогов: HndDialog:=0; HndControl:=0; HndBtn:=0; HndAsc:=0; IdBtn:=0; //=============================================================================== //поищем диалог ввода до тех пор пока не найдем: While HndDialog=0 do HndDialog:= FindWindow(nil, 'Открыть файл конфигурации'); if HndDialog<>0 then begin StrClass:='Edit'+#0;//на всякий случай вставим завершающий ноль //Ищем класс Edit среди подчиненных HndDialog окон HndControl:=FindWindowEx(HndDialog,0,StrClass,''); if HndControl<>0 then begin StrBase:='D:\md\zik2345\1Cv7.MD'; Sleep(1000);//а вот без этого ну ни как не хочет работать. SendMessage(HndControl, WM_Settext,0,Integer(StrBase));//все, текст переменной StrBase введен. //жмем Enter SendMessage(HndDialog,WM_Command,MakeWParam(1,$0f),HndControl); //здесь 1 это значит что мы передаем на выполнение акселератор //строки, а $0f - это событие "(Enter)" этому акселератору //в MSDN смотрим WM_Command. //MakeWParam - функция которая два Word слова помещает : //первое в верхние 16 bit, второе в нижние 16 bit, 32 битного(LongInt) //параметра WParam (аналог MakeLParam ). //=============================================================================== //ищем диалог пока не найдем: while HndAsc=0 do HndAsc:= FindWindow(nil, 'Конфигуратор'); if HndAsc<>0 then begin //ищем кнопку в диалоге: //обращаем внимание на знак & - если на кнопку завязана комбинация клавиш //(это когда буква в кнопке подчеркнута) //то надо к имени добавлять перед этой буквой & а то кнопочка не найдется если их несколько. while HndBtn=0 do HndBtn:=FindWindowEx(HndAsc,0,'Button','&Да'); if HndBtn<>0 then begin IdBtn:=GetDlgCtrlID(HndBtn); if IdBtn<>0 then begin //ну и наконец жмем кнопку '&Да': SendMessage(HndAsc,WM_Command,MakeWParam(IdBtn,BN_CLICKED),HndBtn); //а хелп MSDN по BN_CLICKED или WM_Command //здесь верхнее слово WParam это идентификатор контрола, а нижнее - код BN_CLICKED end; end; end; //================================================================================ end; end; end; end; end; |
Userunit
| | "Knowledge itself is power" F.Bacon |
| Функция для представления числа прописью |
Внедрение и линковка компонентов. Пример.
| Раздел Сокровищница | рбань С.В., дата публикации 18 марта 2002г. |
Модуль демонстрирует возможности по "Внедрению" и "Сцепке" компонентов. В основном все д/б понятно из подстрочных комментариев. Для чего нужно: Задача - содать специализированный LightWeight вариант TChart. Работа ведется несколькими программистами. ВСЕ элементы д/б объектами, а по возможности и самостоятельными компонентами. Например - полоса скроллинга по данным. Она должна быть либо "встроенной" (принадлежать базовому компоненту) либо внешней. Причем при работе (в приложении) различий быть не должно...
Первый маленький элемент - полоса скроллинга по данным и контейнер для нее. Компонент вполне самостоятельный и вполне может быть полезен Вне контекста задачи.
Примечания: 1. В первую очередь проект предназначен для обучения. В том числе и меня :-)) Поэтому "не стреляйте в пианиста...". Если есть лучшее решение - ДАВАЙТЕ ЕГО СЮДА!!!->>> Fox1225@Mail.ru 2. Весь код приведенный здесь может использоваться As Is и все такое... Я не силен в лицензионных соглашениях. Просто берите и пользуйтесь. На свой страх и риск, разумеется :-)) 3. Все Ваши комментарии можно мылить по адресу: Fox1225@Mail.ru} Глюкобаги: 1. Гляньте в конструктор. Там есть вопросик... 2. Есть БОЛЬШАЯ бяка - смотрите TModContainer.CreateComponent unit AltChartMain; interface {Заранее извиняюсь за цветовую гамму... Делайте как кому нравится :-)} {ВНИМАНИЕ!!!! Пример тестировался под D6, и меня предупредили, что в D5 нет SetSubComponent. Самому проверить негде, так что будте внимательны!} uses Windows, Messages, SysUtils, Classes, Controls, StdCtrls, ExtCtrls, Graphics, Math, MyMath; resourcestring SMinMaxError = 'Max ДОЛЖЕН быть больше Min. EMinMaxError.'+Chr(13)+Chr(13); type EMinMaxError = class(Exception); //Попытка задать Min > Max TGraphScrollKind = (skHorizontal, skVertical); TGraphScrollLayout = (slTop, slCenter, slBottom); //Полоса скроллинга по данным TGraphScroll = class(TGraphicControl) private FLineWidth: Integer; FLineColor: TColor; FSliderWidth: Integer; FSliderLength: Integer; FSliderColor: TColor; FHSC: Integer; //Horisontal Slider Center. Для ускорения отрисовки. FVSC: Integer; //Vertical Slider Center. Для ускорения отрисовки. FPosition: Integer; FSliderRect: TRect; //Это чтобы по быстрому определить, ткнули мы мышом по слайдеру или нет... FMin: Integer; FMax: Integer; FSliderCaptured: Boolean; FGraphScrollKind: TGraphScrollKind; //Слайдер зацепили мышом... FBegDragCoord: TPoint; //Коорд. мыша в момент "зацепа" FBegDragPos: Integer; //Position в момент "зацепа" FGraphScrollLayout: TGraphScrollLayout; procedure (const Index, Value: Integer); procedure (const Index: Integer; const Value: TColor); procedure (AMin, AMax, APosition: Integer); procedure ; procedure (const Value: Integer); procedure (const Value: Integer); procedure (const Index, Value: Integer); procedure (const Value: TGraphScrollKind); procedure (const Value: TGraphScrollLayout); protected procedure ; override; procedure ; override; procedure (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure (Shift: TShiftState; X, Y: Integer); override; procedure (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure (var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); override; procedure ; override; function (var NewWidth, NewHeight: Integer): Boolean; override; public constructor Create(AOwner: TComponent); override; published property Anchors; property Align; property AutoSize; property LineColor: TColor index 0 read FLineColor write SetColor; property SliderColor: TColor index 1 read FSliderColor write SetColor; property LineWidth: Integer index 0 read FLineWidth write SetGeometry; property SliderWidth: Integer index 1 read FSliderWidth write SetGeometry; property SliderLength: Integer index 2 read FSliderLength write SetGeometry; property Position: Integer index 0 read FPosition write SetPosition; property Min: Integer read FMin write SetMin; property Max: Integer read FMax write SetMax; property Kind: TGraphScrollKind read FGraphScrollKind write SetGraphScrollKind; property Layout: TGraphScrollLayout read FGraphScrollLayout write SetGraphScrollLayout; end; //Компонент - контейнер TModContainer = class(TPanel) private FComponent: TGraphScroll; procedure ; procedure (const Value: TGraphScroll); protected procedure (AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; published property Component: TGraphScroll read FComponent write SetComponent; end; procedure ; implementation procedure Register; begin RegisterComponents('Samples', [TGraphScroll, TModContainer]); end; { TGraphScroll } constructor TGraphScroll.Create(AOwner: TComponent); begin Inherited Create(AOwner); //"сетапим" компонент... FLineWidth:=3; FLineColor:=clNavy; FSliderWidth:=7; FSliderLength:=40; FSliderColor:=clTeal; FMax:=100; FPosition:=30; Width:=200; Height:=11; //Странно, но значения меньше 10 НЕ принимаются! Почему? Кто объяснит дремучему? Align:=alBottom; RecalcGeometry; end; procedure TGraphScroll.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; If InRect(X, Y, FSliderRect) Then begin FSliderCaptured:=True; FBegDragCoord.X:=X; FBegDragCoord.Y:=Y; FBegDragPos:=Position; end; end; procedure TGraphScroll.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; If FSliderCaptured Then If Kind = skHorizontal Then Position:=FBegDragPos+Round((X-FBegDragCoord.X)*(Max-Min)/Width) Else Position:=FBegDragPos+Round((Y-FBegDragCoord.Y)*(Max-Min)/Height); end; procedure TGraphScroll.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; FSliderCaptured:=False; Refresh; end; procedure TGraphScroll.RecalcGeometry; Var WorkZone: Integer; begin //Гммм... если кто-нибудь сможет упростить эти монструозные формулы - буду благодарен... //Однако будте внимательны! //If по Kind'у меня уже достал... Нужно как-то более гибко... If Kind = skHorizontal Then begin WorkZone:=Width - SliderLength - SliderWidth - 3; //Левый край FSliderRect.Left:=Round(WorkZone*(FPosition-FMin)/(FMax-FMin))+SliderWidth div 2 + 2; //Правый край FSliderRect.Right:=FSliderRect.Left+SliderLength; //Горизонтальный центр слайдера (нужен для рисования риски) FHSC:=EnsureRange(FSliderRect.Left+Floor(SliderLength / 2), 0, Width-1); //"Вертикальные" параметры. Зависят от Layout. Case Layout of //ВНИМАНИЕ!!!! Может кому пригодится! У нас есть св-во Max, а нам нужна ф-ия Max из //модуля Math. Поэтому - Math.Max. Вроде-бы просто, но какую я шишку год назад набил на этом... slTop: FVSC:=Math.Max(SliderWidth, LineWidth) div 2; slCenter: FVSC:=Height div 2; slBottom: FVSC:=Height - Math.Max(SliderWidth, LineWidth) div 2 - 2; End; //Верх бегунка FSliderRect.Top:=FVSC - SliderWidth div 2; //Низ бегунка FSliderRect.Bottom:=FSliderRect.Top+SliderWidth; end Else begin WorkZone:=Height - SliderLength - SliderWidth - 3; //Верх бегунка FSliderRect.Top:=Round(WorkZone*(FPosition-FMin)/(FMax-FMin))+SliderLength div 2 + 2; //Низ бегунка FSliderRect.Bottom:=FSliderRect.Top+SliderLength; //Горизонтальный центр (при skVertical становится Вертикальным Центром) слайдера (нужен для рисования риски) FHSC:=EnsureRange(FSliderRect.Top+Floor(SliderLength / 2), 0, Height-1); //"Вертикальные" параметры. Зависят от Layout. Case Layout of //ВНИМАНИЕ!!!! Может кому пригодится! У нас есть св-во Max, а нам нужна ф-ия Max из //модуля Math. Поэтому - Math.Max. Вроде-бы просто, но какую я шишку год назад набил на этом... slTop: FVSC:=Math.Max(SliderWidth, LineWidth) div 2; slCenter: FVSC:=Width div 2; slBottom: FVSC:=Width - Math.Max(SliderWidth, LineWidth) div 2 - 2; End; //Левый край бегунка FSliderRect.Left:=FVSC - SliderWidth div 2; //Правый край бегунка FSliderRect.Right:=FSliderRect.Left+SliderWidth; end; end; procedure TGraphScroll.Paint; Var LWD2: Integer; //LineWidth div 2// begin //Предложения по "украшательству" компонента принимаются с радостью, но только не в ущерб СКОРОСТИ //Предложения, как избавиться от мерцания, принимаются ВНЕ очереди! //С удовольствием выслушаю предложения, как избавиться от If'ов по Kind'у. Уж больно громоздко... LWD2:=LineWidth div 2 + 1; //При рисовании толстой линии ее концы скругляются "наружу", чтобы их НЕ //подрезать (красиво выглядит), даем для них отступ... With Canvas do begin //Рисуем линию. Без комментариев... Pen.Width:=LineWidth; Pen.Color:=LineColor; If Kind = skHorizontal Then begin MoveTo(LWD2, FVSC);//0 + ширина линии | Так получаются скругленные концы LineTo(Width-LWD2-1, FVSC); //ширина - ширина линии | end Else begin MoveTo(FVSC, LWD2); //0 + ширина линии | Так получаются скругленные концы LineTo(FVSC, Height-LWD2-1); //ширина - ширина линии | end; //Рисуем "слайдер" (бегунок, он же ползунок, по буржуйски - Slider). Без комментариев... Pen.Width:=SliderWidth; Pen.Color:=SliderColor; If Kind = skHorizontal Then begin MoveTo(FSliderRect.Left, FVSC); LineTo(FSliderRect.Right, FVSC); end Else begin MoveTo(FVSC, FSliderRect.Top); LineTo(FVSC, FSliderRect.Bottom); end; //Рисуем центральную риску на бегунке. Pen.Width:=1; If FSliderCaptured Then //Если бегунок "захвачен" (двигается мышом...) Pen.Color:=clRed //Рисуем красным цветом Else Pen.Color:=clBlack; //Если нет - черным... If Kind = skHorizontal Then begin MoveTo(FHSC, FSliderRect.Top); LineTo(FHSC, FSliderRect.Bottom); end Else begin MoveTo(FSliderRect.Left, FHSC); LineTo(FSliderRect.Right, FHSC); end; end; end; procedure TGraphScroll.Resize; begin //При изменении размера надо пересчитать все переменные, используемы для отрисовки компонента... inherited Resize; RecalcGeometry; Refresh; end; procedure TGraphScroll.SetColor(const Index: Integer; const Value: TColor); begin //Все стандартно... Case Index of 0: FLineColor := Value; 1: FSliderColor:=Value; End; Refresh; end; procedure TGraphScroll.SetGeometry(const Index, Value: Integer); begin //Тоже стандартно... Case Index of 0: FLineWidth:=Value; 1: FSliderWidth:=Value; 2: FSliderLength:=Value; End; RecalcGeometry; Refresh; end; procedure TGraphScroll.SetGraphScrollKind(const Value: TGraphScrollKind); Var Tmp: Integer; begin If FGraphScrollKind <> Value then //Если НЕ текущее значение begin FGraphScrollKind:=Value; //Присвоим новое... If not (csLoading in ComponentState) and //Если не в состоянии загрузки И //Выравнивание alNone или alCustom или alClient ((Align = alNone) or (Align = alCustom) or (Align = alClient)) then begin //"Переворачиваем" компонент (меняем местами высоту и ширину...) Tmp:=Height; Height:=Width; Width:=Tmp; end; end; RecalcGeometry; Refresh; end; procedure TGraphScroll.SetGraphScrollLayout( const Value: TGraphScrollLayout); begin //Процедура смены Layout'а. Все просто... Что такое Layout - смотри TLabel FGraphScrollLayout:=Value; RecalcGeometry; Refresh; end; procedure TGraphScroll.SetMax(const Value: Integer); begin SetValues(FMin, Value, FPosition); end; procedure TGraphScroll.SetMin(const Value: Integer); begin SetValues(Value, FMax, FPosition); end; procedure TGraphScroll.SetPosition(const Index, Value: Integer); begin SetValues(FMin, FMax, Value); end; procedure TGraphScroll.SetValues(AMin, AMax, APosition: Integer); begin If AMax < AMin then //Максимум ДОЛЖЕН быть больше минимума raise EMinMaxError.Create(SMinMaxError+'TGraphScroll.SetValues'); FMin:=AMin; FMax:=AMax; FPosition:=EnsureRange(APosition, FMin, FMax); RecalcGeometry; Refresh; end; procedure TGraphScroll.ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer); //Перекрыв этот метод TControl можно задать мин и макс. р-ры компонента. //В нашем случае - компонент не может быть ниже ширины Math.Max(LineWidth, SliderWidth); //И уже MinWidth:=SliderLength+2*LineWidth+2*SliderWidth; //ЕСЛИ вертикально расположенный - наоборот... begin If Kind = skHorizontal Then begin MinWidth:=SliderLength+2*LineWidth+2*SliderWidth; MinHeight:=Math.Max(LineWidth, SliderWidth); end Else begin MinWidth:=Math.Max(LineWidth, SliderWidth); MinHeight:=SliderLength+2*LineWidth+2*SliderWidth; end; end; procedure TGraphScroll.RequestAlign; begin Inherited; //Меняем тип Kind'а при изменении выравнивания. If ((Align = alTop) or (Align = alBottom)) and (Kind <> skHorizontal) Then Kind:=skHorizontal; If ((Align = alLeft) or (Align = alRight)) and (Kind <> skVertical) Then Kind:=skVertical; end; function TGraphScroll.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; begin //Перекрываем унаследованную "автосайзилку". Код слизан с TImage и поэтому работает :-) Result:=True; if not (csDesigning in ComponentState) or (LineWidth > 0) and (SliderWidth > 0) then begin if (Align in [alNone, alLeft, alRight]) and (Kind = skVertical) then NewWidth:=Math.Max(LineWidth, SliderWidth); if (Align in [alNone, alTop, alBottom]) and (Kind <> skVertical) then NewHeight:=Math.Max(LineWidth, SliderWidth); end; end; { TModContainer } constructor TModContainer.Create(AOwner: TComponent); begin inherited Create(AOwner); //Ну, это святое... Width:=400; Height:=150; CreateComponent; //Создание к-та собрано в процедуру, так как используется еще и в SetComponent end; procedure TModContainer.CreateComponent; begin FComponent:=TGraphScroll.Create(Self); //Создаем к-т FComponent.Name:='IntCnt'; //Даем ему имя (необязательно...) FComponent.SetSubComponent(True); //Устанавливаем флаг "SubComponent" FComponent.FreeNotification(Self); //Хотим получать уведомление об уничтожении FComponent.Parent:=Self; //ВАЖНО!!!! Ставим себя "Родителем" FComponent.Width:=Width-20; //Располагаем и образмериваем... FComponent.Top:=Height-20; // ------//------- FComponent.Left:=10; // ------//------- // FComponent.Anchors:=[akBottom, akLeft, akRight]; //А вот с якорями пока решения нету. //Ставим "ручками" в DesignTime //Суть прикола такова - "якоря" цепляются раньше, чем загружаются размеры контейнерного компонента //из файла формы. (ВСЕ креэйты отрабатваю раньше загрузки). Как я понял: контейнерный компонент создается //с размерами Width:=400; Height:=150; , на нем создается FComponent, который цепляется якорями, а затем //читаются данные из файла формы, например Width:=800; - Результат - внедренные к-ты с установленными akLeft+akRight или //akTop+akBottom растягиваются (сжимаются) при КАЖДОЙ загрузке формы в Design Time. //В Ран тайм все нормально... но... end; procedure TModContainer.Notification(AComponent: TComponent; Operation: TOperation); //*Fox* Процедура отслеживающая удаление встроенных объектов //См. справку "Creating properties for subcomponents" begin inherited Notification(AComponent, Operation); //Ну, это святое... //Если "наш" компонент и его удаляют If (AComponent = FComponent) and (Operation = opRemove) Then FComponent:=nil; //Обнулим линк на него... end; procedure TModContainer.SetComponent(const Value: TGraphScroll); //*Fox* Процедура ответственная за "линковку" FComponent //Если линкуем внешний скроллер - внутренний высвобождается //Если удаляем внешний (присваиваем nil) - создается внутрений //См. справку "Creating properties for subcomponents" begin If Value <> FComponent Then //Если предлагают НЕ то, что уже есть... begin If Value <> nil Then //Если линкуем внешний begin If (FComponent <> nil) and (FComponent.Owner = Self) Then //Если сейчас НЕ пустой и Свой FComponent.Free; //Удалим его FComponent:=Value; //Прицепим то, что предлагают... FComponent.FreeNotification(Self); //Хотим получать уведомление об уничтожении end Else //Если удаляем внешний (присв. nil) begin If FComponent.Owner <> Self Then //Если убрали внешний - создадим внутренний CreateComponent; end; end; end; end.
Скачать пример: (11 K)
Этот код является плодом обсуждения проблемы на Круглом столе между рем Шевченко.
Горбань С.В.
Специально для
Возможности
Проверяется корректность введенного выражения. Вычисляются правильно составленные выражения, содержащие бинарные операции +, -, *, /, ^, любые скобки, функции sin, cos, tg, ctg, exp, ln, lg, числовые константы типа extended (с точкой в качестве десятичного разделителя), и переменные произвольной длины, состоящие из букв любого алфавита и цифр. Одинаковые символы в разных регистрах считаются идентичными. Если аргументом функции является переменная либо константа, то их не обязательно заключать в скобки.
Пример: -(x+cosy)/Exp[z]+LN {sin пеРеменная1-tg 3.14}
Возможные проблемы при работе с TCanvas больших размеров
| Рздел Сокровищница | ренко, дата публикации 08 января 2002г. |
Проблема.
Так получилось, что передо мной встала задачи работы с канвой (TCanvas) больших размеров (от 2000 и более точек в одном измерении). Через достаточно короткое время работы я обнаружил, что методы TCanvas иногда ведут себя некорректно. Некорректность поведения заключалась в том, что при определенных условиях графические примитивы, например, прямые линии, либо отображались неправильно, либо просто исчезали. Проверка и перепроверка текста программы ничего не дала. Попытка найти какую-либо информацию о возможных особенностях работы с канвой таких размеров также ни дала положительного результата (может быть, просто плохо искал). Пришлось разбираться самому, а затем и обратиться за советом к некоторым жителям Королевства.
Результат.
В ходе работы удалось некоторым образом локализовать условия возникновения изложенной выше ситуации. 1. Проблемы возникают только под Win9x. Под Windows NT или 2000 подобные ошибки обнаружить не удалось. 2. Графические примитивы могут отображаться неправильно, если их размер в одном измерении более 1000 точек. Например, при отрисовки линии: … MoveTo(0, 0); LineTo(0, 2000); … 3. Самый надежный метод TCanvas - Rectangle, рисуется корректно всегда. Менее надежные - методы рисования прямых линий, например, PolyLine или MoveTo, LineTo. Поскольку большое значение имеет платформа, а именно Windows 9x, возникло предположение, что возникающие проблемы являются не глюком или не ошибкой TCanvas. Просто именно под этой платформой возможности графики ограничены.
Напрашивающиеся выводы по использованию TCanvas больших размеров.
1. Не пытайтесь рисовать все сразу, а отображайте только то что, действительно необходимо. Если по каким-либо причинам это невозможно, и вам просто необходимо перерисовывать сразу весь TCanvas, используйте графические примитивы, принудительно ограничивая их размер, допустим 1500 точек. 2. Может быть, воспользоваться советом Рустама Кафарова:
"Итак, решение одно (во всяком случае, одно я нашел, может решений больше) - используйте платформу NT. Под Windows 2000 все работает НАМНОГО ЛУЧШЕ! Советую просто поменять систему. Если в вашей программе будет ремарка "разработана специально под NT", то это не будет минусом для программы"
P.S.
В качестве примера я предлагаю вашему вниманию небольшой проект , в котором возникают изложенные выше проблемы. Суть проекта - отрисовка разными методами сетки с шагом 40 точек.
К сожалению, мне не удалось подобрать такой режим, чтобы проблема возникало на любой машине, на которой стоит Windows 9x. Поэтому я хотел бы попросить сразу не забрасывать меня помидорами тех, у кого под Windows 9x все будет работать корректно. Возможно, что все вышеописанное является неким частным случаем, и дарность за оказанную помощь.
Специально для
Выключение компьютера в заданное время
| Раздел Сокровищница | Агранович, дата публикации 13 июня 2002г. |
Программа для выключения компьютера в заданное время. Если запустить с параметром, указав время, то программа запустится скрытно и выключит компьютер в указанное время. Проверенно на Windows XP.
Для выключения используется процедура: Procedure ShutdownComputer; var ph:THandle; tp,prevst:TTokenPrivileges; rl:DWORD; begin OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,ph); LookupPrivilegeValue(Nil,'SeShutdownPrivilege',tp.Privileges[0].Luid); tp.PrivilegeCount:=1; tp.Privileges[0].Attributes:=2; AdjustTokenPrivileges(ph,FALSE,tp,SizeOf(prevst),prevst,rl); ExitWindowsEx(EWX_SHUTDOWN or EWX_POWEROFF,0); end; Скачать (обновление от 01.07.02): Исполняемый файл (161 K) Исходные коды (6 K)
WinAPIFAQ
| источник информации: |
| DELPHI WinAPI FAQ Перевод с английского |
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи.
Скачать (27 K) для просмотра в off-line.
Вопрос:
Как программно выключить монитор?
Ответ:
Программно можно отключить монитор совместимый со стандартом EnergyStar.
Отправьте сообщение wm_SysCommand с параметром WParam = SC_MonitorPower и LParam = 0 для отключения монитора LParam = 1 для включения монитора
В приведенном примере монитор отключается на 10 секунд.
Пример: type TForm1 = class(TForm) Button1: TButton; Timer1: TTimer; procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public MonitorOff : bool; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Timer1.Enabled := false; Timer1.Interval := 10000; MonitorOff := false; end; procedure TForm1.Timer1Timer(Sender: TObject); begin if MonitorOff then begin MonitorOff := false; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1); Timer1.Enabled := false; end; end; procedure TForm1.Button1Click(Sender: TObject); begin MonitorOff := true; Timer1.Enabled := true; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0); end; Вопрос:
Как создать мигающий заголовок окна (пиктограмму)?
Ответ:
Можно воспользоваться функцией API FlashWindow():
Пример:
var Flash : bool; procedure TForm1.Timer1Timer(Sender: TObject); begin FlashWindow(Form1.Handle, Flash); FlashWindow(Application.Handle, Flash); Flash := not Flash; end; procedure TForm1.FormCreate(Sender: TObject); begin Flash := False; end; Вопрос:
Иногда всплывающее меню моего приложения system tray не исчезает когда оно теряет фокус. Как закрыть его?
Ответ:
При показе всплывающего меню установите foreground window, затем пошлите сообщение WM_NULL после показа меню. procedure TForm1.WndProc(var Msg : TMessage); var p : TPoint; begin case Msg.Msg of WM_USER + 1: case Msg.lParam of WM_RBUTTONDOWN: begin SetForegroundWindow(Handle); GetCursorPos(p); PopupMenu1.Popup(p.x, p.y); PostMessage(Handle, WM_NULL, 0, 0); end; end; end; inherited; end; Вопрос:
Как узнать текущие время и дату по Гринвичу
Ответ:
Используя API фукцию GetSystemTime.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var lt : TSYSTEMTIME; st : TSYSTEMTIME; begin GetLocalTime(lt); GetSystemTime(st); Memo1.Lines.Add('LocalTime = ' + IntToStr(lt.wmonth) + '/' + IntToStr(lt.wDay) + '/' + IntToStr(lt.wYear) + ' ' + IntToStr(lt.wHour) + ':' + IntToStr(lt.wMinute) + ':' + IntToStr(lt.wSecond)); Memo1.Lines.Add('UTCTime = ' + IntToStr(st.wmonth) + '/' + IntToStr(st.wDay) + '/' + IntToStr(st.wYear) + ' ' + IntToStr(st.wHour) + ':' + IntToStr(st.wMinute) + ':' + IntToStr(st.wSecond)); end; Вопрос:
Какой самый быстрый способ для очистки canvasа?
Ответ:
Windows API функция PatBlt().
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, WHITENESS); end; Вопрос:
При изменении размеров формы мне необходимо чтобы перерисовывалась вся ее поверхность. Но свойство Canvas.ClipRect у формы - только для чтения.
Ответ:
На событии Resize вызовите Windows API функцию InvalidateRect(). Если передать nil в качестве второго параметра приведет к тому, что перерисовываться будет вся клиентская область окна. Третий параметр указывает будет ли перерисовываться фон формы.
Пример:
procedure TForm1.FormResize(Sender: TObject); begin InvalidateRect(Form1.Handle, nil, false); end; Вопрос:
Как использовать процедуру mouse_event() для имитации событий мыши?
Ответ:
Приведенный пример демонстрирует использование API функции mouse_event() для имитации событий мыши. При нажатии кнопки Button2 программа перемещает курсор мыши на кнопку Button1 и щелкает по ней. Положение курсора мыши задается в "абсолютных" координатах ("Mickeys"), где 65535 "Mickeys" равно ширине экрана. procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Button 1 clicked'); end; procedure TForm1.Button2Click(Sender: TObject); var Pt : TPoint; begin {Позволим кнопке Button2 перерисоваться} Application.ProcessMessages; {Найдем координаты центра button 1} Pt.x := Button1.Left + (Button1.Width div 2); Pt.y := Button1.Top + (Button1.Height div 2); {Преобразуем Pt к координатам экрана} Pt := ClientToScreen(Pt); {Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки} Pt.x := Round(Pt.x * (65535 / Screen.Width)); Pt.y := Round(Pt.y * (65535 / Screen.Height)); {Переместим курсор мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0); {Имитируем нажатие левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);; {Имитируем отпускание левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);; end; Вопрос:
Как программно закрыть другое приложение?
Ответ:
Отправьте этому приложению сообщение WM_QUIT
Пример:
PostMessage(FindWindow(Nil, 'Заголовок окна'), WM_QUIT, 0, 0); Где "Заголовок окна" - заголовок окна, которому Вы посылаете сообщение. Вопрос:
Форматирование диска в Win32
Ответ:
ShellAPI функция ShFormatDrive().
Пример:
const SHFMT_DRV_A = 0; const SHFMT_DRV_B = 1; const SHFMT_ID_DEFAULT = $FFFF; const SHFMT_OPT_QUICKFORMAT = 0; const SHFMT_OPT_FULLFORMAT = 1; const SHFMT_OPT_SYSONLY = 2; const SHFMT_ERROR = -1; const SHFMT_CANCEL = -2; const SHFMT_NOFORMAT = -3; function SHFormatDrive(hWnd : HWND; Drive : Word; fmtID : Word; Options : Word) : Longint stdcall; external 'Shell32.dll' name 'SHFormatDrive'; procedure TForm1.Button1Click(Sender: TObject); var FmtRes : longint; begin try FmtRes:= ShFormatDrive(Handle, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT); case FmtRes of SHFMT_ERROR : ShowMessage('Error formatting the drive'); SHFMT_CANCEL : ShowMessage('User canceled formatting the drive'); SHFMT_NOFORMAT : ShowMessage('No Format') else ShowMessage('Disk has been formatted'); end; except end; end; Вопрос:
Как спрятать и отключить кнопку "Пуск"?
Ответ:
Приведенный пример прячет и показывает кнопку "Пуск", а также разрешает и запрещает ее.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var Rgn : hRgn; begin {Cпрятать кнопку "Пуск"} Rgn := CreateRectRgn(0, 0, 0, 0); SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), Rgn, true); end; procedure TForm1.Button2Click(Sender: TObject); begin {Показать кнопку "Пуск"} SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), 0, true); end; procedure TForm1.Button3Click(Sender: TObject); begin {Запретить кнопку "Пуск"} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), false); end; procedure TForm1.Button4Click(Sender: TObject); begin {Разрешить кнопку "Пуск"} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), true); end Вопрос:
Как временно отключить перерисовку окна?
Ответ:
Вызовите функцию WinAPI LockWindowUpdate передав ей дескриптор окна, которое необходимо не обновлять. Передайте ноль в качестве параметра для восстановления нормального обновления. LockWindowUpdate(Memo1.Handle); . . LockWindowUpdate(0); Вопрос:
Моя программа использует дравер принтера. Возможно ли потихоньку установить драйвер принтера без вмешательства пользователя?
Ответ:
Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini. Примечание: DriverName = Имя драйвера; DRVFILE - имя файла с драйвером без расширения (".drv" - по умолчанию).
Пример:
procedure TForm1.Button1Click(Sender: TObject); var s : array[0..64] of char; begin WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45'); WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:'); StrCopy(S, 'PrinterPorts'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); StrCopy(S, 'Devices'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); end; Вопрос:
Как набрать номер с помощью модема в Win32?
Ответ:
Используйте функцию Windows API CreateFile() чтобы получить дескриптор порта, и стандартные функции ввода-вывода для связи с полученным портом.
Пример:
var hCommFile : THandle; procedure TForm1.Button1Click(Sender: TObject); var PhoneNumber : string; CommPort : string; NumberWritten : LongInt; begin PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10; CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile=INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Dial the phone} NumberWritten:=0; if WriteFile(hCommFile, PChar(PhoneNumber)^, Length(PhoneNumber), NumberWritten, nil) = false then begin ShowMessage('Unable to write to ' + CommPort); end; end; procedure TForm1.Button2Click(Sender: TObject); begin {Close the port} CloseHandle(hCommFile); end; Вопрос:
Как использовать TAPI для голосового звонка?
Ответ:
См пример.
Пример:
{tapi Errors} const TAPIERR_CONNECTED = 0; const TAPIERR_DROPPED = -1; const TAPIERR_NOREQUESTRECIPIENT = -2; const TAPIERR_REQUESTQUEUEFULL = -3; const TAPIERR_INVALDESTADDRESS = -4; const TAPIERR_INVALWINDOWHANDLE = -5; const TAPIERR_INVALDEVICECLASS = -6; const TAPIERR_INVALDEVICEID = -7; const TAPIERR_DEVICECLASSUNAVAIL = -8; const TAPIERR_DEVICEIDUNAVAIL = -9; const TAPIERR_DEVICEINUSE = -10; const TAPIERR_DESTBUSY = -11; const TAPIERR_DESTNOANSWER = -12; const TAPIERR_DESTUNAVAIL = -13; const TAPIERR_UNKNOWNWINHANDLE = -14; const TAPIERR_UNKNOWNREQUESTID = -15; const TAPIERR_REQUESTFAILED = -16; const TAPIERR_REQUESTCANCELLED = -17; const TAPIERR_INVALPOINTER = -18; {tapi size constants} const TAPIMAXDESTADDRESSSIZE = 80; const TAPIMAXAPPNAMESIZE = 40; const TAPIMAXCALLEDPARTYSIZE = 40; const TAPIMAXCOMMENTSIZE = 80; const TAPIMAXDEVICECLASSSIZE = 40; const TAPIMAXDEVICEIDSIZE = 40; function tapiRequestMakeCallA(DestAddress : PAnsiChar; AppName : PAnsiChar; CalledParty : PAnsiChar; Comment : PAnsiChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCallW(DestAddress : PWideChar; AppName : PWideChar; CalledParty : PWideChar; Comment : PWideChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCall(DestAddress : PChar; AppName : PChar; CalledParty : PChar; Comment : PChar) : LongInt; stdcall; external 'TAPI32.DLL'; procedure TForm1.Button1Click(Sender: TObject); var DestAddress : string; CalledParty : string; Comment : string; begin DestAddress := '1-555-555-1212'; CalledParty := 'Frank Borland'; Comment := 'Calling Frank'; tapiRequestMakeCall(pChar(DestAddress), PChar(Application.Title), pChar(CalledParty), PChar(Comment)); end; end. Вопрос:
Как показать иконку, ассоциированной с данным типом файла?
Ответ:
ShellApi функция ExtractAssociatedIcon()
Пример:
uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); var Icon : hIcon; IconIndex : word; begin IconIndex := 1; Icon := ExtractAssociatedIcon(HInstance, Application.ExeName, IconIndex); DrawIcon(Canvas.Handle, 10, 10, Icon); end; Вопрос:
Как определение нажатия определенной клавиши во время загрузки приложения?
Ответ:
Используйту WinAPI функцию GetKeyState() для определения нажатия клавиши в тексте проекта. Для того чтобы увидеть текст файла проекта в главном меню Delphi 3 выберите "View">>"ProjectSource" в Delphi 4 "Project">>"View Source".
Пример:
program Project1; uses Windows, Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} begin if GetKeyState(vk_F8) < 1 then MessageBox(0, 'F8 was pressed during startup', 'MyApp', mb_ok); Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end. Вопрос:
Как заставить пикнуть динамик несколько раз с небольшой задержкой между сигналами, не зависящей от тактовой частоты процессора?
Ответ:
См. пример.
Пример:
procedure Delay(ms : longint); {$IFNDEF WIN32} var TheTime : LongInt; {$ENDIF} begin {$IFDEF WIN32} Sleep(ms); {$ELSE} TheTime := GetTickCount + ms; while GetTickCount < TheTime do Application.ProcessMessages; {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); begin MessageBeep(word(-1)); Delay(200); MessageBeep(word(-1)); Delay(200); MessageBeep(word(-1)); end; Вопрос:
Можно ли отключить кнопку закрытия любого окна?
Ответ:
Да, приведенный пример отключает кнопку закрытия и пункт "закрыть" ситсемного меню заданного окна. procedure TForm1.Button1Click(Sender: TObject); var hwndHandle : THANDLE; hMenuHandle : HMENU; begin hwndHandle := FindWindow(nil, 'Untitled - Notepad'); if (hwndHandle <> 0) then begin hMenuHandle := GetSystemMenu(hwndHandle, FALSE); if (hMenuHandle <> 0) then DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); end; end; Вопрос:
Как узнать путь к каталогам Windows?
Ответ:
Следующий пример получает полный список каталогов по умолчанию (Favorites, Desktop, Programs, Fonts, SendTo, Start, Menu, Templates, Startup, Recent and NetHood) Windows и заносит его в Memo.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_CURRENT_USER; reg.LazyWrite := false; reg.OpenKey( 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(ts.Strings[i] + ' = ' + reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end; Вопрос:
Как узнать полный путь и имя файла загруженной DLL?
Ответ:
См. пример
Пример:
uses Windows; procedure ShowDllPath stdcall; var TheFileName : array[0..MAX_PATH] of char; begin FillChar(TheFileName, sizeof(TheFileName), #0); GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName)); MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok); end; Вопрос:
Как вызвать диалог 'Найти файлы и паки' проводника?
Ответ:
Приведенный пример показывает использование DDE для вызова диалога 'Найти файлы и паки' Explorerа. Диалог открывается на каталоге "C:\Download". procedure TForm1.Button1Click(Sender: TObject); begin with TDDEClientConv.Create(Self) do begin ConnectMode := ddeManual; ServiceApplication := 'explorer.exe'; SetLink( 'Folders', 'AppProperties'); OpenLink; ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False); CloseLink; Free; end; end; Вопрос:
Как сделать родительское окно с фоновым рисунком в клиентской области?
Ответ:
Для того чтобы сделать это выполните следующие шаги: Срздайте новый проект. Установите FormStyle формы в fsMDIForm Разместите Image на форме и загрузите в него картинку. Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки: FClientInstance : TFarProc; FPrevClientProc : TFarProc; procedure ClientWndProc(var Message: TMessage); Добаьте следующие строки в разделе implementation: procedure TMainForm.ClientWndProc(var Message: TMessage); var Dc : hDC; Row : Integer; Col : Integer; begin with Message do case Msg of WM_ERASEBKGND: begin Dc := TWMEraseBkGnd(Message).Dc; for Row := 0 to ClientHeight div Image1.Picture.Height do for Col := 0 to ClientWidth div Image1.Picture.Width do BitBlt(Dc, Col * Image1.Picture.Width, Row * Image1.Picture.Height, Image1.Picture.Width, Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY); Result := 1; end; else Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam); end; end; В методе формы OnCreate добавьте: FClientInstance := MakeObjectInstance(ClientWndProc); FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC)); SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance)); Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild. У Вас получился MDI-проект с "обоями" в клиентской области MDI формы. Вопрос:
Как глобально перехватить нажатие кнопки PrintScreen?
Ответ:
В примере для глобального перехвата нажатия клавиши printscreen регистрируется горячая клавиша (hot key).
Пример:
type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} 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; Вопрос:
Существует ли способ для определение числа заданий spoolerа печати?
Ответ:
Spoolerа печати Windows посылает WM_SPOOLERSTATUS каждый раз при добавлении и удалении заданий в очереди печати. В следующем примере показано как перехватить это сообщение
Пример:
type TForm1 = class(TForm) Label1: TLabel; private { Private declarations } procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); message WM_SPOOLERSTATUS; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); begin Lable1.Caption := IntToStr(msg.JobsLeft) + ' Jobs currenly in spooler'; msg.Result := 0; end; Вопрос:
Как определить имена установленых Com-портов?
Ответ:
Из реестра. См. пример.
Пример:
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('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; Вопрос:
Извлечение пиктограммы из exe, dll или ico-файла
Ответ:
Функция SHELLAPI ExtractIconEx:
Обратите внимание - в примере функции обьявленны иначе, чем в модуле ShellAPI type ThIconArray = array[0..0] of hIcon; type PhIconArray = ^ThIconArray; function ExtractIconExA(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; function ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; phiconLarge: PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExW'; function ExtractIconEx(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; procedure TForm1.Button1Click(Sender: TObject); var NumIcons : integer; pTheLargeIcons : phIconArray; pTheSmallIcons : phIconArray; LargeIconWidth : integer; SmallIconWidth : integer; SmallIconHeight : integer; i : integer; TheIcon : TIcon; TheBitmap : TBitmap; begin NumIcons := ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', -1, nil, nil, 0); if NumIcons > 0 then begin LargeIconWidth := GetSystemMetrics(SM_CXICON); SmallIconWidth := GetSystemMetrics(SM_CXSMICON); SmallIconHeight := GetSystemMetrics(SM_CYSMICON); GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0); FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0); ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', 0, pTheLargeIcons, pTheSmallIcons, numIcons); {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} for i := 0 to (NumIcons - 1) do begin DrawIcon(Form1.Canvas.Handle, i * LargeIconWidth, 0, pTheLargeIcons^[i]); TheIcon := TIcon. Create; TheBitmap := TBitmap.Create; TheIcon.Handle := pTheSmallIcons^[i]; TheBitmap.Width := TheIcon.Width; TheBitmap.Height := TheIcon.Height; TheBitmap.Canvas.Draw(0, 0, TheIcon); TheIcon.Free; Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth, 100, (i + 1) * SmallIconWidth, 100 + SmallIconHeight), TheBitmap); TheBitmap.Free; end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); end; end; end. Вопрос:
как заставить Рабочий Стола Windows обновится?
Ответ:
См. пример.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0); end; Вопрос:
Перерисовка canvasf моей формы занимает довольно много времени. Как определить установлен ли у пользователя режим перерисовки всего окна при перемещении чтобы временно отключить перерисовку моего окна?
Ответ:
В приведенном примере определяется включен ли режим "Full Window Drag" (перерисовки всего окна при перемещении)
Пример:
procedure TForm1.Button1Click(Sender: TObject); var b : bool; begin SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0); if not b then ShowMessage('Full Window Drag is not enabled') else ShowMessage('Full Window Drag is enabled'); end; Вопрос:
Как уступить выделенный моей программе квант процессорного времени другим приложениям?
Ответ:
Вызовите функцию Windows API Sleep() передав ноль в качестве параметра.
Вопрос:
Как запускать мою программу на каждом старте Windows?
Ответ:
Пример работает и для Win32и для Win16. uses Registry, {For Win32} IniFiles; {For Win16} {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} {For Win32} procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', false); reg.WriteString('My App', Application.ExeName); reg.CloseKey; reg.free; end; {For Win16} procedure TForm1.Button2Click(Sender: TObject); var WinIni : TIniFile; WinIniFileName : array[0..MAX_PATH] of char; s : string; begin GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName)); StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName); s := WinIni.ReadString('windows', 'run', ''); if s = '' then s := Application.ExeName else s := s + ';' + Application.ExeName; WinIni.WriteString('windows', 'run', s); WinIni.Free; end; Вопрос:
Как увеличить процессорное время, выделяемого программе?
Ответ:
Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью - т.к. присвоение слишком высокого приоритета может привети к медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function.
Пример:
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; Вопрос:
Я хочу определить момент окончания изменения размера или перемещения окна. Перехватываю сообщения WM_SIZE и WM_MOVE но я получаю много таких сообщений а мне нужно узнать когда именно пользователь закончил перенос или изменение размеров окна. Возможно ли это?
Ответ:
В следующем примере показан перехват сообщения WM_EXITSIZEMOVE Хотя сообщение документированно только для Windows NT оно работает точно так же и под Windows 95. Обратите внимание что Вы можите перехватить сообщение WM_ENTERSIZEMOVEдля определения момента начала пользователем операции изменения размера или перемещения окна.
Пример:
type TForm1 = class(TForm) private { Private declarations } public procedure WMEXITSIZEMOVE(var Message: TMessage); message WM_EXITSIZEMOVE; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage); begin Form1.Caption := 'Finished Moving and sizing'; end; Вопрос:
Как определить время последнего доступа к файлу?
Ответ:
См пример. Примечание: не все файловые системы поддерживают время последнего доступа к файлу.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var SearchRec : TSearchRec; Success : integer; DT : TFileTime; ST : TSystemTime; begin Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec); if (Success = 0) and (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime <> 0) or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime <> 0)) then begin FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT); FileTimeToSystemTime(DT,ST); Memo1.Lines.Clear; Memo1.Lines.Add('AutoExec.Bat was last accessed at:'); Memo1.Lines.Add('Year := ' + IntToStr(st.wYear)); Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth)); Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek)); Memo1.Lines.Add('Day := ' + IntToStr(st.wDay)); Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour)); Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute)); Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond)); Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds)); end; SysUtils.FindClose(SearchRec); end; Вопрос:
Как использовать функцию Shell API SHBrowseForFolder чтобы позволить пользователю выбрать каталог?
Ответ:
См. пример
Пример:
uses ShellAPI, ShlObj; procedure TForm1.Button1Click(Sender: TObject); var TitleName : string; lpItemID : PItemIDList; BrowseInfo : TBrowseInfo; DisplayName : array[0..MAX_PATH] of char; TempPath : array[0..MAX_PATH] of char; begin FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); BrowseInfo.hwndOwner := Form1.Handle; BrowseInfo.pszDisplayName := @DisplayName; TitleName := 'Please specify a directory'; BrowseInfo.lpszTitle := PChar(TitleName); BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; lpItemID := SHBrowseForFolder(BrowseInfo); if lpItemId <> nil then begin SHGetPathFromIDList(lpItemID, TempPath); ShowMessage(TempPath); GlobalFreePtr(lpItemID); end; end; Вопрос:
Как получить дескриптора окна Window, сожержащего DOS программу или программу консольного режима?
Ответ:
В следуещем примере используется функция Windows API FindWindow(). Обратите внимание, что WndClass консольного окна отличаются для Windows 95 и Window NT и заголовок окна может содержать полный путь под Windows NT.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var info : TOSVersionInfo; ClassName : string; Title : string; begin {Проверяем - Win95 или NT.} info.dwOSVersionInfoSize := sizeof(info); GetVersionEx(info); if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin ClassName := 'ConsoleWindowClass'; Title := 'Command Prompt'; end else begin ClassName := 'tty'; Title := 'MS-DOS Prompt'; end; ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title)))); end; Вопрос:
Возможно ли определить факта изменения системного времени другим приложением?
Ответ:
Следующий прмер перехватывает событие WM_TIMECHANGE. примечание: Приложение , изменяющее системное время должно посылать сообщение WM_TIMECHANGE всем окнам. type TForm1 = class(TForm) private { Private declarations } procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); message WM_TIMECHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE); begin Form1.Caption := 'Time Changed'; end; Вопрос:
Как очистить пункт документы меню кнопки Пуск
Ответ:
Вызовите Windows API функцию SHAddToRecentDocs() передав nil вместо имени файла в качестве параметра.
Пример:
uses ShlOBJ; procedure TForm1.Button1Click(Sender: TObject); begin SHAddToRecentDocs(SHARD_PATH, nil); end; Вопрос:
Как опеределить состояние модема под Win32?
Ответ:
См. пример
Пример:
procedure TForm1.Button1Click(Sender: TObject); 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; Вопрос:
Как добавить пункт к системному меню приложения?
Пример:
type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const SC_MyMenuItem = WM_USER + 1; procedure TForm1.FormCreate(Sender: TObject); begin AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, ''); AppendMenu(GetSystemMenu(Handle, FALSE), MF_STRING, SC_MyMenuItem, 'My Menu Item'); end; procedure TForm1.WMSysCommand(var Msg: TWMSysCommand); begin if Msg.CmdType = SC_MyMenuItem then ShowMessage('Got the message') else inherited; end; Вопрос:
Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?
Ответ:
В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже документацию к сообщению EM_SETWORDBREAKPROC. var OriginalWordBreakProc : pointer; NewWordBreakProc : pointer; function MyWordBreakProc(LPTSTR : pchar; ichCurrent : integer; cch : integer; code : integer) : integer {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} begin result := 0; end; procedure TForm1.FormCreate(Sender: TObject); begin OriginalWordBreakProc := Pointer( SendMessage(Memo1.Handle, EM_GETWORDBREAKPROC, 0, 0)); {$IFDEF WIN32} NewWordBreakProc := @MyWordBreakProc; {$ELSE} NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, hInstance); {$ENDIF} SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(NewWordBreakProc)); end; procedure TForm1.FormDestroy(Sender: TObject); begin SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(@OriginalWordBreakProc)); {$IFNDEF WIN32} FreeProcInstance(NewWordBreakProc); {$ENDIF} end; Вопрос:
Можно ли скопировать группу файлов, используя стандартный диалог с анимацией Копирование Файлов, который использует "Проводник" (Explorer)?
Ответ:
В следующем примере используется функция SHFileOperation для копирования группы файлов и показа анимированного диалога. Вы можете использовать также следующие флаги для копирования, удаления, переноса и переименования файлов. TO_COPY FO_DELETE FO_MOVE FO_RENAME Примечание: буфер, содержащий имена файлов для копирования должен заканчиваться двумя нулевыми символами.
Пример:
uses ShellAPI; 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; Вопрос:
Как узнать серийный номер диска
Ответ:
procedure TForm1.Button1Click(Sender: TObject); 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; Вопрос:
Как узнать является диск CD-диском,сетевым диском, виртуальным диском или сьемным диском?
Ответ:
Windows API функция GetDriveType().
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin 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; end; Вопрос:
Как проверить готовность диска без появления окна ошибки Windows?
Ответ:
Вы можете использовать функцию Windows API SetErrorMode() для отключения диалога Window's critical Error.
Пример:
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; Вопрос:
Использование FindFirst для поиска файлов.
Ответ:
begin Result := SysUtils.FindFirst(Path, Attr, SearchRec); while Result = 0 do begin ProcessSearchRec(SearchRec); Result := SysUtils.FindNext(SearchRec); end; SysUtils.FindClose(SearchRec); end; Вопрос:
Как получить дескриптор окна другого приложения и сделать его активным?
Ответ:
Использование фуекции Windows API FindWindow() - простейший способ нахождение окна, при условии, что известен его заголовок или имя оконного класса. Если Вам известна только часть заголовка окна (например 'Netscape - ' + 'какой-то неизвестный URL'), Вам нужно использовать функцию EnumWindows() для получения всех окон, затем вызывать функцию GetWindowsText() и GetClassName для поиска нужного окна. Следующий пример находит первое окно, содержащее совпадающую часть заголовка окна и полностью совпадающее название оконного класса (если он задан) и делает это окно активным. 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; Вопрос:
Как написать программу не имеющую ни одной формы?
Ответ:
Создайте новое приложение, затем удалите из проекта все unitы - (Delphi 3 - View - Project Manager)
(Delphi 4 - Project - Remove from project)
Откройте файл проекта
(Delphi 3 - View - Project Source)
(Delphi 3 - Project - View Source)
и отредактируйте его так как приведино ниже.
Пример:
program Project1; {$R *.RES} uses SysUtils; var f : TextFile; begin AssignFile(f, 'TestFile.Txt'); ReWrite(f); Writeln(f, 'Test'); Close(f); end. Вопрос:
Почему возникает ошибка при передаче параметров типа boolean равного True в некоторые внешней функции
Ответ:
В Delphi 3 значение "True" для типов ByteBool, WordBool LongBool представляется как -1 для совместимости с Microsoft Visual Basic. Многие компиляторы представляют "True" как либо "не нуль" либо 1. При передаче параметров в не Visual Basic-приложения Вам следует придерживаться следующей техники во избежание несовместимости: LongBool(Abs(True)); При приеме значений типа boolean из внешних программ Вам следует всегда проверять его на значение "False". Эта техника всегда работает, поскольку "False" всегда представляется нулем. if BoolValPassed <> False then DoSomething. Вопрос:
Как получить длинное имя файла или каталога, зная короткое имя?
Ответ:
Используйте Win32_Find_Data поле TSearchRec.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var SearchRec : TSearchRec; Success : integer; begin Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', faAnyFile, SearchRec); if Success = 0 then begin ShowMessage(SearchRec.FindData.CFileName); end; SysUtils.FindClose(SearchRec); end; Вопрос:
Как временно отключить range checking для участка программы, а затем вновь вклчить его?
Ответ:
Можно сделать это, используя "IFOPT" и "DEFINE". type PSomeArray = ^TSomeArray; TSomeArray = array[0..0] of integer; procedure TForm1.Button1Click(Sender: TObject); var p : PSomeArray; i : integer; begin {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} GetMem(p, sizeof(integer) * 200); try for i := 1 to 200 do p[i] := i; finally FreeMem(p, sizeof(integer) * 200); end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} end; Вопрос:
Как получить имя файла и путь локальной таблицы?
Ответ:
Следующий пример взят из файла BDE32.HLP Borland/CommonFiles/BDE directory: 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; procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Lines.Add(fDbiFormFullName(Table1)); end; Примечание: Таблица должна быть открытой. Работает с локальными таблицами. Вопрос:
Как получить дескриптор панели задач (TaskBar)?
Ответ:
hTaskbar := FindWindow('Shell_TrayWnd', Nil ); Вопрос:
Как из программы запустить Screen Saver?
Ответ:
Представленная ниже функция демонстрирует как это сделать function TurnScreenSaverOn : bool; var b : bool; begin result := false; if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @b, 0) <> true then exit; if not b then exit; PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0); result := true; end; Вопрос:
Как выяснить установлены ли в системе шрифты TrueType?
Ответ:
function IsTrueTypeAvailable : bool; var {$IFDEF WIN32} rs : TRasterizerStatus; {$ELSE} rs : TRasterizer_Status; {$ENDIF} begin result := false; if not GetRasterizerCaps(rs, sizeof(rs)) then exit; if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then exit; if rs.WFlags and TT_ENABLED <> TT_ENABLED then exit; result := true; end; Вопрос:
Как переслать файл в Мусорную Корзину?
Ответ:
Используйте функцию 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; Вопрос:
Как изменить обои Windows програмно?
Ответ:
Изменить обои можно функцией SystemParametersInfo()Б переслав ей в качестве параметров константу SPI_SETDESKWALLPAPER и имя нового файла обоев.
Пример:
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar('C:\SOMEPATH\SOME.BMP'), SPIF_SENDWININICHANGE); Вопрос:
Как выяснить запущен ли Delphi / C++ Builder?
Ответ:
Используйте функцию FindWindow. (Класс главного окна Delphi / C++ Builder - TAppBuilder) if FindWindow('TAppBuilder', Nil) <> 0 Then ShowMessage('Delphi and or C++ Builder is running'); Вопрос:
Как програмно выяснить версию Windows?
Ответ:
{$IFDEF WIN32} function GetVersionEx(lpOs : pointer) : BOOL; stdcall; external 'kernel32' name 'GetVersionExA'; {$ENDIF} procedure GetWindowsVersion(var Major : integer; var Minor : integer); var {$IFDEF WIN32} lpOS, lpOS2 : POsVersionInfo; {$ELSE} l : longint; {$ENDIF} begin {$IFDEF WIN32} GetMem(lpOS, SizeOf(TOsVersionInfo)); lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo); while getVersionEx(lpOS) = false do begin GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1); lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); lpOS := lpOs2; end; Major := lpOs^.dwMajorVersion; Minor := lpOs^.dwMinorVersion; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); {$ELSE} l := GetVersion; Major := LoByte(LoWord(l)); Minor := HiByte(LoWord(l)); {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); var Major : integer; Minor : integer; begin GetWindowsVersion(Major, Minor); Memo1.Lines.Add(IntToStr(Major)); Memo1.Lines.Add(IntToStr(Minor)); end; Вопрос:
Как узнать переменные окружения (environment variable) DOS, например path?
Ответ:
Windows API - функция GetDOSEnvironment() для Win16 и GetEnvironmentStrings() для Win32.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var p : pChar; begin Memo1.Lines.Clear; Memo1.WordWrap := false; {$IFDEF WIN32} p := GetEnvironmentStrings; {$ELSE} p := GetDOSEnvironment; {$ENDIF} while p^ <> #0 do begin Memo1.Lines.Add(StrPas(p)); inc(p, lStrLen(p) + 1); end; {$IFDEF WIN32} FreeEnvironmentStrings(p); {$ENDIF} end; Вопрос:
Как рисовать непосредственно на Рабочем столе?
Ответ:
Пример:
procedure TForm1.Button1Click(Sender: TObject); var dc : hdc; begin dc := GetDc(0); MoveToEx(Dc, 0, 0, nil); LineTo(Dc, 300, 300); ReleaseDc(0, Dc); end; Вопрос:
Как определить каталог Windows?
Ответ:
Вызовите функцию GetWindowsDirectory(). Если Вас интересует каталог System, вызовите функцию GetSystemDirectory().
Пример:
{$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var a : Array[0..MAX_PATH] of char; begin GetWindowsDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); GetSystemDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); end; Вопрос:
Как определить размер рабочего стола без Тaskbar'а?
Ответ:
Воспользуйтесь функцией SystemParametersInfo(), переслав ей в качестве параметров - SPI_GETWORKAREA и адрес структуры типа TRect, куда будут передан полученный результат.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var r : TRect; begin SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0); Memo1.Lines.Add(IntToStr(r.Top)); Memo1.Lines.Add(IntToStr(r.Left)); Memo1.Lines.Add(IntToStr(r.Bottom)); Memo1.Lines.Add(IntToStr(r.Right)); end; Вопрос:
Как закрыть CD програмно?
Ответ:
Вызовите функцию mciSendCommand (из библиотекиMMSystem) передав ей параметр MCI_SET_DOOR_CLOSED.
Пример:
uses MMSystem; procedure CloseCD(Drive : char); var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Open; Application.ProcessMessages; mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0); Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin CloseCD('D'); end; Вопрос:
Как определить свободное дисковое пространство на дисках размером больше 2 ГБ?
Ответ:
Вызовите функцию GetDiskFreeSpaceEx(). Возвращаемый функцией результат типа integers конвертируйте в doubles.
Пример:
function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar; var lpFreeBytesAvailableToCaller : Integer; var lpTotalNumberOfBytes: Integer; var lpTotalNumberOfFreeBytes: Integer) : bool; stdcall; external kernel32 name 'GetDiskFreeSpaceExA'; procedure GetDiskSizeAvail(TheDrive : PChar; var TotalBytes : double; var TotalFree : double); var AvailToCall : integer; TheSize : integer; FreeAvail : integer; begin GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail); {$IFOPT Q+} {$DEFINE TURNOVERFLOWON} {$Q-} {$ENDIF} if TheSize >= 0 then TotalBytes := TheSize else if TheSize = -1 then begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes * 2; TotalBytes := TotalBytes + 1; end else begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize); end; if AvailToCall >= 0 then TotalFree := AvailToCall else if AvailToCall = -1 then begin TotalFree := $7FFFFFFF; TotalFree := TotalFree * 2; TotalFree := TotalFree + 1; end else begin TotalFree := $7FFFFFFF; TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall); end; end; procedure TForm1.Button1Click(Sender: TObject); var TotalBytes : double; TotalFree : double; begin GetDiskSizeAvail('C:\', TotalBytes, TotalFree); ShowMessage(FloatToStr(TotalBytes)); ShowMessage(FloatToStr(TotalFree)); end; Вопрос:
Как спрятать Панель Задач Windows (Task Bar)?
Ответ:
Вначале необходимо вызвать функцию FindWindow(), чтобы определить handle TaskBar. Затем вызвите функцию ShowWindow(), передав ей в качестве параметра костанту SW_HIDE.
Пример:
procedure TForm1.Button1Click(Sender: TObject); var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_HIDE); end; procedure TForm1.Button2Click(Sender: TObject); var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_SHOWNORMAL); end; Вопрос:
Как определить подключен ли компюетер к сети.
Ответ:
Воспользуйтесь функцией GetSystemMetrics(), переслав ей флаг SM_NETWORK.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then ShowMessage('Machine is attached to network') else ShowMessage('Machine is not attached to network'); end; Вопрос:
Как добавить документ в меню ПУСК - ДОКУМЕНТЫ?
Ответ:
Используйте функцию SHAddToRecentDocs.
Пример:
uses ShlOBJ; procedure TForm1.Button1Click(Sender: TObject); var s : string; begin s := 'C:\DownLoad\ntkfaq.html'; SHAddToRecentDocs(SHARD_PATH, pChar(s)); end; Вопрос:
Как программно изменить текущий порт принтера?
Ответ:
Используйте метод SetPrinter класса TPrinter.
Пример:
uses Printers; {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var pDevice : pChar; pDriver : pChar; pPort : pChar; hDMode : THandle; PDMode : PDEVMODE; begin if PrintDialog1.Execute then begin GetMem(pDevice, cchDeviceName); GetMem(pDriver, MAX_PATH); GetMem(pPort, MAX_PATH); Printer.GetPrinter(pDevice, pDriver, pPort, hDMode); Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode); FreeMem(pDevice, cchDeviceName); FreeMem(pDriver, MAX_PATH); FreeMem(pPort, MAX_PATH); Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Delphi Is RAD!'); Printer.EndDoc; end; end; Вопрос:
Как корректно определить изменения в оборудовании PlugNPlay?
Ответ:
Пример:
type TForm1 = class(TForm) Button1: TButton; private { Private declarations } procedure WMDeviceChange(var Message: TMessage); message WM_DEVICECHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const DBT_DEVICEARRIVAL = $8000; const DBT_DEVICEQUERYREMOVE = $8001; const DBT_DEVICEQUERYREMOVEFAILED = $8002; const DBT_DEVICEREMOVEPENDING = $8003; const DBT_DEVICEREMOVECOMPLETE = $8004; const DBT_DEVICETYPESPECIFIC = $8005; const DBT_CONFIGCHANGED = $0018; procedure TForm1.WMDeviceChange(var Message: TMessage); var s : string; begin {Do Something here} case Message.wParam of DBT_DEVICEARRIVAL : s := 'A device has been inserted and is now available'; DBT_DEVICEQUERYREMOVE: begin s := 'Permission to remove a device is requested'; ShowMessage(s); {True grants premission} Message.Result := integer(true); exit; end; DBT_DEVICEQUERYREMOVEFAILED : s := 'Request to remove a device has been canceled'; DBT_DEVICEREMOVEPENDING : s := 'Device is about to be removed'; DBT_DEVICEREMOVECOMPLETE : s := 'Device has been removed'; DBT_DEVICETYPESPECIFIC : s := 'Device-specific event'; DBT_CONFIGCHANGED : s:= 'Current configuration has changed' else s := 'Unknown Device Message'; end; ShowMessage(s); inherited; end; Вопрос:
Как после записи в ini-файл сбросить cache на диск, чтоб задействовать изменения?
Ответ:
Вызовите функцию WriteProfileString() или WritePrivateProfileString(), передав ей в качестве параметров секции, ключа и строки - nil.
Пример:
WriteProfileString(nil, nil, nil); WritePrivateProfileString(nil, nil, nil, FileName); Вопрос:
Как с помощью Проводника открыть конкретный каталог?
Ответ:
Пример:
uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(0, 'explore', 'C:\WINDOWS', nil, nil, SW_SHOWNORMAL); end; Вопрос:
Как запустить аплет Панели управления?
Ответ:
Запустить аплет Панели управления можно вызвав функцию WinExec, для выполнения файла control.exe, которому передано имя аплета. Обычно аплеты панели управления расположены в каталоге System Windows и имеют расширение .cpl.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE MOUSE', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS', sw_ShowNormal); end; Вопрос:
Как печатать в цвете?
Ответ:
Обычно нет необходимости переводить принтер в режим цветной печати, если он установлен в этот режим. Windows автоматически переведет цветную печать в черно-белую, если принтер не поддерживает цветной печати. Если Вам необходимо програмно изменить режим цвета, Вы можете обратится к структуре DevMode драйвера принтера.
Пример:
uses Printers; procedure TForm1.Button1Click(Sender: TObject); var Device : array[0..255] of char; Driver : array[0..255] of char; Port : array[0..255] of char; hDMode : THandle; PDMode : PDEVMODE; begin with Printer do begin PrinterIndex := PrinterIndex; GetPrinter(Device, Driver, Port, hDMode); if hDMode <> 0 then begin pDMode := GlobalLock(hDMode); if pDMode <> nil then begin pDMode.dmFields := pDMode.dmFields or dm_Color; pDMode.dmColor := DMCOLOR_COLOR; GlobalUnlock(hDMode); end; end; PrinterIndex := PrinterIndex; BeginDoc; Canvas.Font.Color := clRed; Canvas.TextOut(100,100, 'Red As A Rose!'); EndDoc; end; end; Вопрос:
Как открыть URL браузером, установленным по умолчанию?
Ответ:
Используйте функцию ShellExecute.
Пример:
uses ShellAPI; procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(Form1.Handle, nil, 'http://www.borland.com', nil, nil, SW_SHOWNORMAL); end; Вопрос:
Как стереть ехе-файл во время его исполнения?
Ответ:
Это не возможно. Вы можете стереть его во время следующего запуска Windows, добавив ключ RunOnce: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
Пример:
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; Вопрос:
Как програмноинсталировать шрифты TrueType?
Ответ:
Скопируйте файл шрифта в директорию Windows\Fonts, и добавьте строку с именем шрифта и его расположением в разделе "'Software\Microsoft\Windows\CurrentVersion\Fonts". Вызовите функцию AddFontRecource(), а затем передайте системе сообщение WM_FONTCHANGE. И наконец, для удоления установленного шрифта, вызовите функцию RemoveFontRecource(), а затем передайте системе сообщение WM_FONTCHANGE.
Пример:
uses Registry; procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; b : bool; begin CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', b); reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', false); reg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); reg.CloseKey; reg.free; {Add the font resource} AddFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); {Remove the resource lock} RemoveFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; Вопрос:
Как получить список часовых поясов?
Ответ:
Пример:
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; Вопрос:
Какие значения возвращает функция GetTimeZoneInformation()?
Ответ:
const TIME_ZONE_ID_UNKNOWN = 0; const TIME_ZONE_ID_STANDARD = 1; const TIME_ZONE_ID_DAYLIGHT = 2; Вопрос:
Как сделать прозрачным фон текста?
Ответ:
Используйте функцию SetBkMode().
Пример:
procedure TForm1.Button1Click(Sender: TObject); var OldBkMode : integer; begin with Form1.Canvas do begin Brush.Color := clRed; FillRect(Rect(0, 0, 100, 100)); Brush.Color := clBlue; TextOut(10, 20, 'Not Transparent!'); OldBkMode := SetBkMode(Handle, TRANSPARENT); TextOut(10, 50, 'Transparent!'); SetBkMode(Handle, OldBkMode); end; end; Вопрос:
Как получить информацию о версии файла?
Ответ:
Для этого необходимо вызвать несколько функций API. В приведеннном ниже примере проверяется версия shell32.dll. Функция возвращает значение True - если версия DLL больше или равна 4.71 function TForm1.CheckShell32Version: Boolean; procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer); { Helper function to get the actual file version information } var Info: Pointer; InfoSize: DWORD; FileInfo: PVSFixedFileInfo; FileInfoSize: DWORD; Tmp: DWORD; begin // Get the size of the FileVersionInformatioin InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp); // If InfoSize = 0, then the file may not exist, or // it may not have file version information in it. if InfoSize = 0 then raise Exception.Create('Can''t get file version information for ' + FileName); // Allocate memory for the file version information GetMem(Info, InfoSize); try // Get the information GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); // Query the information for the version VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); // Now fill in the version information Major1 := FileInfo.dwFileVersionMS shr 16; Major2 := FileInfo.dwFileVersionMS and $FFFF; Minor1 := FileInfo.dwFileVersionLS shr 16; Minor2 := FileInfo.dwFileVersionLS and $FFFF; finally FreeMem(Info, FileInfoSize); end; end; var tmpBuffer: PChar; Shell32Path: string; VersionMajor: Integer; VersionMinor: Integer; Blank: Integer; begin tmpBuffer := AllocMem(MAX_PATH); // Get the shell32.dll path try GetSystemDirectory(tmpBuffer, MAX_PATH); Shell32Path := tmpBuffer + '\shell32.dll'; finally FreeMem(tmpBuffer); end; // Check to see if it exists if FileExists(Shell32Path) then begin // Get the file version GetFileVersion(Shell32Path, VersionMajor, VersionMinor, Blank, Blank); // Do something, such as require a certain version // (such as greater than 4.71) if (VersionMajor >= 4) and (VersionMinor >= 71) then Result := True else Result := False; end else Result := False; end; Вопрос:
Как создать иконку из bitmap'а?
Ответ:
Нужно создать два bitmap'а: bitmap-маску ("AND" bitmap) и bitmap-картинку (XOR bitmap). Потом передать дескрипторы "AND" и "XOR" bitmap-ов API функции CreateIconIndirect()
Пример:
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; Вопрос:
Как преобразовать RGB-цвет в оттенки серого?
Ответ:
В приведенном примере для преобразования RGB-цвета используются коэффициенты, принятые в телевидении: 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; Вопрос:
Как держать приложение в минимизированном виде?
Ответ:
Установите свойство WindowState в Minimized. Создайте обработчик сообщения WM_QueryOpen.
Пример:
{Place this code in the private section of the Form declaration} procedure WMQueryOpen(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN; {Place this code in the Form implementation section} procedure TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen); begin Msg.Result := 0; end; Вопрос:
при вызове функции RegisterClass я получаю ошибку: "Incompatible types: 'TPersistantClass' and 'TWndClassA'"
Ответ:
Функция RegisterClass() обьявлена в модулях Classes и Windows unit. Чтобы вызвать функцию из модуля Windows просто добавте префикс "Windows."
Пример:
procedure TForm1.Button1Click(Sender: TObject); wc : TWndClass; begin Windows.RegisterClass(wc) end; Вопрос:
Как принять файлы, брошенные на мою форму по drag & drop
Ответ:
Нужно сообщить Windows, что ваша форма принимает файлы по drag & drop с помощью функции Shell API DragAcceptFiles.(в обработчике события form create) Затем нужно реагироавть на сообытия drag & drop чтобы принять файлы. (см. пример) unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; procedure FormCreate(Sender: TObject); private procedure WMDROPFILES(var Message: TWMDROPFILES); message WM_DROPFILES; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses ShellApi; procedure TForm1.FormCreate(Sender: TObject); begin {Let Windows know we accept dropped files} DragAcceptFiles(Form1.Handle, True); end; procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES); var NumFiles : longint; i : longint; buffer : array[0..255] of char; begin {How many files are being dropped} NumFiles := DragQueryFile(Message.Drop, -1, nil, 0); {Accept the dropped files} for i := 0 to (NumFiles - 1) do begin DragQueryFile(Message.Drop, i, @buffer, sizeof(buffer)); Form1.Memo1.Lines.Add(buffer); end; end; end. Вопрос:
Как создать задержку не подвешивая систему без компонента TTimer ?
Ответ:
В примере используется вызов Application.ProcessMessages для того, чтобы Windows обрабатывал сообщения во время цикла задержки. procedure Delay(ms : longint); var TheTime : LongInt; begin TheTime := GetTickCount + ms; while GetTickCount < TheTime do Application.ProcessMessages; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Start Test'); Delay(2000); ShowMessage('End Test'); end; Вопрос:
Как програмно перезагрузить Windows? Ответ: Используйте функцию ExitWindows(). В качестве первого параметра ей передается она из трех констант: EW_RESTARTWINDOWS EW_REBOOTSYSTEM EW_EXITANDEXECAPP Второй параметр используется для перезагрузки компьютера в режиме эмуляции MS DOS.
Пример:
ExitWindows(EW_RESTARTWINDOWS, 0 );
(c) 1999 .
Last Modified Friday, 06-Aug-99 11:12:04 PST.
Translated & Adapted by
17-Aug-1999
Заготовки для сборщика мусора.
Для использования мониторинга, модуль GCSystem.pas нужно включить первым в проект.
В каталоге программы создастся файл log.txt, в котором будут все выделения и освобождения памяти, а также создание/уничтожение объектов.
Файл log.txt можно обработать анализатором (analog.bat). При этом создадутся файлы log1.txt с неосвобождённой памятью и log2.txt с неудалёнными объектами.
GCSystem.pas работает как при сборке с пакетами, так и без.
Примеры логов:
Log1.txt:
| +16, Address: 13241272 +16, Address: 13244248 ReallocMem, +32 Address Source: 13244248 Address Dest: 13244248 +16, Address: 13244644 +16, Address: 13244664 ReallocMem, +48 Address Source: 13244248 Address Dest: 13244732 +16, Address: 13244840 +16, Address: 13244876 +16, Address: 13244912 +16, Address: 13244952 +16, Address: 13244996 +128, Address: 13245016 ReallocMem, +32 Address Source: 13244664 Address Dest: 13246016 ReallocMem, +48 Address Source: 13246016 Address Dest: 13246080 +16, Address: 13244664 ReallocMem, +112 Address Source: 13246080 Address Dest: 13262008 |
Log2.txt:
| +16, Address: 13241252 Create: TIntConst, Address: 13241252 +16, Address: 13241292 Create: TIntConst, Address: 13241292 +48, Address: 13242948 Create: THelpManager, Address: 13242948 +20, Address: 13243000 Create: TObjectList, Address: 13243000 +20, Address: 13243024 Create: TObjectList, Address: 13243024 +20, Address: 13243048 Create: TObjectList, Address: 13243048 +16, Address: 13244112 Create: TIntConst, Address: 13244112 +20, Address: 13244132 Create: TRegGroup, Address: 13244132 +16, Address: 13244156 Create: TList, Address: 13244156 +48, Address: 13244176 Create: TStringList, Address: 13244176 +16, Address: 13244228 Create: TList, Address: 13244228 +36, Address: 13244784 Create: TWinHelpViewer, Address: 13244784 +16, Address: 13244932 Create: TList, Address: 13244932 +28, Address: 13260600 Create: TCriticalSection, Address: 13260600 |
Скачать: — Тестовый проект (Delphi 6) — Модуль для Delphi 5
"Живой Desktop" — вариант использования Shell
| Раздел Сокровищница |
Что это:Прикольное расширение Shellа. Назначение:Разовое применение с целью разрушить устоявшееся представление индивидума о незыблемости иконок на рабочем столе. Показания: WinNT4/Win2000 (для других не проверялось); Непосредственный доступ к жертве; D6 +/- 3 версии я думаю.
Внимание - это демонстрация, содержит как минимум одну ошибку приводящую к завершению работы Explorerа без сохранения данных через ~ 20 мин.
Предыстория: Работает у нас один парень все ничего вот только у него странная тяга к иконкам на рабочем столе что выражается в их не мерянном количестве и особо структурированном распределении (сложном и непонятном с полпинка). Как то раз, с утречка он включает комп и... О БОЖЕ !?!?!, по неизвестной причине, ОНИ (иконки - прядка 30~40 штук) были упорядочены!!! и выровнены!!! стандартным образом... что тут началось... (вырезано по требованию правозащитных организаций ) прям конец света :) в общем стены устояли. Парень наотрез отказался работать до тех пор пока не расставит все иконки в только ему ведомом порядке и в соответствии с распределением космических сил - ушел в нирвану на пол дня.
Ну и я, под впечатлением от силы воздействия иконок, решил написать прогу по их своеобразному упрядовачиванию в (как говорится) real-time :) Как сделано: После взвешивания цели и возможных средств доставки было выбрано - повесить на получение контекстного меню (Explorer файл/папка) дллку в которой собственно и осуществляется вся работа.
В качестве основы был взят пример \Borland\Delphi6\Demos\ActiveX\ShellExt\..
Реализовано три алгоритма поведения иконок - черви (Worms), частицы (Atoms) и мышь серая (Mouse). Worms: черви в виде цепочек иконок бегают по рабочему столу поедая друг друга увеличиваясь в длине. Atoms: мечутся по экрану с учетом связей между собой. Mouse: избегают курсора мыши. Содержание: ContextM.pas - реализация IContextMenu DeskHelp.pas - получение хендла ListView рабочего стола UthDeskIcon.pas - алгоритмы по управлению иконками fsc.reg - регистрация в системе FtpSC32.dpr - проект дллки ReadMe.txt - хмм Скачать (56K)
Митронов Станислав
