Зайцев О.В. и Владимиров А.М.
Дата последней редакции 10.10.1999
Прочее
Вопросы - ответы - советы
Глюки
Как отличить режим дизайна от режима
запущенного приложения:
if not (csDesigning in ComponentState) then {запущено приложениее}
От авторов ...
Зайцев О.В.
Владимиров А.М.
Как получить горизонтальную прокрутку (scrollbar) в ListBox?
procedure TForm1.FormCreate(Sender: TObject); begin ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0)); end;
Второй параметр в вызове - ширина прокрутки в
точках.
Поиск строки в ListBox
Есть функция API Windows, что заставляет искать строку
в ListBox с указанной позиции.
Например, поиск строки, что начинается на '1.' От
текущей позиции курсора в ListBox. Т.о., нажимая на
кнопку Button1, будут перебраны все строки
начинающиеся на '1.'
procedure TForm1.Button1Click(Sender: TObject); var S : string; begin S:='1.'; with ListBox1 do ItemIndex := Perform(LB_SELECTSTRING, ItemIndex, LongInt(S)); end;
Более подробную информацию о работе
команды LB_SELECTSTRING можно узнать из Help-а Win32.
Пример получения позиции курсора из компоненты TMemo.
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin Memo1Click(Self); end; procedure TForm1.Memo1Click(Sender: TObject); VAR LineNum : LongInt; CharNum : LongInt; begin LineNum := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0); CharNum := Memo1.Perform(EM_LINEINDEX, LineNum, 0); Label1.Caption := IntToStr(LineNum+1)+' : '+IntToStr((Memo1.SelStart-CharNum)+1); end; procedure TForm1.FormCreate(Sender: TObject); begin Memo1Click(Self); end;
Функция Undo в TMemo
В компоненте TMemo предусмотрена функция отмены
последней правки (Undo). Ее можно вызвать следующим
образом:
Memo1.Perform(EM_UNDO,0,0);
Узнать о том, возможна ли отмена (т.е. есть ли что
отменять) можно следующим образом:
UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);
Как прокрутить текст в Tmemo или в TRichEdit
Я добавляю програмно несколько строк в конец
поля Memo, а их не видно. Как прокрутить Memo, чтобы
было видно последние строки ?
Примерно так:
SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);
Как определить работает ли уже данное приложение или это первая его копия?
Для Delphi 1. Каждый экземпляр программы имеет
ссылку на свою предыдущую копию - hPrevInst: hWnd. Ее
можно проверить перед созданием приложения и при
необходимости отреагировать соответствующим
образом. Если запущена только одна копия, то эта
ссылка равна нулю.
Пример:
procedure TForm1.FormCreate(Sender: TObject); begin {Проверяем есть ли указатель на предыдущую копию приложения} IF hPrevInst <> 0 THEN BEGIN {Если есть, то выдаем сообщение и выходим} MessageDlg('Программа уже запущена!', mtError, [mbOk], 0); Halt; END; {Иначе - ничего не делаем (не мешаем созданию формы)} end;
P.S. Для выхода необходимо использовать Halt, а не
Close, как хотелось бы, так как форма еще не создана
и закрывать нечего.
Есть и другой способ - по списку загруженных
приложений
procedure TForm1.FormCreate(Sender: TObject); VAR Wnd : hWnd; buff : ARRAY[0.. 127] OF Char; Begin Wnd := GetWindow(Handle, gw_HWndFirst); WHILE Wnd <> 0 DO BEGIN IF (Wnd <> Application.Handle) AND (GetWindow(Wnd, gw_Owner) = 0) THEN BEGIN GetWindowText (Wnd, buff, sizeof (buff )); IF StrPas (buff) = Application.Title THEN BEGIN MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0); Halt; END; END; Wnd := GetWindow (Wnd, gw_hWndNext); END; End;
Еще один интересный способ для Win32. Дело в том,
что можно в памяти создавать временные файлы. При
перезагрузке они теряются, а так существуют.
Кстати, этот метод можно использовать и для
обмена информацией между вашими приложениями.
Пример:
program Project1; uses Windows, // Обязательно Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} Const MemFileSize = 1024; MemFileName = 'one_inst_demo_memfile'; Var MemHnd : HWND; begin { Попытаемся создать файл в памяти } MemHnd := CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READWRITE, 0, MemFileSize, MemFileName); { Если файл не существовал запускаем приложение } if GetLastError<>ERROR_ALREADY_EXISTS then begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end; CloseHandle(MemHnd); end.
Часто при работе у пользователя может быть
открыто 5-20 окон и сообщение о том, что программа
уже запущено приводит к тому, что он вынужден
полчаса искать ранее запущенную копию. Выход из
положения - найдя копию программы активировать
ее, для чего в последнем примере перед HALT
необходимо добавить строку :
SetForegroundWindow(Wnd);
Например так:
program Project0; uses Windows, // !!! Forms, Unit0 in 'Unit0.pas' {Form1}; var Handle1 : LongInt; Handle2 : LongInt; {$R *.RES} begin Application.Initialize; Handle1 := FindWindow('TForm1',nil); if handle1 = 0 then begin Application.CreateForm(TForm1, Form1); Application.Run; end else begin Handle2 := GetWindow(Handle1,GW_OWNER); //Чтоб заметили :) ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE); SetForegroundWindow(Handle1); // Активизируем end; end.
Пример вывода сообщения одной командой и ввода строки тоже одной командой.
unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Пример простого сообщения.'+#10+ 'Данное сообщение выводится всегда в центре экрана.'); end; procedure TForm1.Button2Click(Sender: TObject); begin ShowMessagePos('Пример сообщения с указанием его положения на экране.', Form1.Left+Button2.Left, Form1.Top+Button2.Top); end; procedure TForm1.Button3Click(Sender: TObject); begin Button3.Caption := InputBox('Delphi для всех', 'Введите строку:', Button3.Caption); end; end.
Перетаскивание формы за ее поле
procedure TForm1.MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); const SC_DragMove = $F012; { a magic number } begin ReleaseCapture; perform(WM_SysCommand, SC_DragMove, 0); end;
Обработка событий от клавиатуры
{текст библиотеки} library SendKey; uses WinTypes, WinProcs, Messages; const {пользовательские сообщения} wm_NextShow_Event = wm_User + 133; wm_PrevShow_Event = wm_User + 134; {handle для ловушки} HookHandle: hHook = 0; var SaveExitProc : Pointer; {собственно ловушка} function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export; var H: HWND; begin {если Code>=0, то ловушка может обработать событие} if Code >= 0 then begin {это те клавиши?} if ((wParam = VK_ADD)or(wParam = VK_SUBTRACT)) and (lParam and $40000000 = 0) then begin {ищем окно по имени класса и по заголовку} H := FindWindow('TForm1', 'XXX'); {посылаем сообщение} if wParam = VK_ADD then SendMessage(H, wm_NextShow_Event, 0, 0) else SendMessage(H, wm_PrevShow_Event, 0, 0); end; {если 0, то система должна дальше обработать это событие} {если 1 - нет} Result:=0; end else {если Code<0, то нужно вызвать следующую ловушку} Result := CallNextHookEx(HookHandle,Code, wParam, lParam); end; {при выгрузке DLL надо снять ловушку} procedure LocalExitProc; far; begin if HookHandle<>0 then begin UnhookWindowsHookEx(HookHandle); ExitProc := SaveExitProc; end; end; {инициализация DLL при загрузке ее в память} begin {устанавливаем ловушку} HookHandle := SetWindowsHookEx(wh_Keyboard, Key_Hook, hInstance, 0); if HookHandle = 0 then MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok) else begin SaveExitProc := ExitProc; ExitProc := @LocalExitProc; end; end.
Размер такой DLL в скомпилированном виде будет
около 3Кб, поскольку в ней не используются
объекты из VCL.
Далее приведен код модуля в Delphi, который
загружает DLL и обрабатывает сообщения от ловушки,
просто отображая их в Label1.
unit Unit1; interface uses SysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls; {пользовательские сообщения} const wm_NextShow_Event = wm_User + 133; wm_PrevShow_Event = wm_User + 134; type TForm1 = class(TForm) Label1: TLabel; procedure FormCreate(Sender: TObject); private {обработчики сообщений} procedure WM_NextMSG (Var M : TMessage); message wm_NextShow_Event; procedure WM_PrevMSG (Var M : TMessage); message wm_PrevShow_Event; end; var Form1: TForm1; P : Pointer; implementation {$R *.DFM} {загрузка DLL} function Key_Hook : Longint; far; external 'SendKey'; procedure TForm1.WM_NextMSG (Var M : TMessage); begin Label1.Caption:='Next message'; end; procedure TForm1.WM_PrevMSG (Var M : TMessage); begin Label1.Caption:='Previous message'; end; procedure TForm1.FormCreate(Sender: TObject); begin {если не использовать вызов процедуры из DLL в программе, то компилятор удалит загрузку DLL из программы} P:=@Key_Hook; end; end.
Конечно, свойство Caption в этой форме должно быть
установлено в "XXX".
Как сделать так, что при нажатии на Enter происходил переход к следующему элементу формы
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if (Key = #13) then begin Key:=#0; Perform(WM_NEXTDLGCTL,0,0); end; end;
Вставка и удаление компонент в форму в design-time
Вопрос:
Каким образом можно отследить вставку и удаление
компонент в форму в design-time? Такая информация
могла бы пригодится, если моя компонента имеет
ссылки на другие компоненты (например, как в
связке TDateSource,TTable и др.)
Ответ:
Для получения такой информации предназначен
метод
procedure Notification (AComponent: TComponent; Operation: TOperation); virtual;
класса TComponent. Перекрыв его в своей компоненты Вы
можете произвести необходимые действия, в
зависимости от значения параметра Operation типа
TOperation = (opInsert, opRemove);
объявленного в модуле Classes. Параметр AComponent -
компонента, соответственно вставлемая или
удаляемая, в зависимости от Operation.
Создание отчета в MS Word
(Пример для Delphi 1.0 поскольку в Delphi 2-3 лучше
использовать:
var MsWord : variant;
MsWord := CreateOleObject('Word.Basic'); Для Delphi 3, пример ниже)
Создавать отчет в программе Word удобно если отчет
имеет сложную структуру (тогда его быстрее
создать в Word, чем в Qreport от Delphi, кроме того, этот
QReport имеет "глюки"), либо, если после создания
отчета его нужно будет изменять. Итак, первым
делом в Word создается шаблон будущего отчета, это
самый обыкновенный не заполненный отчет. А в
места куда будет записываться информация нужно
поставить метки. Например (для наглядности метки
показаны зеленым цветом, реально они конечно не
видны):
Накладная ? Num
? |
Поставщик |
Наименование товара |
Код товара |
Кол-во |
Цена |
Сумма |
Table |
Сдал_______________________ Принял________________________ М.П. М.П.
Далее в форму, откуда будут выводиться данные,
вставляете компоненту DdeClientConv из палитры System.
Назовем ее DDE1. Эта компонента позволяет
передавать информацию между программами методом
DDE. Свойства:
ConnectMode : ddeManual - связь устанавливаем вручную
DdeService : (winword) - с кем устанавливается связь
ServiceApplication : C:\MSOffice\Winword\WINWORD.EXE - полный путь
доступа к программе. (Вот здесь можно наступить
на грабли. Ведь Word может лежать в любой папке!
Поэтому путь доступа к нему лучше взять из
реестра, а еще лучше использовать OLE см.начало
раздела)
Теперь пишем процедуру передачи данных:
{ Печать накладной } procedure Form1.PrintN; Var S : string; i : integer; Sum : double; {итоговая сумма, кстати,совет: не пользуйтесь типом real!} Tv, Ss : PChar; begin S:=GetCurrentDir+'\Накладная.doc'; { имя открываемого документа } DDE1.OpenLink; { устанавливаем связь } Tv:=StrAlloc(20000); Ss:=StrAlloc(300); { выделяем память } { даем команду открыть документ и установить курсор в начало документа } StrPCopy(Tv, '[FileOpen "'+S+'"][StartOfDocument]'); S:=NNakl.Text; { номер накладной } { записываем в позицию Num номер накладной } StrCat(Tv, StrPCopy(SS, '[EditBookmark .Name = "Num", .Goto][Insert "'+S+'"]'+ '[EditBookmark .Name = "Table", .Goto]'); { и переходим к заполнению таблицы } { передаем данные в Word } if not DDE1.ExecuteMacro(Tv, false) then begin { сообщаем об ошибке и выход } MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0); StrDispose(Tv); StrDispose(Ss); exit; end; { Заполняем таблицу } Sum:=0; Nn:=0; for i:=0 to TCount do begin inc(Nn); { предполагаем, что данные находятся в массиве T } StrPCopy(Tv, '[Insert "'+IntToStr(Nn)+'"][NextCell][Insert "'+T[i].Company+'"]'+ '[NextCell][Insert "'+T.TName+'"][NextCell][Insert "'+T.Cod+'"][NextCell]'+ '[Insert "'+IntToStr(T.Count)+'"][NextCell]'+ '[Insert "'+FloatToStr(T.Cena)+'"][NextCell]'+ '[Insert "'+FloatToStr(T.Count*T.Cena)*+'"][NextCell]')); inc(Nn); Sum:=Sum+(T.Count*T.Cena); { итоговая сумма } if not DDE1.ExecuteMacro(Tv, false) then begin MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0); exit; end; end; { Записываем итоговую сумму } StrPCopy(Tv, '[NextCell][Insert "Итого"][NextCell][NextCell][NextCell]'+ '[Insert "'+FloatToStr(Sum)+'"]')); if not DDE1.ExecuteMacro(Tv, false) then MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0) else MessageDlg('Акт удачно создан. Перейдите в Microsoft Word.', mtInformation, [mbOk], 0); StrDispose(Tv); StrDispose(Ss); end;
Для Delphi 2 и выше === Cut Пример by Sergey Arkhipov 2:5054/88.10 === Пример проверен только на русском Word 7.0! Может, поможет... unit InWord; interface uses ... ComCtrls; // Delphi3 ... OLEAuto; // Delphi2 [skip] procedure TPrintForm.MPrintClick(Sender: TObject); var W: Variant; S: String; begin S:=IntToStr(Num); try // А вдруг где ошибка :) W:=CreateOleObject('Word.Basic'); // Создаем документ по шаблону MyWordDot // с указанием пути если он не в папке шаблонов Word W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0); // Отключение фоновой печати (на LJ5L без этого был пустой лист) W.ToolsOptionsPrint(Background:=0); // Переходим к закладке Word'a 'Num' W.EditGoto('Num'); W.Insert(S); //Сохранение W.FileSaveAs('C:\MayPath\Reports\MyReport') W.FilePrint(NumCopies:='2'); // Печать 2-х копий finally W.ToolsOptionsPrint(Background:=1); W:=UnAssigned; end; end; {.....} === Cut Конец примера ===
Спасибо Сергею :) И еще, как определить установлен ли на компьютере Word, запустить его и загрузить в него текст из программы?
Пример:
var MsWord: Variant; ... try // Если Word уже запущен MsWord := GetActiveOleObject('Word.Application'); // Взять ссылку на запущенный OLE объект except try // Word не запущен, запустить MsWord := CreateOleObject('Word.Application'); // Создать ссылку на зарегистрированный OLE объект MsWord.Visible := True; except ShowMessage('Не могу запустить Microsoft Word'); Exit; end; end; end; ... MSWord.Documents.Add; // Создать новый документ MsWord.Selection.Font.Bold := True; // Установить жирный шрифт MsWord.Selection.Font.Size := 12; // установить 12 кегль MsWord.Selection.TypeText('Текст');
По командам OLE Automation сервера см. help по
Microsoft Word Visual Basic.
Ну вот и все.
{ На эту форму можно бросить файл (например из проводника) и он будет открыт } unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, ShellAPI {обязательно!}; type TForm1 = class(TForm) Memo1: TMemo; FileNameLabel: TLabel; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); protected {Это и есть самая главная процедура} procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMDropFiles(var Msg: TMessage); var Filename: array[0 .. 256] of Char; Count : integer; begin { Получаем количество файлов (просто пример) } nCount := DragQueryFile( msg.WParam, $FFFFFFFF, acFileName, cnMaxFileNameLen); { Получаем имя первого файла } DragQueryFile( THandle(Msg.WParam), 0, { это номер файла } Filename,SizeOf(Filename) ) ; { Открываем его } with FileNameLabel do begin Caption := LowerCase(StrPas(FileName)); Memo1.Lines.LoadfromFile(Caption); end; { Отдаем сообщение о завершении процесса } DragFinish(THandle(Msg.WParam)); end; procedure TForm1.FormCreate(Sender: TObject); begin { Говорим Windows, что на нас можно бросать файлы } DragAcceptFiles(Handle, True); end; procedure TForm1.FormDestroy(Sender: TObject); begin { Закрываем за собой дверь золотым ключиком} DragAcceptFiles(Handle, False); end; end.
Привлечение внимания к окну
Часто возникает проблема - в многооконном
приложении необходимо обратить внимание
пользователя на то, что какое-то из окон требует
внимания (например, к нему пришло сообщение по DDE,
в нем завершился какой-либо процесс, произошла
ошибка ...). Это легко сделать, используя команду API
FlashWindow:
procedure TForm1.Timer1Timer(Sender: TObject); begin FlashWindow(Handle,true); end;
В данном примере FlashWindow вызывается по
таймеру ежесекундно, что приводит к миганию
заголовка окна.
Заставка для программы
Сведения о программе, авторские права и т.д.,
лучше оформить в виде отдельной формы и
показывать ее при запуске программы (как это
сделано в Word).
Сделать это не сложно:
1. Создаете форму (например SplashForm).
2. Объявляете ее свободной (availableForms).
3. В Progect Source вставляете следующее (например):
program Splashin; uses Forms, Main in 'MAIN.PAS', Splash in 'SPLASH.PAS' {$R *.RES} begin try SplashForm := TSplashForm.Create(Application); SplashForm.Show; SplashForm.Update; Application.CreateForm(TMainForm, MainForm); SplashForm.Hide; finally SplashForm.Free; end; Application.Run; end.
И форма SplashForm держится на экране пока
выполняется Create в главной форме. Но иногда она
появляется и пропадает очень быстро, поэтому
нужно сделать задержку:
1. Добавляете на форму таймер с событием:
procedure TSplashForm.Timer1Timer(Sender: TObject); begin Timer1.Enabled := False; end;
2. Событие onCloseQuery для формы:
procedure TSplashForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin CanClose := Not Timer1.Enabled; end;
3. И перед SplashForm.Hide; ставите цикл:
repeat Application.ProcessMessages; until SplashForm.CloseQuery;
4. Все! Осталось установить на таймере
период задержки 3-4 секунды.
5. На последок, у такой формы желательно убрать
Caption:
SetWindowLong (Main.Handle,GWL_STYLE, GetWindowLong(Main.Handle, GWL_STYLE) AND NOT
WS_CAPTION OR WS_SIZEBOX);
Прозрачная форма
Эта форма имет прозрачный фон !!! unit unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; // это просто кнопка на форме - для демонстрации protected procedure RebuildWindowRgn; procedure Resize; override; public constructor Create(AOwner: TComponent); override; end; var Form1 : TForm1; implementation // ресурс этой формы {$R *.DFM} { Прозрачная форма } constructor TForm1.Create(AOwner: TComponent); begin inherited; // убираем сколлбары, чтобы не мешались // при изменении размеров формы HorzScrollBar.Visible:= False; VertScrollBar.Visible:= False; // строим новый регион RebuildWindowRgn; end; procedure TForm1.Resize; begin inherited; // строим новый регион RebuildWindowRgn; end; procedure TForm1.RebuildWindowRgn; var FullRgn, Rgn: THandle; ClientX, ClientY, I: Integer; begin // определяем относительные координаты клиенской части ClientX:= (Width - ClientWidth) div 2; ClientY:= Height - ClientHeight - ClientX; // создаем регион для всей формы FullRgn:= CreateRectRgn(0, 0, Width, Height); // создаем регион для клиентской части формы // и вычитаем его из FullRgn Rgn:= CreateRectRgn(ClientX, ClientY, ClientX + ClientWidth, ClientY + ClientHeight); CombineRgn(FullRgn, FullRgn, Rgn, rgn_Diff); // теперь добавляем к FullRgn регионы каждого контрольного элемента for I:= 0 to ControlCount -1 do with Controls[I] do begin Rgn:= CreateRectRgn(ClientX + Left, ClientY + Top, ClientX + Left + Width, ClientY + Top + Height); CombineRgn(FullRgn, FullRgn, Rgn, rgn_Or); end; // устанавливаем новый регион окна SetWindowRgn(Handle, FullRgn, True); end; end. А как Вам понравится эта форма ? unit rgnu; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, Menus; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure FormPaint(Sender: TObject); private { Private declarations } rTitleBar : THandle; Center : TPoint; CapY : Integer; Circum : Double; SB1 : TSpeedButton; RL, RR : Double; procedure TitleBar(Act : Boolean); procedure WMNCHITTEST(var Msg: TWMNCHitTest); message WM_NCHITTEST; procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE); message WM_NCACTIVATE; procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT; end; var Form1: TForm1; implementation {$R *.DFM} CONST TitlColors : ARRAY[Boolean] OF TColor = (clInactiveCaption, clActiveCaption); TxtColors : ARRAY[Boolean] OF TColor = (clInactiveCaptionText, clCaptionText); procedure TForm1.FormCreate(Sender: TObject); VAR rTemp, rTemp2 : THandle; Vertices : ARRAY[0..2] OF TPoint; X, Y : INteger; begin Caption := 'OOOH! Doughnuts!'; BorderStyle := bsNone; {required} IF Width > Height THEN Width := Height ELSE Height := Width; {harder to calc if width <> height} Center := Point(Width DIV 2, Height DIV 2); CapY := GetSystemMetrics(SM_CYCAPTION)+8; rTemp := CreateEllipticRgn(0, 0, Width, Height); rTemp2 := CreateEllipticRgn((Width DIV 4), (Height DIV 4), 3*(Width DIV 4), 3*(Height DIV 4)); CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF); SetWindowRgn(Handle, rTemp, True); DeleteObject(rTemp2); rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4); rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY); CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF); Vertices[0] := Point(0,0); Vertices[1] := Point(Width, 0); Vertices[2] := Point(Width DIV 2, Height DIV 2); rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE); CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND); DeleteObject(rTemp); RL := ArcTan(Width / Height); RR := -RL + (22 / Center.X); X := Center.X-Round((Center.X-1-(CapY DIV 2))*Sin(RR)); Y := Center.Y-Round((Center.Y-1-(CapY DIV 2))*Cos(RR)); SB1 := TSpeedButton.Create(Self); WITH SB1 DO BEGIN Parent := Self; Left := X; Top := Y; Width := 14; Height := 14; OnClick := Button1Click; Caption := 'X'; Font.Style := [fsBold]; END; end; procedure TForm1.Button1Click(Sender: TObject); begin Close; End; procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest); begin Inherited; WITH Msg DO WITH ScreenToClient(Point(XPos,YPos)) DO IF PtInRegion(rTitleBar, X, Y) AND (NOT PtInRect(SB1.BoundsRect, Point(X,Y))) THEN Result := htCaption; end; procedure TForm1.WMNCActivate(var Msg: TWMncActivate); begin Inherited; TitleBar(Msg.Active); end; procedure TForm1.WMSetText(var Msg: TWMSetText); begin Inherited; TitleBar(Active); end; procedure TForm1.TitleBar(Act: Boolean); VAR TF : TLogFont; R : Double; N, X, Y : Integer; begin IF Center.X = 0 THEN Exit; WITH Canvas DO begin Brush.Style := bsSolid; Brush.Color := TitlColors[Act]; PaintRgn(Handle, rTitleBar); R := RL; Brush.Color := TitlColors[Act]; Font.Name := 'Arial'; Font.Size := 12; Font.Color := TxtColors[Act]; Font.Style := [fsBold]; GetObject(Font.Handle, SizeOf(TLogFont), @TF); FOR N := 1 TO Length(Caption) DO BEGIN X := Center.X-Round((Center.X-6)*Sin(R)); Y := Center.Y-Round((Center.Y-6)*Cos(R)); TF.lfEscapement := Round(R * 1800 / pi); Font.Handle := CreateFontIndirect(TF); TextOut(X, Y, Caption[N]); R := R - (((TextWidth(Caption[N]))+2) / Center.X); IF R < RR THEN Break; END; Font.Name := 'MS Sans Serif'; Font.Size := 8; Font.Color := clWindowText; Font.Style := []; end; end; procedure TForm1.FormPaint(Sender: TObject); begin WITH Canvas DO BEGIN Pen.Color := clBlack; Brush.Style := bsClear; Pen.Width := 1; Pen.Color := clWhite; Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height); Arc((Width DIV 4)-1, (Height DIV 4)-1, 3*(Width DIV 4)+1, 3*(Height DIV 4)+1, 0, Height, Width, 0); Pen.Color := clBlack; Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0); Arc((Width DIV 4)-1, (Height DIV 4)-1, 3*(Width DIV 4)+1, 3*(Height DIV 4)+1, Width, 0, 0, Height); TitleBar(Active); END; end; end.
Как получить короткий путь файла если имеется длинный ("c:\Program Files" ==> "c:\progra~1")
Как создать свою кнопку в заголовке формы (на Caption Bar)
Непосредственно такой функции вроде нет, но
можно изловчиться. Нарисовать там кнопку вручную
и обрабатывать команды нажатия мышки на Caption Bar.
Пример.
unit Main; interface uses Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormResize(Sender: TObject); private CaptionBtn : TRect; procedure DrawCaptButton; procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint; procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE; procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT; procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST; procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN; public { Public declarations } end; var Form1: TForm1; implementation const htCaptionBtn = htSizeLast + 1; {$R *.DFM} procedure TForm1.DrawCaptButton; var xFrame, yFrame, xSize, ySize : Integer; R : TRect; begin //Dimensions of Sizeable Frame xFrame := GetSystemMetrics(SM_CXFRAME); yFrame := GetSystemMetrics(SM_CYFRAME); //Dimensions of Caption Buttons xSize := GetSystemMetrics(SM_CXSIZE); ySize := GetSystemMetrics(SM_CYSIZE); //Define the placement of the new caption button CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2, yFrame + 2, xSize - 2, ySize - 4); //Get the handle to canvas using Form's device context Canvas.Handle := GetWindowDC(Self.Handle); Canvas.Font.Name := 'Symbol'; Canvas.Font.Color := clBlue; Canvas.Font.Style := [fsBold]; Canvas.Pen.Color := clYellow; Canvas.Brush.Color := clBtnFace; try DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False); //Define a smaller drawing rectangle within the button R := Bounds(Width - xFrame - 4 * xSize + 2, yFrame + 3, xSize - 6, ySize - 7); with CaptionBtn do Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W'); finally ReleaseDC(Self.Handle, Canvas.Handle); Canvas.Handle := 0; end; end; procedure TForm1.WMNCPaint(var Msg : TWMNCPaint); begin inherited; DrawCaptButton; end; procedure TForm1.WMNCActivate(var Msg : TWMNCActivate); begin inherited; DrawCaptButton; end; procedure TForm1.WMSetText(var Msg : TWMSetText); begin inherited; DrawCaptButton; end; procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest); begin inherited; with Msg do if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then Result := htCaptionBtn; end; procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown); begin inherited; if (Msg.HitTest = htCaptionBtn) then ShowMessage('You hit the button on the caption bar'); end; procedure TForm1.FormResize(Sender: TObject); begin //Force a redraw of caption bar if form is resized Perform(WM_NCACTIVATE, Word(Active), 0); end; end.
Преобразование текста OEM у Ansi
function ConvertAnsiToOem(const S : string) : string; { ConvertAnsiToOem translates a string into the OEM-defined character set } {$IFNDEF WIN32} var Source, Dest : array[0..255] of Char; {$ENDIF} begin {$IFDEF WIN32} SetLength(Result, Length(S)); if Length(Result) > 0 then AnsiToOem(PChar(S), PChar(Result)); {$ELSE} if Length(Result) > 0 then begin AnsiToOem(StrPCopy(Source, S), Dest); Result := StrPas(Dest); end; {$ENDIF} end; { ConvertAnsiToOem } function ConvertOemToAnsi(const S : string) : string; { ConvertOemToAnsi translates a string from the OEM-defined character set into either an ANSI or a wide-character string } {$IFNDEF WIN32} var Source, Dest : array[0..255] of Char; {$ENDIF} begin {$IFDEF WIN32} SetLength(Result, Length(S)); if Length(Result) > 0 then OemToAnsi(PChar(S), PChar(Result)); {$ELSE} if Length(Result) > 0 then begin OemToAnsi(StrPCopy(Source, S), Dest); Result := StrPas(Dest); end; {$ENDIF} end; { ConvertOemToAnsi }
Состояние кнопки insert (Insert/Overwrite)
{------------------------------------------} { Returns the status of the Insert key. } {------------------------------------------} function InsertOn: Boolean; begin if LowOrderBitSet(GetKeyState(VK_INSERT)) then InsertOn := true else InsertOn := false end;
Сводка функций модуля Math
Здесь я привожу полный список всех функций и
процедур модуля Math. При переходе от Delphi 2 к Delphi 3
модуль Math почти не изменился, фирма Borland ввела в
него только три новые функции: MaxIntVal ue, MInIntValue и
Sumint. Эти функции отличаются от своих прототипов
(MaxValue, MI nVal ue и Sum) лишь тем, что работают
исключительно с целыми числами, не принимая и не
возвращая величин с плавающей точкой. Что
касается остальных функций, то большинство из
них вполне очевидно. Если вам покажется иначе -
что ж, садитесь за исследования. И не надейтесь,
что все тайны Delphi достанутся вам на блюдечке в
виде help-файла!
Тригонометрические функции и процедуры
ArcCos - Арккосинус
ArcCosh - Пиперболический арккосинус
ArcSIn - Арксинус
ArcSInh - Гиперболический арксинус
ArcTahn - Гиперболический арктангенс
ArcTan2 - Арктангенс с учетом квадранта (функция ArcTan,
не учитывающая квадрант, находится в модуле System)
Cosh - Гиперболический косинус
Cotan - Котангенс
CycleToRad - Преобразование циклов в радианы
DegToRad - Преобразование градусов в радианы
GradToRad - Преобразование градов в радианы
Hypot - Вычисление гипотенузы прямоугольного
треугольника по длинам катетов
RadToCycle - Преобразование радианов в циклы
RadToDeg - Преобразование радианов в градусы
RacIToGrad - Преобразование радианов в грады
SinCos - Вычисление синуса и косинуса угла. Как и в
случае SumAndSquares и MeanAndStdDev, одновременная генерация
обеих величин происходит быстрее
Sinh - Гиперболический синус
Tan - Тангенс
Tanh - Гиперболический тангенс
Арифметические функции и процедуры
Cell - Округление вверх
Floor - Округление вниз
Frexp - Вычисление мантиссы и порядка заданной
величины
IntPower - Возведение числа в целую степень. Если вы
не собираетесь пользоваться экспонентами с
плавающей точкой, желательно использовать эту
функцию из-за ее скорости
Ldexp - Умножение Х на 2 в заданной степени
LnXPI - Вычисление натурального логарифма Х+1.
Рекомендуется для X, близких к нулю
LogN - Вычисление логарифма Х по основанию N
LogIO - Вычисление десятичного логарифмах
Log2 - Вычисление двоичного логарифмах
Power - Возведение числа в степень. Работает
медленнее IntPower, но для операций с плавающей
точкой вполне приемлемо
Финансовые функции и процедуры
DoubleDecliningBalance - Вычисление амортизации методом
двойного баланса
FutureValue - Будущее значение вложения
InterestPayment - Вычисление процентов по ссуде
InterestRate - Норма прибыли, необходимая для получения
заданной суммы
InternalRateOfReturn - Вычисление внутренней скорости
оборота вложения для ряда последовательных
выплат
NetPresentValue - Вычисление чистой текущей стоимости
вложения для ряда последовательных выплат с
учетом процентной ставки
NumberOf Periods - Количество периодов, за которое
вложение достигнет заданной величины
Payment - Размер периодической выплаты, необходимой
для погашения ссуды, при заданном числе периодов,
процентной ставке, а также текущем и будущем
значениях ссуды
PerlodPayment - Платежи по процентам за заданный период
PresentValue - Текущее значение вложения
SLNDepreclatlon - Вычисление амортизации методом
постоянной нормы
SYDepreclatlon - Вычисление амортизации методом весовых
коэффициентов
Статистические функции и процедуры
MaxIntValue - Максимальное значение в наборе целых
чисел. Функция появилась в Delphi 3. ее не существует
в Delphi 2
MaxValue - Максимальное значение в наборе чисел. В Delphi
2 функция возвращает минималъное значение
Mean - Среднее арифметическое для набора чисел
MeanAndStdDev - Одновременное вычисление среднего
арифметического и стандартного отклонения для
набора чисел. Вычисляется быстрее, чем обе
величины по отдельности
MinIntValLie - Минимальное значение в наборе целых
чисел. Функция появилась в Delphi 3, ее не существует
в Delphi 2
MInValue - Минимальное значение в наборе чисел. В Delphi 2
функция возвращает максимальное значение
MoiiientSkewKurtosIs - Статистические моменты порядков с
первого по четвертый, а также асимметрия (skew) и
эксцесс (kurtosis) для набора чисел
Norm - Норма для набора данных (квадратный корень из
суммы квадратов)
PopnStdDev - Выборочное стандартное отклонение.
Отличается от обычного стандартного отклонения
тем, что при вычислениях используется выборочное
значение дисперсии, PopnVarl апсе (см. ниже)
PopnVarlance - Выборочная дисперсия. Использует
"смещенную" формулу TotalVanance/n
RandG - Генерация нормально распределенных
случайных чисел с заданным средним значением и
среднеквадратическим отклонением
StdDev - Среднеквадратическое отклонение для набора
чисел
Sum - Сумма набора чисел
SLimsAndSquares - Одновременное вычисление суммы и суммы
квадратов для набора чисел. Как и в других
функциях модуля Math, обе величины вычисляются
быстрее, чем по отдельности
Sumint - Сумма набора целых чисел. Функция появилась
в Delphi 3, ее не существует в Delphi 2
SLimOfSquares - Сумма квадратов набора чисел
Total Variance - "Полная дисперсия" для набора
чисел. Это сумма квадратов расстояний всех
величин от их среднего арифметического
Variance - Выборочная дисперсия для набора чисел.
Функция использует "несмещенную" формулу
TotalVanапсе/ (п -1)
Глюки TImage
Глюки QReport
function SetDefPrn(const stDriver : string) : boolean; begin SetPrinter(nil).Free; Result := WriteProfileString('windows', device', PChar( stDriver)); end;
После печати восстановите установки.
По-видимому, надо добавить строк в конец, изменив
Grid.RowCount, а потом раздвинуть строки циклом снизу
вверх:
Grid.Rows.Strings[i] := Grid.Rows.Strings[i - 1];
Или я бы сделал метод рисования этой таблицы, а
данные хранил бы в отдельном stringList-е, там есть
методы вставки, а вообще-то для этих целей
предпочитаю DrawGrid: переопределяю метод onDrawCell, всё
же объектная модель лучше и данные проще
контролировать.
У меня такая проблема: я пишу компонент, который внутри себя создаёт другой компонент. Конструктор первого компонента выглядит примерно так:
constructor TFirstComp.Create(AOwner:TComponent); begin inherited Create(AOwner); SecondComp:=TSecondComp.Create(Owner) end;
Проблема заключается в том, что при
помещении первого компонента на форму в dfm-файл
записывается информация и о втором компоненте
тоже. А в pas-файл - только о первом. Это приводит к
конфликтам. Для меня принципиально, чтобы хозяин
у второго компонента был тот же, что и у первого.
Как не дать Delphi поместить запись о TSecondComp в
dfm-файл?
Попробуйте сделать так:
constructor TFirstComp.Create(AOwner:TComponent); begin inherited Create(AOwner); SecondComp:=TSecondComp.Create(SELF); end;
Т.е. дочернему компоненту в качастве
владельца передавайте его непосредственного
хозяина.
Посмотрите компонент RichEdit98 (полностью бесплатный). ftp://ftp.bcsmi.minsk.by/alex/
Я думаю, пример красноречивее пяти листов словоблудия ...
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, ComCtrls, ExtCtrls, OleCtnrs; type TForm1 = class(TForm) OleContainer1: TOleContainer; Panel1: TPanel; StatusBar1: TStatusBar; mbLoad: TSpeedButton; mbPrint: TSpeedButton; OpenDialog1: TOpenDialog; procedure mbLoadClick(Sender: TObject); procedure mbPrintClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.mbLoadClick(Sender: TObject); begin // Покажем диалог, и если он отработал, то загрузим в контейнер if OpenDialog1.Execute and (OpenDialog1.FileName<>'') then OleContainer1.CreateObjectFromFile(OpenDialog1.FileName,false); // Если загрузилось что-нибудь, то покажем if OleContainer1.State <> osEmpty then OleContainer1.DoVerb(ovShow); end; procedure TForm1.mbPrintClick(Sender: TObject); var V : Variant; begin if OleContainer1.State = osEmpty then Begin MessageDlg('OLE не загружен !!', mtError, [mbOk],0); exit; end; // Получаем объект, который воплощает в себе WordBasic интерфейс V := OleContainer1.OleObject.Application.WordBasic; // Командуем до одурения .... V.FilePrint; end; end.