Кнопка с несколькими строчками текста III
Вот полный код проекта, создающего на кнопке во время выполнения две строчки текста.
Файл TWOLNBTN.DPR
|
program TwolnBtn;
uses Forms, TwolnBtu in 'TWOLNBTU.PAS' {Form1}; {$R *.RES} begin Application.CreateForm(TForm1, Form1); Application.Run; end. |
Файл TWOLNBTU.TXT => TWOLNBTU.DFM
| object Form1: TForm1 Left = 202 Top = 98 Width = 320 Height = 176 Caption = 'Form1' Font.Color = clRed Font.Height = -12 Font.Name = 'Arial' Font.Style = [fsBold] PixelsPerInch = 96 OnActivate = ChgSpeedButton OnCreate = ChgBitBtn TextHeight = 15 object SpeedButton1: TSpeedButton Left = 144 Top = 24 Width = 65 Height = 45 Caption = 'Это двустрочный заголовок' OnClick = ChgSpeedButton end object BitBtn1: TBitBtn Left = 32 Top = 24 Width = 69 Height = 37 Caption = 'Прерывание работы программы' TabOrder = 0 OnClick = BitBtn1Click end end |
Файл TWOLNBTU.PAS
|
unit Twolnbtu;
interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons; type TForm1 = class(TForm) BitBtn1: TBitBtn; SpeedButton1: TSpeedButton; procedure ChgBitBtn(Sender: TObject); procedure ChgSpeedButton(Sender: TObject); procedure BitBtn1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.ChgBitBtn(Sender: TObject); VAR R : TRect; N : Integer; Buff : ARRAY[0..255] OF Char; BEGIN WITH BitBtn1 DO BEGIN Glyph.Canvas.Font := Self.Font; Glyph.Width := Width-6; Glyph.Height := Height-6; R := Bounds(0,0,Glyph.Width,0); StrPCopy(Buff, Caption); Caption := ''; DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK OR DT_CALCRECT); OffsetRect(R, (Glyph.Width-R.Right) DIV 2, (Glyph.Height - R.Bottom) DIV 2); DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK); END; END; procedure TForm1.ChgSpeedButton(Sender: TObject); VAR R : TRect; N : Integer; Buff : ARRAY[0..255] OF Char; BEGIN WITH SpeedButton1 DO BEGIN Glyph.Canvas.Font := Self.Font; Glyph.Width := Width-6; Glyph.Height := Height-6; R := Bounds(0,0,Glyph.Width,0); StrPCopy(Buff, Caption); Caption := ''; DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK OR DT_CALCRECT); OffsetRect(R, (Glyph.Width-R.Right) DIV 2, (Glyph.Height - R.Bottom) DIV 2); DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK); END; END; procedure TForm1.BitBtn1Click(Sender: TObject); begin Close; end; end. |
-Dennis Passmore [001062]
Мутация кнопок
Для цветных кнопок есть простое решение: используйте TBitBtn. Если не хотите, не используйте изображение на кнопке, но свойство Font.Color даст нужный эффект. Если же на вашей форме уже расположены стандартные кнопки, вы легко можете изменить их на TBitBtns, следуя этим шагам: Щелкните на кнопке в дизайнере форм Нажмите Ctrl+X для перемещения ее в буфер обмена Переключитесь в редактор и переместитесь к заключительному "end." Нажмите Ctrl+V для вставки копии текста кнопки Измените тип в первой строке с TButton на TBitBtn Выделите скопированный текст кнопки и переместите его в буфер обмена Вставьте его снова в дизайнер форм. [000390]
Смена цветов иконки в кнопке BitBtn
Лучшим решением было бы создание более чем одной иконки в кнопке, и, если вы согласны на это, попробуйте загрузить в редакторе более чем одну иконку из набора предустановленных, и посмотрите, как это может быть сделано...
Я же полагаю, что у вас есть все же TBitmap, который вы динамически подгружаете во время выполнения приложения. Чтобы сгенерировать "погашенную (выключенную)" иконку, можно покрасить в черный цвет каждый "шахматностоящий" пиксель, чтобы в итоге у вас получилась иконка наподобие шахматной доски. Я предполагаю, что таким же способом действует и 95 в момент появления диалога о завершении работы системы. Чтобы сделать из вашей иконки ее "выключенное" состояние, воспользуйтесь следующим кодом:
| BitBtn1.Glyph.Canvas.Pixels[0,0] := clBlack; |
и в цикле:
|
for i := 1 to BitBtn1.Height do for j := 1 to BitBtn1.Width do begin if (Trunc(j/2)*2) = j then BitBtn1.Glyph.Canvas.Pixels[j, Trunc(Frac(i/2)*2)] := clBlack; end; |
[001936]
Смена иконки BitBtn во время работы приложения
Иконка компонента является инкапсулированным объектом, требующим для хранения изображения некоторый участок памяти. Следовательно, при замене иконки, память, связанная с первоначальной иконкой, должна возвратиться в кучу, а для новой иконки требуется новое распределение памяти. По правилам Delphi, этим должен заниматься метод "Assign". Ниже приведен код всей процедуры замены иконки.
|
implementation {$R *.DFM} var n: integer; // При инициализации программы данное значение будет равным нулю procedure TForm1.Button1Click(Sender: TObject); var Image: TBitmap; begin // Изменение иконки в BitBtn1 Image:= TBitmap.Create; if n < ImageList1.Count then ImageList1.GetBitmap(n, Image); {end if} BitBtn1.Glyph.Assign(Image) // Примечание: Для изменения свойств объекта используется метод Assign inc(n,2); // В данный момент кнопка содержит две иконки! if n > ImageList1.Count then n:= 0; {end if} Image.Free; end; procedure TForm1.Button2Click(Sender: TObject); begin // добавляем новую иконку кнопки в список ImageList1 if OpenDialog1.Execute then ImageList1.FileLoad(rtBitMap,OpenDialog1.FileName,clBtnFace); label1.Caption:= 'Количество иконок = ' + IntToStr(ImageList1.Count); end; |
Удаление TBitmap из BitBtn
Попробуйте следующее:
| Glyph.free; Glyph := nil; |
На этом этапе, вероятно, вы захотите избавиться от самого изображения. Попытайтесь теперь сделать это сами. [001942]
Цветная кнопка
VS пишет:
В книгах Калверта, Свана и других авторов можно найти похожий текст. Смысл текста – "Изменить цвет кнопок Button, BitBtn нельзя, т.к. их рисует WINDOWS". Если нельзя, но ОЧЕНЬ НУЖНО, то можно.
Небольшой компонент ColorBtn, дает возможность использовать в кнопках цвет. Кроме того, представлено новое свойство - Frame3D, позволяющее получить более реалистичный вид нажатой кнопки. В отличие от API, при изменении значения свойства Frame3D, не требуется переоткрытие компонента.
Примечание. Кнопку по-прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Чаще заглядывайте в VCL - можно найти много интересного. На рисунке представлены ColorButton и ColorBitBtn.
|
unit colorbtn; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons; type TColorBtn = class(TButton) private FCanvas: TCanvas; IsFocused: Boolean; F3DFrame: boolean; FButtonColor: TColor; procedure Set3DFrame(Value: boolean); procedure SetButtonColor(Value: TColor); procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure DrawButtonText(const Caption: string; TRC: TRect; State: TButtonState; BiDiFlags: Longint); procedure CalcuateTextPosition(const Caption: string; var TRC: TRect; BiDiFlags: Longint); protected procedure CreateParams(var Params: TCreateParams); override; procedure SetButtonStyle(ADefault: Boolean); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property ButtonColor: TColor read FButtonColor write SetButtonColor default clBtnFace; property Frame3D: boolean read F3DFrame write Set3DFrame default False; end; procedure Register; implementation { TColorBtn } constructor TColorBtn.Create(AOwner: TComponent); begin Inherited Create(AOwner); Height:= 21; FCanvas:= TCanvas.Create; FButtonColor:= clBtnFace; F3DFrame:= False; end; destructor TColorBtn.Destroy; begin FCanvas.Free; Inherited Destroy; end; procedure TColorBtn.CreateParams(var Params: TCreateParams); begin Inherited CreateParams(Params); with Params do Style:= Style or BS_OWNERDRAW; end; procedure TColorBtn.Set3DFrame(Value: boolean); begin if F3DFrame <> Value then F3DFrame:= Value; end; procedure TColorBtn.SetButtonColor(Value: TColor); begin if FButtonColor <> Value then begin FButtonColor:= Value; Invalidate; end; end; procedure TColorBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk); begin Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos)); end; procedure TColorBtn.SetButtonStyle(ADefault: Boolean); begin if IsFocused <> ADefault then IsFocused:= ADefault; end; procedure TColorBtn.CNDrawItem(var Message: TWMDrawItem); var RC: TRect; Flags: Longint; State: TButtonState; IsDown, IsDefault: Boolean; DrawItemStruct: TDrawItemStruct; begin DrawItemStruct:= Message.DrawItemStruct^; FCanvas.Handle:= DrawItemStruct.HDC; RC:= ClientRect; with DrawItemStruct do begin IsDown:= ItemState and ODS_SELECTED <> 0; IsDefault:= ItemState and ODS_FOCUS <> 0; if not Enabled then State:= bsDisabled else if IsDown then State:= bsDown else State:= bsUp; end; Flags:= DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; if IsDown then Flags:= Flags or DFCS_PUSHED; if DrawItemStruct.ItemState and ODS_DISABLED <> 0 then Flags:= Flags or DFCS_INACTIVE; if IsFocused or IsDefault then begin FCanvas.Pen.Color:= clWindowFrame; FCanvas.Pen.Width:= 1; FCanvas.Brush.Style:= bsClear; FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom); InflateRect(RC, -1, -1); end; if IsDown then begin FCanvas.Pen.Color:= clBtnShadow; FCanvas.Pen.Width:= 1; FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom); InflateRect(RC, -1, -1); if F3DFrame then begin FCanvas.Pen.Color:= FButtonColor; FCanvas.Pen.Width:= 1; DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags); end; end else DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags); FCanvas.Brush.Color:= FButtonColor; FCanvas.FillRect(RC); InflateRect(RC, 1, 1); if IsFocused then begin RC:= ClientRect; InflateRect(RC, -1, -1); end; FCanvas.Font:= Self.Font; if IsDown then OffsetRect(RC, 1, 1); DrawButtonText(Caption, RC, State, 0); if IsFocused and IsDefault then begin RC:= ClientRect; InflateRect(RC, -4, -4); FCanvas.Pen.Color:= clWindowFrame; Windows.DrawFocusRect(FCanvas.Handle, RC); end; FCanvas.Handle:= 0; end; procedure TColorBtn.CalcuateTextPosition(const Caption: string; var TRC: TRect; BiDiFlags: Integer); var TB: TRect; TS, TP: TPoint; begin with FCanvas do begin TB:= Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom); DrawText(Handle, PChar(Caption), Length(Caption), TB, DT_CALCRECT or BiDiFlags); TS:= Point(TB.Right - TB.Left, TB.Bottom - TB.Top); TP.X:= ((TRC.Right - TRC.Left) - TS.X + 1) div 2; TP.Y:= ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2; OffsetRect(TB, TP.X + TRC.Left, TP.Y + TRC.Top); TRC:= TB; end; end; procedure TColorBtn.DrawButtonText(const Caption: string; TRC: TRect; State: TButtonState; BiDiFlags: Integer); begin with FCanvas do begin CalcuateTextPosition(Caption, TRC, BiDiFlags); Brush.Style:= bsClear; if State = bsDisabled then begin OffsetRect(TRC, 1, 1); Font.Color:= clBtnHighlight; DrawText(Handle, PChar(Caption), Length(Caption), TRC, DT_CENTER or DT_VCENTER or BiDiFlags); OffsetRect(TRC, -1, -1); Font.Color:= clBtnShadow; DrawText(Handle, PChar(Caption), Length(Caption), TRC, DT_CENTER or DT_VCENTER or BiDiFlags); end else DrawText(Handle, PChar(Caption), Length(Caption), TRC, DT_CENTER or DT_VCENTER or BiDiFlags); end; end; procedure Register; begin RegisterComponents('Controls', [TColorBtn]); end; end. |
Небольшое дополнение. Кнопку по прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Хочется повторить слова Калверта – "Пользуйтесь исходным кодом". Чаще заглядывайте в VCL - можно найти много интересного. [001324]
Нажатие кнопки
Я знаю как нажать кнопку через keypress, но хотя пользователь определил действие в обработчике события OnClick, сама кнопка не отражает видимых изменений, происходящих при ее нажатии мышью. Кто-нибудь может мне помочь?
Вы можете сделать кнопку "нажатой" или "ненажатой", посылая ей сообщение BM_SETSTATE. Определить ее текущее состояние можно, послав ей сообщение BM_GETSTATE.
Для нажатия кнопки:
| Button1.Perform( BM_SETSTATE, 1, 0 ); |
Для отжатия кнопки:
| Button1.Perform( BM_SETSTATE, 0, 0 ); |
Чтобы обнаружить нажатие кнопки:
| ButtonPressed := Button1.Perform( BM_GETSTATE, 0, 0 ) = 1; |
- Ed Jordan [000996]
Обработка щелчка нескольких кнопок, используя их заголовок
...с ваших слов я понял, что вы все уже реализовали, но давайте все повторим: вы должны убедиться в том, что событие OnClick привязано к каждой кнопке калькулятора (числовые кнопки 0..9) и указывают на общий обработчик события.
В разделяемом обработчике события получите заголовок обрабатываемой кнопки следующим образом:
| Edit1.Text := TButton(Sender).Caption; |
...я думаю в этом случае самым разумным будет использование свойства Tag каждой кнопки: назначьте уникальный Tag для каждой кнопки (например, эквивалент арабским цифрам)
|
procedure TForm1.Button1Click(Sender: TObject); begin if (Sender is TButton) then with (Sender as TButton) do {используем Tag} end; |
Если вам нужен только заголовок, то есть изящный способ получить к нему доступ. Подключите общий обработчик события для всех кнопок и используйте приведение типа как показано ниже:
|
procedure TForm1.Edit1Click(Sender: TObject); begin edit1.text := (sender as TButton).caption ; end; |
Приведенная ниже конструкция будет недостаточной:
| sender.caption |
поскольку компилятор не знает о том, имеет ли "sender" свойство caption, или нет. [001523]
Вызов Delphi DLL из MS Visual C++
Во-первых, Вам необходимо объявить все экспортируемые в Delphi DLL функции с ключевыми словами export; stdcall;
Во-вторых, файл заголовка VC++ должен объявить все функции как тип __declspec(dllexport) __stdcall (применяйте двойное подчеркивание в секции объявления прототипа функции extern "C" { ... }. (вместо этого можно также использовать __declspec(dllimport)...). Для примера:
|
extern "C" { int __declspec(dllexport) __stdcall plusone(int); } |
В-третьих, в VC++ компилятор настраивается на "украшающее" имена функций __stcall, так что Ваша Delphi DLL соответственно должна экспортировать эти функции. Для этого необходимо модифицировать файл Delphi 2.0 .DPR для Вашего DLL, модифицируя имена всех функций, прописанных в разделе экспорта. Для примера, если Вы экспортируете функцию function plusone (intval : Integer), Вам необходимо включить следующую строку в раздел экспорта .DPR-файла:
| plusone name 'plusone@4' |
Число, следующее за символом @, является общей длиной в байтах всех функциональных аргументов. Самый простой путь для обнаружения неправильных значений - попытаться слинковать Вашу VC++ программу и посмотреть на наличие возможной ошибки компоновщика "unresolved external".
И, наконец, Вы можете легко создать библиотеку импорта, используя утилиту LIB из поставки VC++. Для этого необходимо вручную (!!) создать .DEF-файл для Вашей DLL с секцией экспорта, перечисляющей имена и/или порядковые номера всех экспортируемых DLL функций. Формат .DEF-файла очень прост:
|
library MYLIB description 'Моя собственная DLL' exports plusone@4 |
Затем запускаете LIB из командной строки DOS/Win95, и в качестве параметра подставляете имя .DEF-файла. Например, LIB /DEF:MYDLL.DEF. Наконец, через диалог Build|Settings|Linker Вы информируете VC++ о полученном .LIB-файле.
Вот пример кода:
*******MYDLLMU.PAS
|
unit MyDLLMU; interface function plusone(val : Integer) : Integer; export; stdcall; procedure ChangeString(AString : PChar); export; stdcall; implementation uses Dialogs, SysUtils; function plusone(val : Integer) : Integer; begin Result := val + 1; end; procedure ChangeString(AString : PChar); begin if AString = 'Здравствуй' then StrPCopy(AString, 'Мир'); end; end. |
***********MYDLL.DPR
|
library mydll; { Существенное замечание об управлении памятью в DLL: Если DLL экспортирует функции со строковыми параметрами или возвращающие строковые значения, модуль ShareMem надо указывать в разделе Uses библиотеки и проекта первым. Это касается любых строк, передаваемых как в DLL, так и из нее, даже если они размещаются внутри записей или объектов. Модуль ShareMem служит интерфейсом менеджера разделяемой памяти DELPHIMM.DLL, который должен разворачиваться одновременно с данной DLL. Чтобы избежать применения DELPHIMM.DLL, строковую информацию можно передавать с помощью параметров типа PChar или ShortString. } uses SysUtils, Classes, MyDLLMU in 'MyDLLMU.pas'; exports plusone name 'plusone@4', ChangeString name 'ChangeString@4'; begin end. |
*************** MYDLL.DEF
; -----------------------------------------------------------------
; Имя файла: MYDLL.DEF
; -----------------------------------------------------------------
|
LIBRARY MYDLL DESCRIPTION 'Тестовая Delphi DLL, статическая загрузка в VC++ приложение' EXPORTS plusone@4 |
************** DLLTSTADlg.H
|
// DLLTSTADlg.h : заголовочный файл // #define USELIB #ifdef USELIB extern "C" { int __declspec(dllimport) __stdcall plusone(int); } #endif //USELIB ///////////////////////////////////////////////////////////////////////////// // Диалог CDLLTSTADlg class CDLLTSTADlg : public CDialog { // Создание public: CDLLTSTADlg(CWnd* pParent = NULL); // стандартный конструктор ~CDLLTSTADlg(); // Данные диалога //{{AFX_DATA(CDLLTSTADlg) enum { IDD = IDD_DLLTSTA_DIALOG }; CString m_sVal; CString m_sStr; //}}AFX_DATA // Перекрытая виртуальная функция, сгенерированная ClassWizard //{{AFX_VIRTUAL(CDLLTSTADlg) protected: virtual void DoDataExchange(CDataExchange* pDX); // Поддержка DDX/DDV //}}AFX_VIRTUAL // Реализация protected: #ifndef USELIB HINSTANCE hMyDLL; FARPROC lpfnplusone; typedef int (*pIIFUNC)(int); pIIFUNC plusone; #endif //USELIB HICON m_hIcon; // Карта функций генераций сообщений //{{AFX_MSG(CDLLTSTADlg) virtual BOOL OnInitDialog(); afx_msg void OnPaint(); afx_msg HCURSOR OnQueryDragIcon(); afx_msg void OnBtnplusone(); afx_msg void OnBtnplusoneClick(); afx_msg void OnBtndostringClick(); //}}AFX_MSG DECLARE_MESSAGE_MAP() }; |
************ DLLTSTADlg.CPP
|
// DLLTSTADlg.cpp : файл реализации // #include "stdafx.h" #include "DLLTSTA.h" #include "DLLTSTADlg.h" #ifdef _DEBUG #define new DEBUG_NEW #undef THIS_FILE static char THIS_FILE[] = __FILE__; #endif extern CDLLTSTAApp theApp; ///////////////////////////////////////////////////////////////////////////// // Диалог CDLLTSTADlg CDLLTSTADlg::CDLLTSTADlg(CWnd* pParent /*=NULL*/) : CDialog(CDLLTSTADlg::IDD, pParent) { //{{AFX_DATA_INIT(CDLLTSTADlg) m_sVal = _T("1"); m_sStr = _T("Hello"); //}}AFX_DATA_INIT // Имейте в виду, что в Win32 LoadIcon не требует последующего DestroyIcon m_hIcon = AfxGetApp()->LoadIcon(IDR_MAINFRAME); #ifndef USELIB hMyDLL = LoadLibrary("C:\\delpwork\\MYDLL.DLL"); if(hMyDLL == NULL) PostQuitMessage(1); lpfnplusone = GetProcAddress(HMODULE(hMyDLL), "_plusone"); if(lpfnplusone == NULL) PostQuitMessage(2); plusone = pIIFUNC(lpfnplusone); #endif //USELIB } CDLLTSTADlg::~CDLLTSTADlg() { #ifndef USELIB if (hMyDLL != NULL) FreeLibrary(hMyDLL); #endif //USELIB } void CDLLTSTADlg::DoDataExchange(CDataExchange* pDX) { CDialog::DoDataExchange(pDX); //{{AFX_DATA_MAP(CDLLTSTADlg) DDX_Text(pDX, IDC_LBLINT, m_sVal); DDX_Text(pDX, IDC_LBLSTRING, m_sStr); //}}AFX_DATA_MAP } BEGIN_MESSAGE_MAP(CDLLTSTADlg, CDialog) //{{AFX_MSG_MAP(CDLLTSTADlg) ON_WM_PAINT() ON_WM_QUERYDRAGICON() ON_BN_CLICKED(IDC_BTNPLUSONE, OnBtnplusoneClick) ON_BN_CLICKED(IDC_BTNDOSTRING, OnBtndostringClick) //}}AFX_MSG_MAP END_MESSAGE_MAP() ///////////////////////////////////////////////////////////////////////////// // Дескрипторы сообщений CDLLTSTADlg BOOL CDLLTSTADlg::OnInitDialog() { CDialog::OnInitDialog(); // Устанавливаем иконку для данного диалога. В случае, когда главное // окно программы не является диалогом, это происходит автоматически SetIcon(m_hIcon, TRUE); // Устанавливаем большую иконку SetIcon(m_hIcon, FALSE); // Устанавливаем маленькую иконку // TODO: Здесь добавляем дополнительную инициализацию return TRUE; // возвращает TRUE в случае отсутствия фокуса у диалога } // Если Вы добавляете в диалог кнопку минимизации, для создания иконки Вам // необходим код, приведенный ниже. Для MFC-приложений используйте // document/view model для автоматического создания скелета кода. void CDLLTSTADlg::OnPaint() { if (IsIconic()) { CPaintDC dc(this); // контекст устройства для рисования SendMessage(WM_ICONERASEBKGND, (WPARAM) dc.GetSafeHdc(), 0); // Центр иконки в области клиента int cxIcon = GetSystemMetrics(SM_CXICON); int cyIcon = GetSystemMetrics(SM_CYICON); CRect rect; GetClientRect(&rect); int x = (rect.Width() - cxIcon + 1) / 2; int y = (rect.Height() - cyIcon + 1) / 2; // Рисование иконки dc.DrawIcon(x, y, m_hIcon); } else { CDialog::OnPaint(); } } // Система вызывает данный код для получения курсора, выводимого если // пользователь пытается перетащить свернутое окно. HCURSOR CDLLTSTADlg::OnQueryDragIcon() { return (HCURSOR) m_hIcon; } void CDLLTSTADlg::OnBtnplusoneClick() { int iTemp; char sTemp[10]; iTemp = atoi(m_sVal); iTemp = plusone(iTemp); m_sVal = itoa(iTemp, sTemp, 10); UpdateData(FALSE); } void CDLLTSTADlg::OnBtndostringClick() { UpdateData(FALSE); } |
[000075]
Вызов Delphi DLL из MS Visual C++ II
Во-первых, создайте в Delphi простую DLL:
|
{ Начало кода DLL } Library MinMax; Function Min(X, Y: Integer): Integer; export; begin if X < Y then Min := X else Min := Y; end; Function Max(X, Y: Integer): Integer; export; begin if X > Y then Max := X else Max := Y; end; Exports Min index 1, Max index 2; begin end. { Конец кода DLL } |
Затем, для вызова этих функций из вашего C кода, сделайте следующее: В вашем .DEF-файле добавьте следующие строки:
| IMPORTS Min =MINMAX.Min Max =MINMAX.Max |
Объявите в вашем C-приложени прототип функций, как показано ниже: int FAR PASCAL Min(int x, y); int FAR PASCAL Min(int x, y); Теперь из любого места вашего приложения вы можете вызвать функции Min и Max. [001648]
Функция вычисления суммы полей
|
function SumField(const fieldName : OpenString) : longint; var fld : TField; bm : TBookmark; // закладка begin result := 0; tbl.DisableControls; // выключаем рекцию на перемещение по набору данных bm := tbl.GetBookmark; // сохраняем позицию fld := tbl.FieldByName(fieldName); tbl.first; while not tbl.eof do begin result := result + fld.AsInteger; tbl.next; end; tbl.GotoBookmark(bm); // позиционируем обратно tbl.EnableControls; // включаем реакцию на перемещение по набору данных end; |
Спасибо Alexsander за ценное замечание [000542]
Хитрость OnCalcFields
Событие OncalcFields генерится ОЧЕНЬ часто и может быть необязательным и занимать большое количество времени, например, у вас есть таблица с неким вычисляемым полем, и при каждом редактировании таблицы вызывается следующий код:
| MyCalcField.AsInteger := Table1Field1.AsInteger + 10; |
Теперь, если Вы решили пройти последовательно каждую запись огромной таблицы, вы можете представить, какое количество таких событий будет сгенерировано! Они будут необязательны в случае, если вы сделаете обработку полей в отдельной процедуре.
Мой совет следующий: выключите генерацию события OnCalcFields, обработайте все поля и снова включите генерацию данного события, к примеру так:
|
Procedure TForm1.BigProcessingFunction; begin Table1.OnCalcFields := nil; <Включите любые по сложности вычисления в этом месте!> Table1.OnCalcFields := Table1OnCalcFields; end; |
Поля не вычисляются в течение времени обработки, которое может быть достаточно велико, но при наличие громоздких вычислений специфического поля (или даже нескольких полей), все вычисляется за один проход!
Данный метод позволяет исключить необязательный код и может быть использован повсюду, где применяются большие таблицы или сложный алгоритм калькуляции поля. Разница в скорости обработки таблицы довольно ощутима. [000031]
Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?
Nomadic отвечает:
| Resync( [rmExact, rmCenter] ); |
[001369]
Как создать вычисляемые поля во время исполнения программы (Calculated fields at RunTime)?
Nomadic отвечает:
Смотрите книгу "Developing Custom Delphi Components" от Рэя Конопки.
Здесь немного исправленный пример из этой книги -
|
function TMyClass.CreateCalcField( const AFieldName: string; AFieldClass: TFieldClass; ASize: Word ): TField; begin Result := FDataSet.FindField( AFieldName ); // Field may already exists! if Result<>nil then Exit; if AFieldClass = nil then begin DBErrorFmt( SUnknownFieldType, [AFieldName] ); end; Result := FieldClass.Create( Owner ); with Result do try FieldName := AFieldName; if ( Result is TStringField ) or ( Result is TBCDField ) or ( Result is TBlobField ) or ( Result is TBytesField ) or ( Result is TVarBytesField ) then begin Size := ASize; end; Calculated := True; DataSet := FDataset; Name := FDataSet.Name + AFieldName; except Free; // We must release allocated memory on error! raise; end; end; |
[001385]
Код определения возраста
Вызовите диалог редактирования полей (Fields Editor), дважды щелкнув на компоненте TTable или TQuery, расположенном на вашей форме (или выбрав в контекстном меню пункт Fields Editor). Добавьте все поля, с которыми вы хотите работать в форме (даже если вы хотите, чтобы они были невидимы, но вам необходим к ним доступ -- для таких полей установите свойство visible в false). Затем щелкните на "Define..." (определить) для добавления вычисляемого поля. Введите имя вычисляемого поля, отличающееся от имен других полей таблицы, выберите тип (вероятно, StringField) и задайте длину (20 будет в самый раз). Убедитесь в том, что напротив поля 'calculated' стоит галочка. Затем создайте для вашего объекта TTable или TQuery обработчик события 'OnCalcFields'. В этом обработчике вы берете значения реальных полей таблицы, делаете вычисления, и помещаете результаты в объект вычисляемого поля, который вы только что создали. После этого значение выводится в TDBGrid, или в элементе управления TDBText, если вы решили использовать форму вместо табличной сетки.
Наша функция должна достичь цели, обрабатывая значения лет и месяцев. Поскольку не все месяцы имеют одно и то же количество дней, я просто брал среднее число, поэтому результат может быть не очень точен, но большинство людей это удовлетворяет:
|
function AgeStr(aDate: TDateTime): string; var DaysOld : Double; Years, Months : Integer; begin DaysOld := Date - aDate; Years := Trunc(DaysOld / 365.25); DaysOld := DaysOld - (365.25 * Years); Months := Trunc(DaysOld / 30.41); Result := Format('%d лет, %d месяцев',[Years, Months]); end; |
В моем случае метод OnCalcFields выглядит так:
|
procedure TEntryForm.TableNameOrderCalcFields(DataSet: TDataset); begin TableNameOrderAge.AsString := AgeStr(TableNameOrderDateOfBirth.AsDateTime); end; |
[001227]
Вычисление суммы полей
Создайте TQuery с SQL запросом подобно этому:
Select Sum(Field) From "Table.dbf"
Дважды щелкните на TQuery и в открывшемся редакторе полей выберите "Add" (добавить). В нашем случае это будет SumOfField. Затем в обработчике события OnCalcFields сошлитесь на Query1SumOfField (например, Table1TotalSalary.Value := Query1SumOfField.AsInteger ;). [000451]
Эмулятор плавающей точки
Имеется ошибка при системной эмуляции плавающей точки - квадратный корень отрицательного числа вычисляется неправильно и не может быть перехвачен. [000335]
Как определить, является ли CD в данном CD-ROM'e Audio-CD?
Олег Кулабухов приводит следующий код:
Ниже приведен пример с использованием TmediaPlayer.
|
function IsAudioCD(Drive : char) : bool; var DrivePath : string; MaximumComponentLength : DWORD; FileSystemFlags : DWORD; VolumeName : string; begin Result := false; DrivePath := Drive + ':\'; if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then exit; SetLength(VolumeName, 64); GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil, MaximumComponentLength, FileSystemFlags, nil, 0); if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then result := true; end; function PlayAudioCD(Drive : char) : bool; var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; if not IsAudioCD(Drive) then exit; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Shareable := true; mp.Open; Application.ProcessMessages; mp.Play; Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin if not PlayAudioCD('D') then ShowMessage('Not an Audio CD'); end; |
[001898]
Как получить серийный номер AudioCD?
Олег Кулабухов приводит следующий код:
|
uses MMSystem, MPlayer; procedure TForm1.Button1Click(Sender: TObject); var mp : TMediaPlayer; msp : TMCI_INFO_PARMS; MediaString : array[0..255] of char; ret : longint; begin mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := 'D:'; mp.Open; Application.ProcessMessages; FillChar(MediaString, sizeof(MediaString), #0); FillChar(msp, sizeof(msp), #0); msp.lpstrReturn := @MediaString; msp.dwRetSize := 255; ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, longint(@msp)); if Ret <> 0 then begin MciGetErrorString(ret, @MediaString, sizeof(MediaString)); Memo1.Lines.Add(StrPas(MediaString)); end else Memo1.Lines.Add(StrPas(MediaString)); mp.Close; Application.ProcessMessages; mp.free; end; end. |
[001840]
Получение идентификатора диска
Как получить идентификатор находящегося в CD-ROM'е аудио-компакта?
|
const MCI_INFO_PRODUCT = $00000100; MCI_INFO_FILE  = $00000200; MCI_INFO_MEDIA_UPC = $00000400; MCI_INFO_MEDIA_IDENTITY = $00000800; MCI_INFO_NAME = $00001000; MCI_INFO_COPYRIGHT = $00002000; { блок параметров для командного сообщения MCI_INFO } type PMCI_Info_ParmsA = ^TMCI_Info_ParmsA; PMCI_Info_ParmsW = ^TMCI_Info_ParmsW; PMCI_Info_Parms = PMCI_Info_ParmsA; TMCI_Info_ParmsA = record dwCallback: DWORD; lpstrReturn: PAnsiChar; dwRetSize: DWORD; end; TMCI_Info_ParmsW = record dwCallback: DWORD; lpstrReturn: PWideChar; dwRetSize: DWORD; end; TMCI_Info_Parms = TMCI_Info_ParmsA; |
Идентификатор возвращается функцией MCI_INFO_MEDIA_IDENTITY в виде строки с десятичным числом. Для получения дополнительной информации обратитесь к электронной справке (Win32 и компонент TMediaPlayer). [000037]
Как программно выдвинуть CD-ROM?
Своим опытом делится Олег Кулабухов:
Вот довольно сложный пример с использованием GetDriveTyoe для определения того, что мы собираемся извлекать.
|
function IsDriveCD(Drive : char) : longbool; var DrivePath : string; begin DrivePath := Drive + ':\'; result := LongBool(GetDriveType(PChar(DrivePath)) and DRIVE_CDROM); end; function EjectCD(Drive : char) : bool; var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; if not IsDriveCD(Drive) then exit; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Open; Application.ProcessMessages; mp.Eject; Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin if not EjectCD('D') then ShowMessage('Not A CD Drive'); end; |
[001891]
Определение устройства CD-ROM
Это должно помочь:
|
function IsCDROM(DriveNum: Integer): Boolean; assembler; asm MOV AX,1500h { смотрим на предмет MSCDEX } XOR BX,BX INT 2fh OR BX,BX JZ @Finish MOV AX,150Bh { проверяем использование CD драйвера } MOV CX,DriveNum INT 2fh OR AX,AX @Finish: end; |
BTW: под Win32 GetDriveType правильно возвращает устройство CD-ROM.
|
Function IsCdRom(DriveNum : Word) : Boolean; Var F : WordBool; Begin asm mov ax, 1500h { тест на наличие MSCDEX } xor bx, bx int 2fh mov ax, bx { если bx = нулю, MSCDEX не присутствует } or ax, ax { возвращаем FALSE } jz @no_mscdex mov ax, 150bh { проверка наличия драйвера MSCDEX } mov cx, DriveNum { cx содержит драйв } int 2fh @no_mscdex: mov f,ax end; Result := F; { Назначаем возвращаемое функцией значение } End; |
[001954]
Открытие и закрытие нескольких приводов CD-ROM
Что касается вопроса "Открытие и закрытие привода CD-ROM", то при наличии более одного CD-ROMа в системе, рекомендую воспользоваться следующими функциями:
|
// ____ _ ______ __ // / __ \_____(_) _____/_ __/___ ____ / /____ // / / / / ___/ / | / / _ \/ / / __ \/ __ \/ / ___/ // / /_/ / / / /| |/ / __/ / / /_/ / /_/ / (__ ) // /_____/_/ /_/ |___/\___/_/ \____/\____/_/____/ // (******************************************************************************* * DriveTools 1.0 * * * * (c) 1999 Jan Peter Stotz * * * ******************************************************************************** * * * If you find bugs, has ideas for missing featurs, feel free to contact me * * jpstotz@gmx.de * * * ******************************************************************************** * Date last modified: May 22, 1999 * *******************************************************************************)
unit DriveTools; interface uses Windows, SysUtils, MMSystem; function CloseCD(Drive : Char) : Boolean; function OpenCD(Drive : Char) : Boolean; implementation function OpenCD(Drive : Char) : Boolean; Var Res : MciError; OpenParm: TMCI_Open_Parms; Flags : DWord; S : String; DeviceID : Word; begin Result:=false; S:=Drive+':'; Flags:=mci_Open_Type or mci_Open_Element; With OpenParm do begin dwCallback := 0; lpstrDeviceType := 'CDAudio'; lpstrElementName := PChar(S); end; Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm)); IF Res<>0 Then exit; DeviceID:=OpenParm.wDeviceID; try Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0); IF Res=0 Then exit;Result:=True; finally mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm)); end; end; function CloseCD(Drive : Char) : Boolean; Var Res : MciError; OpenParm: TMCI_Open_Parms; Flags : DWord; S : String; DeviceID : Word; begin Result:=false; S:=Drive+':'; Flags:=mci_Open_Type or mci_Open_Element; With OpenParm do begin dwCallback := 0; lpstrDeviceType := 'CDAudio'; lpstrElementName := PChar(S); end; Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm)); IF Res<>0 Then exit; DeviceID:=OpenParm.wDeviceID; try Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0); IF Res=0 Then exit; Result:=True; finally mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm)); end; end; end. |
Прислал Vadim Petrov. [001266]
Открытие и закрытие привода CD-ROM
Есть ли Win32 API функция, позволяющая не только открыть НО И ЗАКРЫТЬ CD-ROM? Хотелось бы не тянуться ручками к РС, а нажать мышкой на кнопку. Компонентом TMediaPlayer пользоваться не хочу, тем более компакт он может только извлечь...
Для закрытия CD-ROM:
| mciSendString('Set cdaudio door open wait', nil, 0, handle); |
Для открытия CD-ROM:
| mciSendString('Set cdaudio door closed wait', nil, 0, handle); |
Не забудьте включить MMSystem в список используемых модулей (uses).
[000038]Идентификация CheckBox'ов
В режиме проектирования вы, как программист, без труда узнаете, сколько checkbox'ов содержит ваша форма. А вот когда приложение запущено... Используйте Delphi Run Time Type Information (RTTI). Для нашей испытуемой формы вы можете попробовать следующий код:
|
var i : Integer begin for i := 0 to ComponentCount - 1 do: if Components[i] is TCheckBox then (Components[i] as TCheckBox).Checked then begin ... сюда поместите ваш код ... end; end; |
Кроме того, следующий код Delphi абсолютно корректен:
| if Components[i] = CheckBox5 then Чтотоделаем; |
Также, каждый компонент в Delphi имеет опубликованное (Published) свойство с именем 'Tag', значение которого вы можете задавать во время создания компонента, и затем, во время выполнения приложения, обращаться к нему для получения доступа к компоненту:
|
var i : Integer begin for i := 0 to ComponentCount - 1 do: if Components[i] is TCheckBox then with (Components[i] as TCheckBox) do Case Tag of 1 : if Checked then DoSomethingOnBox1; 2 : if Checked then DoSomethingOnBox2; ... другое ... end; end; |
Для получения дополнительной информации, обратитесь к справке Delphi с ключевым словом "ComponentCount". [001509]
Массив из CheckBox - использование разделяемого обработчика события I
Поместите несколько Checkbox в компонент TGroupBox. Во время прогона (или проектирования) назначьте общий обработчик события Click для всех checkbox'в. Чтобы в цикле обойти все "дочерние" TCheckBox'ы, можно воспользоваться свойством-массивом Controls TGroupBox (и заодно привести их к типу TCheckBox). Приблизительно так:
| for i := 0 to GroupBox1.ControlCount -1 do if (GroupBox1.Controls[i] as TCheckBox).checked then {что-то там еще}; |
Вы можете получить имя sender следующим образом:
|
procedure TMain1.CheckBoxClick(Sender: TObject); var whodidit : string[63]; begin whodidit := TComponent(sender).name; end; |
После приведения типа можно добраться и до других свойств. К примеру, очень полезным может оказаться свойство Tag. Во время создания, вы можете присвоить каждому checkbox.tag свой ID номер. А в обработчике события, читая ID, можно идентифицировать sender. [001476]
|
var CheckArray: array[1..x] of TCheckBox; i:integer; begin for i:=1 to x do begin CheckArray[i]:=TCheckBox.Create(Form1); {Устанавливаем свойства} with CheckBox[i] do begin Left:=i*20; Width:=15; другое... end; end; |
Очевидно, можно сказать:
| Check[i].OnClick:=xyz. |
Пока я и сам не знаю как поступить. Динамическое создание компонентов да, но обработчики событий?
Существует способ организации массива checkbox'ов с разделяемым обработчиком события. Расположите их на форме и дайте им "непрерывные" имена (Check1, Check2 и т.д.). Затем установите у них общий обработчик события. Обработчик события может выглядеть так:
|
procedure TForm.Check1Click(Sender : TObject); var i : Integer; begin for i := 1 to 10 { предположим, что мы имеем 10 checkbox'ов } do With TCheckBox(FindComponent('Check'+IntToStr(i))) do begin { другой какой-то код } end; end; |
[001478]
Cut/Copy/Paste через WinAPI
| SendMessage(GetFocus,WM_CUT,0,0); SendMessage(GetFocus,WM_COPY,0,0); SendMessage(GetFocus,WM_PASTE,0,0); |
Я не проводил тщательного тестирования, но, похоже, это работает со всеми элементами управления - - TEdit, DBGrid и др.
-Peter M. Jagielski [000595]
Форма как графический объект
Каким образом можно скопировать форму в буфер обмена в виде графического изображения?
|
uses clipbrd; procedure TShowVRML.Kopieren1Click(Sender: TObject); var bitmap:tbitmap; begin bitmap:=tbitmap.create; bitmap.width:=clientwidth; bitmap.height:=clientheight; try with bitmap.Canvas do CopyRect (clientrect,canvas,clientrect); clipboard.assign(bitmap); finally bitmap.free; end; end; |
Функции меню Вырезать/Копировать/Вставить
Есть два шага, положенных в основу работы функций cut/copy/paste. Во-первых, вам нужно знать, какие пункты меню "Редактирование" должны быть в данный момент включены. Во-вторых, вам необходимо работать с тем элементом управления, который в данный момент выбран. Вот возможное решение:
|
procedure TForm1.Edit1Click(Sender: TObject); begin IF ActiveControl IS TCustomEdit THEN BEGIN WITH TCustomEdit(ActiveControl) DO BEGIN Cut1.Enabled := SelLength > 0; Copy1.Enabled := SelLength > 0; Paste1.Enabled := ClipBoard.HasFormat(CF_TEXT); END; END ELSE BEGIN Cut1.Enabled := False; Copy1.Enabled := False; Paste1.Enabled := False; END; end; procedure TForm1.Cut1Click(Sender: TObject); begin IF ActiveControl IS TDBEdit THEN WITH TDBEdit(ActiveControl).DataSource.DataSet DO Edit; TCustomEdit(ActiveControl).CutToClipboard; IF ActiveControl IS TDBEdit THEN WITH TDBEdit(ActiveControl).DataSource.DataSet DO Post; end; procedure TForm1.Copy1Click(Sender: TObject); begin TCustomEdit(ActiveControl).CopyToClipboard; end; procedure TForm1.Paste1Click(Sender: TObject); begin IF ActiveControl IS TDBEdit THEN WITH TDBEdit(ActiveControl).DataSource.DataSet DO Edit; TCustomEdit(ActiveControl).PasteFromClipboard; IF ActiveControl IS TDBEdit THEN WITH TDBEdit(ActiveControl).DataSource.DataSet DO Post; end; |
Хорошо? Edit1 - меню редактирования верхнего уровня - если по нему щелкают, то прежде, чем меню "вывалится" вниз, происходит проверка того, принадлежит ли текущий активный элемент управления некоторым типам редактирования. Если это условие выполняется, активизируются пункты меню Вырезать и Копировать, и, если есть текст в буфере обмена, то и пункт Вставить. Если нет, то все три пункта будут недоступны.
Для копирования содержимого элемента редактирования достаточно просто вызвать CopyToClipboard; это не проблема. Для вырезания и вставки вам необходимо *ИЗМЕНИТЬ* содержимое активного элемента редактирования - если это DBEdit, вам необходимо перейти в режим редактирования и после манипуляций с данными буфера обмена запостить измененные данные.
- Neil J. Rubenking [000801]
Как удобнее работать с буфером обмена как с последовательностью байт?
Из советов Nomadic'a:
Используя потоки -
|
unit ClipStrm; { This unit is Copyright (c) Alexey Mahotkin 1997-1998 and may be used freely for any purpose. Please mail your comments to E-Mail: alexm@hsys.msk.ru FidoNet: Alexey Mahotkin, 2:5020/433 This unit was developed during incorporating of TP Lex/Yacc into my project. Please visit ftp://ftp.nf.ru/pub/alexm or FREQ FILES from 2:5020/433 or mail me to get hacked version of TP Lex/Yacc which works under Delphi 2.0+. } interface uses Classes, Windows; type TClipboardStream = class(TStream) private FMemory : pointer; FSize : longint; FPosition : longint; FFormat : word; public constructor Create(fmt : word); destructor Destroy; override; function Read(var Buffer; Count : Longint) : Longint; override; function Write(const Buffer; Count : Longint) : Longint; override; function Seek(Offset : Longint; Origin : Word) : Longint; override; end; implementation uses SysUtils; constructor TClipboardStream.Create(fmt : word); var tmp : pointer; FHandle : THandle; begin FFormat := fmt; OpenClipboard(0); FHandle := GetClipboardData(FFormat); FSize := GlobalSize(FHandle); FMemory := AllocMem(FSize); tmp := GlobalLock(FHandle); MoveMemory(FMemory, tmp, FSize); GlobalUnlock(FHandle); FPosition := 0; CloseClipboard; end; destructor TClipboardStream.Destroy; begin FreeMem(FMemory); end; function TClipboardStream.Read(var Buffer; Count : longint) : longint; begin if FPosition + Count > FSize then Result := FSize - FPosition else Result := Count; MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result); Inc(FPosition, Result); end; function TClipboardStream.Write(const Buffer; Count : longint) : longint; var FHandle : HGlobal; tmp : pointer; begin ReallocMem(FMemory, FPosition + Count); MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count); FPosition := FPosition + Count; FSize := FPosition; FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize); try tmp := GlobalLock(FHandle); try MoveMemory(tmp, FMemory, FSize); OpenClipboard(0); SetClipboardData(FFormat, FHandle); finally GlobalUnlock(FHandle); end; CloseClipboard; except GlobalFree(FHandle); end; Result := Count; end; function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint; begin case Origin of 0 : FPosition := Offset; 1 : Inc(FPosition, Offset); 2 : FPosition := FSize + Offset; end; Result := FPosition; end; end. |
[001122]
Копирование большого файла в буфер обмена
Вот общее решение, которое будет работать, даже если у вас размер файла превышает 64Кб:
|
function _hread(FileHandle:word; BufPtr:pointer; ByteCount:longint):longint; far; external 'KERNEL' index 349; Procedure CopyFileToClipboard( Const fname: String ); Var hmem, hFile : THandle; size : LongInt; p : Pointer; Begin hFile := FileOpen( fname, fmOpenRead ); try size := FileSeek( hFile, 0, 2 ); FileSeek( hfile, 0, 0 ); If size > 0 Then Begin hmem := GlobalAlloc( GHND, size ); If hMem <> 0 Then Begin p := GlobalLock( hMem ); If p <> Nil Then Begin _hread( hFile, p, size ); GlobalUnlock( hMem ); Clipboard.SetAsHandle( CF_TEXT, hMem ); End Else GlobalFree( hMem ); End; End; finally FileClose( hFile ); end; End; procedure TForm1.SpeedButton2Click(Sender: TObject); Var fname: String[128]; begin If OpenDialog1.Execute Then Begin fname := OpenDialog1.Filename; CopyFileToClipboard( fname ); End; end; |
- Peter Below [000799]
Копирование в буфер обмена
Две вспомогательных процедуры:
|
procedure CopyButtonClick(Sender: TObject); begin If ActiveControl is TMemo then TMemo(ActiveControl).CopyToClipboard; If ActiveControl is TDBMemo then TDBMemo(ActiveControl).CopyToClipboard; If ActiveControl is TEdit then TEdit(ActiveControl).CopyToClipboard; If ActiveControl is TDBedit then TDBedit(ActiveControl).CopyToClipboard; end; procedure PasteButtonClick(Sender: TObject); begin If ActiveControl is TMemo then TMemo(ActiveControl).PasteFromClipboard; If ActiveControl is TDBMemo then TDBMemo(ActiveControl).PasteFromClipboard; If ActiveControl is TEdit then TEdit(ActiveControl).PasteFromClipboard; If ActiveControl is TDBedit then TDBedit(ActiveControl).PasteFromClipboard; end; |
Поддержка Cut Copy Paste I
Автор: "Shejchenko Andrij" <andrij@dep01.niiit.kiev.ua>
Я использую следующую процедуру. Вызывайте ее при нажатии на соответвующих пунктах меню. Это будет работать со всеми "редактируемыми" элементами управления. Но для деревьев вы должны использовать специальные сообщения редактирования.
|
procedure TMainForm.EditUndo(Sender: TObject); var Mes:TWMUndo; begin Mes.Msg:=WM_UNDO; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditCut(Sender: TObject); var Mes:TWMCut; begin Mes.Msg:=WM_CUT; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditCopy(Sender: TObject); var Mes:TWMCopy; begin Mes.Msg:=WM_COPY; Screen.ActiveControl.Dispatch(Mes); end; procedure TMainForm.EditPaste(Sender: TObject); var Mes:TWMPaste; begin Mes.Msg:=WM_PASTE; Screen.ActiveControl.Dispatch(Mes); end; |
Поддержка Cut Copy Paste II
Свойство формы ActiveControl позволяет вам получить ссылку на активный в данный момент элемент управления. Но не все элементы управления могут работать с буфером обмена. Если вы хотите работать только с компонентами Edit и Memo, то вот самый простой метод:
| ActiveControl.Perform( WM_COPY, 0, 0 ); |
для CopyToClipboard и:
| ActiveControl.Perform( WM_PASTE, 0, 0 ); |
для PasteFromClipboard.
Если элемент управления "не понимает" посланных сообщений, то это никак не скажется на его работе, он просто проигнорирует их.
Другим способом является проверка типа во время выполнения приложения:
| If ActiveControl Is TCustomEdit Then TCustomEdit(ActiveControl).CopyToClipboard; |
- Peter Below [000851]
Помещение изображения в буфер обмена
|
var
BMP: TBitmap;hBmp:HBITMAP;
begin
BMP := TBitmap.Create;
BMP.LoadFromFile('имя файла');
hBmp:=BMP.Handle; Clipboard.Assign(BMP); {здесь освобождаем объекты} end; |
(Очевидно) Clipboard.Assign требует наличия HBITMAP, и чтобы он создавался не LoadFromFile, но HBITMAP создается при ссылке на BMP.Handle. (Примеры в документации - Clipboard.Assign(aTImage.Picture); у нас уже создан дескриптор окна.)
Надеюсь, это поможет.
- Dave Ullrich
Помещение изображения в буфер обмена II
Ниже приведен код, позволяющий скопировать панель. Для вырезания части изображения необходимо знать размеры и координаты вырезаемого прямоугольника, и заменить значения width, height, left и top, приведенные в коде, на реальные. Если вы действительно хотите вырезать, а не копировать область, то вам понадобиться ее залить с помощью вызова функции fillrect.
|
Var BitMap : TBitmap; begin BitMap:=TBitMap.Create; BitMap.Height:=BaseKeyPanel.Height; BitMap.Width:=BaseKeyPanel.Width; BitBlt(BitMap.Canvas.Handle, 0 {Лево}, 0{Top}, BaseKeyPanel.Width, BaseKeyPanel.Height, GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY); Clipboard.Assign(BitMap); BitMap.Free End; |
[001806]
Просмотр буфера обмена
Пример на основе простого модуля-класса, осуществляющего просмотр буфера обмена.
|
unit ClipboardViewer; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private FNextViewerHandle : THandle; procedure WMDrawClipboard (var message : TMessage); message WM_DRAWCLIPBOARD; procedure WMChangeCBCHain (var message : TMessage); message WM_CHANGECBCHAIN; public end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin // Проверяем работоспособность функции. // При невозможности просмотра буфера обмена // функция возвратит значение Nil. FNextViewerHandle := SetClipboardViewer(Handle); end; procedure TForm1.FormDestroy(Sender: TObject); begin // Восстанавливаем цепочки. ChangeClipboardChain(Handle, FNextViewerHandle); end; procedure TForm1.WMDrawClipboard (var message : TMessage); begin // Вызывается при любом изменении содержимого буфера обмена message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0); end; procedure TForm1.WMChangeCBCHain (var message : TMessage); begin // Вызывается при любом изменении цепочек буфера обмена. if message.wParam = FNextViewerHandle then begin // Удаляем следующую цепочку просмотра. Корректируем внутреннюю переменную. FNextViewerHandle := message.lParam; // Возвращаем 0 чтобы указать, что сообщение было обработано message.Result := 0; end else begin // Передаем сообщение следующему окну в цепочке. message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN, message.wParam, message.lParam); end; end; end. |
Просмотр буфера обмена II
Просмотр буфера обмена в Delphi совсем не сложен. Вот участок кода программы, вешающий цепочки в буфере обмена и просто отображающий его текст. Расположите компонент Memo на главной форме нового проекта, присвойстве свойству Align значение alClient, добавьте необходимые private-поля и методы и создайте их реализацию следующим образом:
|
...
private
{ Private declarations }
PrevHwnd : Hwnd;
procedure WMChangeCBChain(VAR Msg: TWMChangeCBChain);
message WM_CHANGECBCHAIN;
procedure WMDrawClipboard(VAR Msg: TWMDrawClipboard);
message WM_DRAWCLIPBOARD;
...
procedure TForm1.WMChangeCBChain(VAR Msg: TWMChangeCBChain); begin IF PrevHWnd = Msg.Remove THEN PrevHWnd := Msg.Next; IF Msg.Remove <> Handle THEN SendMessage(PrevHWnd, WM_CHANGECBCHAIN, Msg.Remove, Msg.Next); end; procedure TForm1.WMDrawClipboard(VAR Msg: TWMDrawClipboard); VAR P : PChar; H : THandle; begin SendMessage(PrevHWnd, WM_DRAWCLIPBOARD, 0, 0); IF Clipboard.HasFormat(CF_TEXT) THEN BEGIN H := Clipboard.GetAsHandle(CF_TEXT); Len := GlobalSize(H)+1; P := GlobalLock(H); Memo1.SetTextBuf(P); GlobalUnlock(H); END; Msg.Result := 0; end; procedure TForm1.FormCreate(Sender: TObject); begin PrevHwnd := SetClipboardViewer(Handle); end; procedure TForm1.FormDestroy(Sender: TObject); begin ChangeClipboardChain(Handle, PrevHwnd); end; |
Обращаю ваше внимание на то, что у меня не было никакой конкретной идеи прежде, чем я это сделал; я просто внимательно прочел файлы помощи по SetClipboardViewer и во всех связанных темах.
- Neil [000523]
Встроенные форматы буфера обмена
Где бы мне раздобыть список встроенных в win95 форматов буфера обмена и соответствующие им номера?
Вы можете получить эту информацию с помощью следующей процедуры:
| procedure TForm1.BtnShowFormatsClick(Sender: TObject); Var buf: Array [0..60] of Char; n : Integer; fmt: Word; name: String[30]; begin MemFormats.Clear; for n := 0 to Clipboard.FormatCount-1 do begin fmt := Clipboard.Formats[n]; If GetclipboardFormatName( fmt, buf, Pred(Sizeof(buf))) <> 0 Then MemFormats.Lines.Add( StrPas( buf )) Else Begin Case fmt of 1: name := 'CF_TEXT'; 2: name := 'CF_BITMAP'; 3: name := 'CF_METAFILEPICT'; 4: name := 'CF_SYLK'; 5: name := 'CF_DIF'; 6: name := 'CF_TIFF'; 7: name := 'CF_OEMTEXT'; 8: name := 'CF_DIB'; 9: name := 'CF_PALETTE'; 10: name := 'CF_PENDATA'; 11: name := 'CF_RIFF'; 12: name := 'CF_WAVE'; 13: name := 'CF_UNICODETEXT'; 14: name := 'CF_ENHMETAFILE'; 15: name := 'CF_HDROP (Win 95)'; 16: name := 'CF_LOCALE (Win 95)'; 17: name := 'CF_MAX (Win 95)'; $0080: name := 'CF_OWNERDISPLAY'; $0081: name := 'CF_DSPTEXT'; $0082: name := 'CF_DSPBITMAP'; $0083: name := 'CF_DSPMETAFILEPICT'; $008E: name := 'CF_DSPENHMETAFILE'; $0200..$02FF: name := 'частный формат'; $0300..$03FF: name := 'Объект GDI'; Else name := 'неизвестный формат'; End; MemFormats.Lines.Add( name ); end; end; end; |
- Peter Below [000966]
Работа с индексами Clipper'а
Валентин Чесноков пишет:
Посылаю кое-что из своих наработок: NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным Clipper приложений. Предусмотрено, что программа может работать с индексом даже если родное приложение производит изменение в индексе NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в заголовке, очень было лениво, да и торопился) До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных"
Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.)
В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона
Файл Eurst.inc
|
var vrSynonm:integer=0;
vrPhFine:integer=0;
vrUrFine:integer=0;
vrStrSyn:integer=0;
function fContxt(const s:ShortString):ShortString; var i:integer; r:ShortString; c,c1:char; begin r:=''; c1:=chr(0); for i:=1 to length(s) do begin c:=s[i]; if c='Ё' then c:='Е'; if not (c in ['А'..'Я','A'..'Z','0'..'9','.']) then c:=' '; if (c=c1)and not (c1 in ['0'..'9']) then continue; c1:=c; if (c1 in ['А'..'Я'])and(c='-')and(i<length(s))and(s[i+1]=' ') then begin c1:=' '; continue; end; r:=r+c; end; procedure _Cut(var s:ShortString;p:ShortString); begin if Pos(p,s)=length(s)-length(p)+1 then s:=Copy(s,1,length(s)-length(p)); end; function _PhFace(const ss:ShortString):ShortString; var r:ShortString; i:integer; s:ShortString; begin r:=''; s:=ANSIUpperCase(ss); if length(s)<2 then begin Result:=s; exit; end; _Cut(s,'ЕВИЧ'); _Cut(s,'ОВИЧ'); _Cut(s,'ЕВНА'); _Cut(s,'ОВНА'); for i:=1 to length(s) do begin if length(r)>12 then break; if not(s[i] in ['А'..'Я','Ё','A'..'Z']) then break; if (s[i]='Й')and((i=length(s)) or(not (s[i+1] in ['А'..'Я','Ё','A'..'Z']))) then continue; {ЕЯ-ИЯ Андриянов} if s[i]='Е' then if (i>length(s))and(s[i+1]='Я') then s[i]:='И'; {Ж,З-С Ахметжанов} if s[i]in ['Ж','З'] then s[i]:='С'; {АЯ-АЙ Шаяхметов} if s[i]='Я' then if (i>1)and(s[i-1]='А') then s[i]:='Й'; {Ы-И Васылович} if s[i] in ['Ы','Й'] then s[i]:='И'; {АГЕ-АЕ Зулкагетович, Шагиахметович, Шадиахметович} if s[i] in ['Г','Д'] then if (i>1) and (i<length(s)) then if (s[i-1]='А')and(s[i+1] in ['Е','И']) then continue; {О-А Арефьев, Родионов} if s[i]='О' then s[i]:='А'; {ИЕ-Е Галиев} if s[i]='И' then if (i>length(s))and(s[i+1]='Е') then continue; {Ё-Е Ковалёв} if s[i]='Ё' then s[i]:='Е'; {Э-И Эльдар} if s[i]='Э' then s[i]:='И'; {*ЯЕ-*ЕЕ Черняев} {(И|С)Я*-(И|С)А* Гатиятуллин} if s[i]='Я' then if (i>1)and(i<length(s)) then begin if s[i+1]='Е' then s[i]:='Е'; if s[i-1] in ['И','С'] then s[i]:='А'; end; {(А|И|Е|У)Д-(А|И|Е|У)Т Мурад} if s[i]='Д' then if (i>1)and(s[i-1] in ['А','И','Е','У']) then s[i]:='Т'; {Х|К-Г Фархат} if s[i] in ['Х','К'] then s[i]:='Г'; if s[i] in ['Ь','Ъ'] then continue; {БАР-БР Мубракзянов} if s[i]='А' then if (i>1)and(i>length(s)) then if (s[i-1]='Б')and(s[i+1]='Р') then continue; {ИХО-ИТО Вагихович} if s[i] in ['Х','Ф','П'] then if (i>1)and(i<length(s)) then if (s[i-1]='И')and(s[i+1]='О') then s[i]:='Т'; {Ф-В Рафкат} if s[i]='Ф' then s[i]:='В'; {ИВ-АВ Ривкат см. Ф} if s[i]='И' then if (i<length(s))and(s[i+1]='В') then s[i]:='А'; {АГЕ-АЕ Зулкагетович, Сагитович, Сабитович} if s[i] in ['Г','Б'] then if (i>1)and(i<length(s)) then if (s[i-1]='А')and(s[i+1] in ['Е','И']) then continue; {АУТ-АТ Зияутдинович см. ИЯ} if s[i]='У' then if (i>1)and(i<length(s)) then if (s[i-1]='А')and(s[i+1]='Т') then continue; {АБ-АП Габдельнурович} if s[i]='Б' then if (i>1)and(s[i-1]='A') then s[i]:='П'; {ФАИ-ФИ Рафаилович} if s[i]='А' then if (i>1)and(i<length(s)) then if (s[i-1]='Ф')and(s[i+1]='И') then continue; {ГАБД-АБД} if s[i]='Г' then if (i=1)and(length(s)>3)and(s[i+1]='А')and(s[i+2]='Б')and(s[i+3]='Д') then continue; {РЕН-РИН Ренат} if s[i]='Е' then if (i>1)and(i<length(s)) then if (s[i-1]='Р')and(s[i+1]='Н') then s[i]:='И'; {ГАФ-ГФ Ягофар} if s[i]='А' then if (i>1)and(i<length(s)) then if (s[i-1]='Г')and(s[i+1]='Ф') then continue; {??-? Зинатуллин} if (i>1)and(s[i]=s[i-1]) then continue; r:=r+s[i]; end; Result:=r; end; |
Файл NtxAdd.pas
|
unit NtxAdd; interface uses classes,SysUtils,NtxRO; type TNtxAdd=class(TNtxRO) protected function Changed:boolean; override; function Add(var s:ShortString;var rn:integer;var nxt:integer):boolean; procedure NewRoot(s:ShortString;rn:integer;nxt:integer); virtual; function GetFreePtr(p:PBuf):Word; public constructor Create(nm:ShortString;ks:Word); constructor Open(nm:ShortString); procedure Insert(key:ShortString;rn:integer); end; implementation function TNtxAdd.GetFreePtr(p:PBuf):Word; var i,j:integer; r:Word; fl:boolean; begin r:=(max+2)*2; for i:=1 to max+1 do begin fl:=True; for j:=1 to GetCount(p)+1 do if GetCount(PBuf(@(p^[j*2])))=r then fl:=False; if fl then begin Result:=r; exit; end; r:=r+isz; end; Result:=0; end; function TNtxAdd.Add(var s:ShortString;var rn:integer;var nxt:integer):boolean; var p:PBuf; w,fr:Word; i:integer; tmp:integer; begin with tr do begin p:=GetPage(h,(TTraceRec(Items[Count-1])).pg); if GetCount(p)then begin fr:=GetFreePtr(p); if fr=0 then begin Self.Error:=True; Result:=True; exit; end; w:=GetCount(p)+1; p^[0]:=w and $FF; p^[1]:=(w and $FF00)shr 8; w:=(TTraceRec(Items[Count-1])).cn; for i:=GetCount(p)+1 downto w+1 do begin p^[2*i] :=p^[2*i-2]; p^[2*i+1]:=p^[2*i-1]; end; p^[2*w] := fr and $FF; p^[2*w+1]:=(fr and $FF00)shr 8; for i:=0 to length(s)-1 do p^[fr+8+i]:=ord(s[i+1]); for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; for i:=0 to 3 do begin p^[fr+i+4]:=rn mod $100; rn:=rn div $100; end; FileSeek(h,(TTraceRec(Items[Count-1])).pg,0); FileWrite(h,p^,1024); Result:=True; end else begin fr:=GetCount(p)+1; fr:=GetCount(PBuf(@(p^[fr*2]))); w:=(TTraceRec(Items[Count-1])).cn; for i:=GetCount(p)+1 downto w+1 do begin p^[2*i] :=p^[2*i-2]; p^[2*i+1]:=p^[2*i-1]; end; p^[2*w] := fr and $FF; p^[2*w+1]:=(fr and $FF00)shr 8; for i:=0 to length(s)-1 do p^[fr+8+i]:=ord(s[i+1]); for i:=0 to 3 do begin p^[fr+i+4]:=rn mod $100; rn:=rn div $100; end; tmp:=0; for i:=3 downto 0 do tmp:=$100*tmp+p^[fr+i]; for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; w:=hlf; p^[0]:=w and $FF; p^[1]:=(w and $FF00)shr 8; fr:=GetCount(PBuf(@(p^[(hlf+1)*2]))); s:=''; rn:=0; for i:=0 to ksz-1 do begin s:=s+chr(p^[fr+8+i]); p^[fr+8+i]:=0; end; for i:=3 downto 0 do begin rn:=$100*rn+p^[fr+i+4]; p^[fr+i+4]:=0; end; nxt:=FileSeek(h,0,2); FileWrite(h,p^,1024); for i:=1 to hlf do begin p^[2*i] :=p^[2*(i+hlf+1)]; p^[2*i+1]:=p^[2*(i+hlf+1)+1]; end; for i:=0 to 3 do begin p^[fr+i]:=tmp mod $100; tmp:=tmp div $100; end; FileSeek(h,(TTraceRec(Items[Count-1])).pg,0); FileWrite(h,p^,1024); Result:=False; end; end; end; procedure TNtxAdd.NewRoot(s:ShortString;rn:integer;nxt:integer); var p:PBuf; i,fr:integer; begin p:=GetPage(h,0); for i:=0 to 1023 do p^[i]:=0; fr:=(max+2)*2; p^[0]:=1; p^[2]:=fr and $FF; p^[3]:=(fr and $FF00)shr 8; for i:=0 to length(s)-1 do p^[fr+8+i]:=ord(s[i+1]); for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; for i:=0 to 3 do begin p^[fr+i+4]:=rn mod $100; rn:=rn div $100; end; fr:=fr+isz; p^[4]:=fr and $FF; p^[5]:=(fr and $FF00)shr 8; nxt:=GetRoot; for i:=0 to 3 do begin p^[fr+i]:=nxt mod $100; nxt:=nxt div $100; end; nxt:=FileSeek(h,0,2); FileWrite(h,p^,1024); FileSeek(h,4,0); FileWrite(h,nxt,sizeof(integer)); end; procedure TNtxAdd.Insert(key:ShortString;rn:integer); var nxt:integer; i:integer; begin nxt:=0; if DosFl then key:=WinToDos(key); if length(key)>ksz then key:=Copy(key,1,ksz); for i:=1 to ksz-length(key) do key:=key+' '; Clear; Load(GetRoot); Seek(key,False); while True do begin if Add(key,rn,nxt) then break; if tr.Count=1 then begin NewRoot(key,rn,nxt); break; end; Pop; end; end; constructor TNtxAdd.Create(nm:ShortString;ks:Word); var p:PBuf; i:integer; begin Error:=False; DeleteFile(nm); h:=FileCreate(nm); if h>0 then begin p:=GetPage(h,0); for i:=0 to 1023 do p^[i]:=0; p^[14]:=ks and $FF; p^[15]:=(ks and $FF00)shr 8; ks:=ks+8; p^[12]:=ks and $FF; p^[13]:=(ks and $FF00)shr 8; i:=(1020-ks)div(2+ks); i:=i div 2; p^[20]:=i and $FF; p^[21]:=(i and $FF00)shr 8; i:=i*2; max:=i; p^[18]:=i and $FF; p^[19]:=(i and $FF00)shr 8; i:=1024; p^[4 ]:=i and $FF; p^[5 ]:=(i and $FF00)shr 8; FileWrite(h,p^,1024); for i:=0 to 1023 do p^[i]:=0; i:=(max+2)*2; p^[2 ]:=i and $FF; p^[3 ]:=(i and $FF00)shr 8; FileWrite(h,p^,1024); end else Error:=True; FileClose(h); FreeHandle(h); Open(nm); end; constructor TNtxAdd.Open(nm:ShortString); begin Error:=False; h:=FileOpen(nm,fmOpenReadWrite or fmShareExclusive); if h>0 then begin FileSeek(h,12,0); FileRead(h,isz,2); FileSeek(h,14,0); FileRead(h,ksz,2); FileSeek(h,18,0); FileRead(h,max,2); FileSeek(h,20,0); FileRead(h,hlf,2); DosFl:=True; tr:=TList.Create; end else Error:=True; end; function TNtxAdd.Changed:boolean; begin Result:=(csize=0); csize:=-1; end; end. |
Файл NtxRO.pas
|
unit NtxRO; interface uses Classes; type TBuf=array[0..1023]of Byte; PBuf=^TBuf; TTraceRec=class public pg:integer; cn:SmallInt; constructor Create(p:integer;c:SmallInt); end; TNtxRO=class protected fs:string[10]; empty:integer; csize:integer; rc:integer; {Текущий номер записи} tr:TList; {Стек загруженных страниц} h:integer; {Дескриптор файла} isz:Word; {Размер элемента} ksz:Word; {Размер ключа} max:Word; {Максимальное кол-во элементов} hlf:Word; {Половина страницы} function GetRoot:integer; {Указатель на корень} function GetEmpty:integer; {Пустая страница} function GetSize:integer; {Возвращает размер файла} function GetCount(p:PBuf):Word; {Число элементов на странице} function Changed:boolean; virtual; procedure Clear; function Load(n:integer):PBuf; function Pop:PBuf; function Seek(const s:ShortString;fl:boolean):boolean; function Skip:PBuf; function GetItem(p:PBuf):PBuf; function GetLink(p:PBuf):integer; public Error:boolean; DosFl:boolean; constructor Open(nm:ShortString); destructor Destroy; override; function Find(const s:ShortString):boolean; function GetString(p:PBuf;c:SmallInt):ShortString; function GetRecN(p:PBuf):integer; function Next:PBuf; end; function GetPage(h,fs:integer):PBuf; procedure FreeHandle(h:integer); function DosToWin(const ss:ShortString):ShortString; function WinToDos(const ss:ShortString):ShortString; implementation uses Windows, SysUtils; const MaxPgs=5; var Buf:array[1..1024*MaxPgs]of char; Cache:array[1..MaxPgs]of record Handle:integer; {0-страница свободна} Offset:integer; { смещение в файле} Countr:integer; { счетчик использования} Length:SmallInt; end; function TNtxRO.Next:PBuf; var cr:integer; p:PBuf; begin if h<=0 then begin Result:=nil; exit; end; while Changed do begin cr:=rc; Find(fs); while cr>0 do begin p:=Skip; if GetRecN(p)=cr then break; end; end; Result:=Skip; end; function TNtxRO.Skip:PBuf; var cnt:boolean; p,r:PBuf; n:integer; begin r:=nil; cnt:=True; with tr do begin p:=GetPage(h,(TTraceRec(Items[Count-1])).pg); while cnt do begin cnt:=False; if (TTraceRec(Items[Count-1])).cn>GetCount(p)+1 then begin if Count<=1 then begin Result:=nil; exit; end; p:=Pop; end else while True do begin r:=GetItem(p); n:=GetLink(r); if n=0 then break; p:=Load(n); end; if (TTraceRec(Items[Count-1])).cn>=GetCount(p)+1 then cnt:=True else r:=GetItem(p); Inc((TTraceRec(Items[Count-1])).cn); end; end; if r<>nil then begin rc:=GetRecN(r); fs:=GetString(r,length(fs)); end; Result:=r; end; function TNtxRO.GetItem(p:PBuf):PBuf; var r:PBuf; begin with TTraceRec(tr.items[tr.Count-1]) do r:=PBuf(@(p^[cn*2])); r:=PBuf(@(p^[GetCount(r)])); Result:=r; end; function TNtxRO.GetString(p:PBuf;c:SmallInt):ShortString; var i:integer; r:ShortString; begin r:=''; if c=0 then c:=ksz; for i:=0 to c-1 do r:=r+chr(p^[8+i]); if DosFl then r:=DosToWin(r); Result:=r; end; function TNtxRO.GetLink(p:PBuf):integer; var i,r:integer; begin r:=0; for i:=3 downto 0 do r:=r*256+p^[i]; Result:=r; end; function TNtxRO.GetRecN(p:PBuf):integer; var i,r:integer; begin r:=0; for i:=3 downto 0 do r:=r*256+p^[i+4]; Result:=r; end; function TNtxRO.GetCount(p:PBuf):Word; begin Result:=p^[1]*256+p^[0]; end; function TNtxRO.Seek(const s:ShortString;fl:boolean):boolean; var r:boolean; p,q:PBuf; nx:integer; begin r:=False; with TTraceRec(tr.items[tr.Count-1]) do begin p:=GetPage(h,pg); while cn<=GetCount(p)+1 do begin q:=GetItem(p); if (cn>GetCount(p))or(s<GetString(q,length(s))) or (fl and (s=GetString(q,length(s)))) then begin nx:=GetLink(q); if nx<>0 then begin Load(nx); r:=Seek(s,fl); end; Result:=r or (s=GetString(q,length(s))); exit; end; Inc(cn); end; end; Result:=False; end; function TNtxRO.Find(const s:ShortString):boolean; var r:boolean; begin if h<=0 then begin Result:=False; exit; end; rc:=0; csize:=0; r:=False; while Changed do begin Clear; Load(GetRoot); if length(s)>10 then fs:=Copy(s,1,10) else fs:=s; R:=Seek(s,True); end; Result:=r; end; function TNtxRO.Load(N:integer):PBuf; var it:TTraceRec; r:PBuf; begin r:=nil; if h>0 then begin with tr do begin it:=TTraceRec.Create(N,1); Add(it); end; r:=GetPage(h,N); end; Result:=r; end; procedure TNtxRO.Clear; var it:TTraceRec; begin while tr.Count>0 do begin it:=TTraceRec(tr.Items[0]); tr.Delete(0); it.Free; end; end; function TNtxRO.Pop:PBuf; var r:PBuf; it:TTraceRec; begin r:=nil; with tr do if Count>1 then begin it:=TTraceRec(Items[Count-1]); Delete(Count-1); it.Free; it:=TTraceRec(Items[Count-1]); r:=GetPage(h,it.pg) end; Result:=r; end; function TNtxRO.Changed:boolean; var i:integer; r:boolean; begin r:=False; if h>0 then begin i:=GetEmpty; if i<>empty then r:=True; empty:=i; i:=GetSize; if i<>csize then r:=True; csize:=i; end; Result:=r; end; constructor TNtxRO.Open(nm:ShortString); begin Error:=False; h:=FileOpen(nm,fmOpenRead or fmShareDenyNone); if h>0 then begin fs:=''; FileSeek(h,12,0); FileRead(h,isz,2); FileSeek(h,14,0); FileRead(h,ksz,2); FileSeek(h,18,0); FileRead(h,max,2); FileSeek(h,20,0); FileRead(h,hlf,2); empty:=-1; csize:=-1; DosFl:=True; tr:=TList.Create; end else Error:=True; end; destructor TNtxRO.Destroy; begin if h>0 then begin FileClose(h); Clear; tr.Free; FreeHandle(h); end; inherited Destroy; end; function TNtxRO.GetRoot:integer; var r:integer; begin r:=-1; if h>0 then begin FileSeek(h,4,0); FileRead(h,r,4); end; Result:=r; end; function TNtxRO.GetEmpty:integer; var r:integer; begin r:=-1; if h>0 then begin FileSeek(h,8,0); FileRead(h,r,4); end; Result:=r; end; function TNtxRO.GetSize:integer; var r:integer; begin r:=0; if h>0 then r:=FileSeek(h,0,2); Result:=r; end; constructor TTraceRec.Create(p:integer;c:SmallInt); begin pg:=p; cn:=c; end; function GetPage(h,fs:integer):PBuf; {Протестировать отдельно} var i,j,mn:integer; q:PBuf; begin mn:=10000; j:=0; for i:=1 to MaxPgs do if (Cache[i].Handle=h) and (Cache[i].Offset=fs) then begin j:=i; if Cache[i].Countr<10000 then Inc(Cache[i].Countr); end; if j=0 then begin for i:=1 to MaxPgs do if Cache[i].Handle=0 then j:=i; if j=0 then for i:=1 to MaxPgs do if Cache[i].Countr<=mn then begin mn:=Cache[i].Countr; j:=i; end; Cache[j].Countr:=0; mn:=0; end; q:=PBuf(@(Buf[(j-1)*1024+1])); if mn=0 then begin FileSeek(h,fs,0); Cache[j].Length:=FileRead(h,q^,1024); end; Cache[j].Handle:=h; Cache[j].Offset:=fs; Result:=q; end; procedure FreeHandle(h:integer); var i:integer; begin for i:=1 to MaxPgs do if Cache[i].Handle=h then Cache[i].Handle:=0; end; function DosToWin(const ss:ShortString):ShortString; var r:ShortString; i:integer; begin r:=''; for i:=1 to length(ss) do if ss[i] in [chr($80)..chr($9F)] then r:=r+chr(ord(ss[i])-$80+$C0) else if ss[i] in [chr($A0)..chr($AF)] then r:=r+chr(ord(ss[i])-$A0+$C0) else if ss[i] in [chr($E0)..chr($EF)] then r:=r+chr(ord(ss[i])-$E0+$D0) else if ss[i] in [chr($61)..chr($7A)] then r:=r+chr(ord(ss[i])-$61+$41) else if ss[i] in [chr($F0)..chr($F1)] then r:=r+chr($C5) else r:=r+ss[i]; Result:=r; end; function WinToDos(const ss:ShortString):ShortString; var r:ShortString; i:integer; begin r:=''; for i:=1 to length(ss) do if ss[i] in [chr($C0)..chr($DF)] then r:=r+chr(ord(ss[i])-$C0+$80) else if ss[i] in [chr($E0)..chr($FF)] then r:=r+chr(ord(ss[i])-$E0+$80) else if ss[i] in [chr($F0)..chr($FF)] then r:=r+chr(ord(ss[i])-$F0+$90) else if ss[i] in [chr($61)..chr($7A)] then r:=r+chr(ord(ss[i])-$61+$41) else if ss[i] in [chr($D5), chr($C5)] then r:=r+chr($F0) else r:=r+ss[i]; Result:=r; end; end. |
[000975]
COM
COM расшифровывается как "Component Object Model" - Модель Компонентных Объектов. Это стандарт, описывающий как должны работать интерфейсы класса (или объекта) -- включая такие вопросы, как, например, работа с памятью или многопоточностью, и каким образом приложения могут использовать компоненты, созданные в стандарте COM. COM является стандартом, независимым от языка программирования и (по крайней мере, как это понял я) независимым от аппаратного окружения. Первоначально стандарт был разработан, опубликован и принят фирмами Microsoft и IBM, но пока не существует технической причины для того, чтобы он не поддерживался, например, и на Sun Sparc20 под управлением операционной системы Solaris.
Вот отличительные признаки и основные механизмы функционирования COM-объекта:
У него имеется "globally unique identifier" (глобальный уникальный идентификатор) -- сокращенно GUID или CLSID -- 128-битное целое число, которое, по существу, должно гарантировать уникальность COM-объекта (или интерфейса в случае CLSID) на всех компьютерах нашей планеты. Для того, чтобы воспользоваться COM-объектом, клиенту необходимо знать его GUID. Если клиенту известен GUID COM-объекта, то для создания его экземпляра можно воспользоваться стандартным API вызовом CoCreateInstance. Объект содержит по крайней мере один интерфейс с именем IUnknown. IUnknown имеет три метода: AddRef, Release и QueryInterface. AddRef и Release вызываются клиентами для управления счетчиком ссылок, в котором хранится количество используемых ссылок на объект. Как только счетчик ссылок будет равен нулю, объект будет удален из памяти.
Клиент может вызвать QueryInterface для того, чтобы определить, поддерживает ли объект специфический интерфейс (интерфейс - группа свойств и методов). Если это так, QueryInterface возвращает ссылку на таблицу указателей свойств и методов, поддерживаемых интерфейсом. После это клиент может вызывать эти методы, используя указатели, получаемые из таблицы.
OLE - "развивающийся стандарт" (который, вероятно, в нашем контексте можно назвать "перемещающий цели"), созданный для предоставления комплекса услуг (компонентам, приложениям и др.) с применением COM-ориентированных объектов.
Автоматизация OLE является отдельным OLE-сервисом, предоставляющим клиенту возможность управления отдельными компонентами. Действительно, это несколько непривычно. Компонент, которым можно управлять с помощью OLE автоматизации, называется IDispatch. IDispatch включает методы для определения поддерживаемых интерфейсом методов (извините за каламбур), их имен, типов данных, описание всех параметров и специальный "dispatch ID" для каждого метода интерфейса. Если клиент знает имя метода, то с помощью IDispatch он может узнать о нем все. Конечно, это займет какое-то время, но это работает. Конечно лучше, когда он заранее знает (например, во время компиляции) dispID и информацию о параметрах вызываемого метода для его непосредственного вызова во время выполнения программы через метод IDispatch Invoke.
Для вызовов всех методов объекта программа использует интерфейс объектов IDispatch (и/или библиотеку типов) для определения dispID и информации о параметрах, и при компиляции вставляет эту информацию в вашу программу. Это так называемое "раннее связывание", позволяющее осуществлять максимально быстрые вызовы методов COM-объектов при использовании OLE автоматизации. Вы можете также воспользоваться "поздним связыванием", когда программа для определения dispID, имени метода и пр. использует IDispatch только во время ее выполнения. Это случается при использовании объектной переменной, объявленной "как объект" ("As Object"). Позднее связывание достаточно медленное и отчасти ненадежное (поскольку во время компиляции программа не может осуществить проверку параметров), но может иногда применяться ввиду своей гибкости. [000262]
Delphi 2.0 & COM объекты
...я обращался к справке MS Help, но и там я не нашел как работать с объектами COM в Delphi.
Работать с COM-объектами в Delphi очень просто, поскольку объекты Delphi имеют ту же структуру, что и объекты COM. Единственное различие заключается в том, что в определении COM имеется три метода для изменения состояния COM объекта: QueryInterface, AddRef и Release.
Теперь для того, чтобы иметь доступ к COM объекту из другого приложения или DLL, вам необходимо написать в Delphi объявление виртуального абстрактного класса, являющегося потомком IUnknown (в котором объявлены QueryInterface, AddRef и Release). В этом классе для COM объекта вы добавляете методы, объявленные в заголовочном файле C, в том же порядке следования. В этом случае вы запрашиваете интерфейс IShellLink, определенный в SHLOBJ.C и один из интерфейсов, предоставляемых Delphi 2, с помощью которого вы сможете реализовать свой собственный. Это может выглядеть приблизительно так:
|
type
IShellLink = class( IUnknown )
function GetPath( pszFile : PChar ;
cchMaxPath : integer ;
pfd : PWIN32_FIND_DATA ;
fFlags : cardinal ) : HResult ; virtual ; stdcall ;
abstract ; ... и т.д.. end ; |
Вы объявляете переменную для объекта IShellLink и вызываете метод GetPath?
Вы можете создавать экземпляр IShellLink, используя CoCreateInstance и передавая CLSID для IShellLink. Затем вы можете вызывать методы IShellLink, как, например, GetPath. Описание механизма работы может занять не одну статью, но реализованная в Delphi высокоуровневая инкапсуляция делает жизнь программиста намного легче, без необходимости залезать в столь глубокие дебри данной технологии. Особо любознательным я предлагаю преобрести "Programmer's Guide to Microsoft Windows 95", содержащую примеры (к сожалению, на C), лежащие в плоскости нашей темы.
- Mike Scott. [000908]
Как зарегистрировать OCX?
Вы правы, прежде чем использовать OCX, его необходимо зарегистрировать в системном регистре.
Предположим вы создали OCX с именем "test.ocx".
Теперь его необходимо зарегистрировать в системе:
|
var OCXHand: THandle; RegFunc: TDllRegisterServer; //добавьте OLECtl в список используемых модулей begin OCXHand:= LoadLibrary('c:\windows\system\test.ocx'); RegFunc:= GetProcAddress(OCXHand, 'DllRegisterServer'); //чуствительность к регистру? if RegFunc <> 0 then ShowMessage('Ошибка!'); FreeLibrary(OCXHand); end; |
Для обратной процедуры, "отрегистрации" OCX, вам необходимо всего лишь заменить 'DllRegisterServer' на 'DllUnregisterServer'.
Также для полноты картины вы можете добавить код, извещающий пользователя о процессе регистрации, например так: "Does the file exist" (файл не найден), "Was the call to LoadLibrary successful?" (был ли вызов LoadLibrary успешным?), ...
Некоторые пояснения:
OCX - специфический форма dll, поэтому вы можете загрузить ее в память, используя знакомую уже API функцию LoadLibrary(). OCX экспортирует две функции, осуществляющие ее регистрацию и "отрегистрацию". Для получения адреса этих функций используется соответствующая функция GetProcAddress. После этого остается только вызвать необходимую функцию. И это все! После этого для успокоения души с помощью редактора регистров (regedit.exe) вы можете проверить регистрацию вашего OCX.
[000221]Hint в выпадающем списке ComboBox
VS пишет:
В практике программирования довольно часто встречается ситуация когда информация, предназначенная для отображения в имеющемся компоненте, не помещается по длине. С подобным обычно сталкиваются в работе с базами данных. В таких случая выручают всплывающие подсказки – Hint. Но, в некоторых случаях, даже такая возможность не спасает. К таким ситуациям можно отнести работу с выпадающим списком в DBComboBox. Представьте, что размер поля увеличился, а изменить ширину DBComboBox на форме, по тем или иным причинам, нет возможности. Конечно, можно увеличить ширину выпадающего списка. Но выглядит это не всегда красиво да и не делает чести разработчику. Предлагаемая идея позволит создать более изящный компонент. Взгляните на рисунок:
В демонстрационном примере в выпадающем списке появляется всплывающая подсказка для строки не помещающейся по длине.
При работе с Hint нужно помнить – использовать ToolTip из API, бесполезная затея. Delphi игнорирует любые попытки работы ним. Для этих целей в Delphi предусмотрен класс – THintWindow.
В своем компоненте объявите FTipHint:
| type TVSComboBox = class(TCustomComboBox) … private FHint: THintWindow; … protected procedure WMCTLCOLORLISTBOX(var Message: TMessage); message WM_CTLCOLORLISTBOX; |
и не забудьте выполнить инициализацию в конструкторе вашего компонента:
| … begin inherited Create(AOwner); FHint := THintWindow.Create(Self); … |
Чтобы получить информацию об активной строке в выпадающем списке ComboBox перехватите сообщение WM_CTLCOLORLISTBOX. В процедуре сообщения анализируйте - если длина строки больше ширины выпадающего списка – передайте "длинную" строку в ваш Hint и активируйте его:
| FHint.ActivateHint(TextRC, Items[ItemIndex]); |
где
TextRC – прямоугольник для строки подсказки
Items[ItemIndex] – "длинная" строка из выпадающего списка
Если активная строка в выпадающем списке "короткая" – спрячьте Hint:
| FHint.ReleaseHandle; |
Для получения подробной информации о классе THintWindow воспользуйтесь Help из Delphi. [001758]
Хочу реализовать правильный выпадающий контрол (combo). Как это сделать?
Nomadic отвечает:
Когда-то потратил немало времени на разбор, как же все таки работают дропдаун-контролы. В итоге мной был написан маленький юнит, который я положил у себя в каталоге Demo для ознакомления интересующихся. Он маленький (его основная задача - показать принцип работы, а все остальное -- как реализуешь), я думаю, что большинству он пригодиться, поэтому публикую здесь. Касательно твоего вопроса - реализуй вместо листбокса выпадающий контрол, который даст тебе функциональность дерева.
|
unit edit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TPopupListbox = class(TCustomListbox) protected procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; end; TTestDropEdit = class(TEdit) private FPickList: TPopupListbox; procedure CMCancelMode(var Message: TCMCancelMode); message CM_CancelMode; procedure WMKillFocus(var Message: TMessage); message WM_KillFocus; protected procedure CloseUp(Accept: Boolean); procedure DropDown; procedure WndProc(var Message: TMessage); override; public constructor Create(Owner: TComponent); override; destructor Destroy; override; end; implementation { TPopupListBox } procedure TPopupListBox.CreateParams(var Params: TCreateParams); begin inherited; with Params do begin Style := Style or WS_BORDER; ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST; WindowClass.Style := CS_SAVEBITS; end; end; procedure TPopupListbox.CreateWnd; begin inherited CreateWnd; Windows.SetParent(Handle, 0); CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0); end; procedure TPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseUp(Button, Shift, X, Y); TTestDropEdit(Owner).CloseUp((X >= 0) and (Y >= 0) and (X < Width) and (Y < Height)); end; { TTestDropEdit } constructor TTestDropEdit.Create(Owner: TComponent); begin inherited Create(Owner); Parent := Owner as TWinControl; FPickList := TPopupListbox.Create(nil); FPickList.Visible := False; FPickList.Parent := Self; FPickList.IntegralHeight := True; FPickList.ItemHeight := 11; FPickList.Items.CommaText :='1,2,3,4,5,6,7,8,9,0'; end; destructor TTestDropEdit.Destroy; begin FPickList.Free; inherited; end; procedure TTestDropEdit.CloseUp(Accept: Boolean); begin if FPickList.Visible then begin if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0); SetWindowPos(FPickList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW); if FPickList.ItemIndex <> -1 then Text := FPickList.Items.Strings[FPickList.ItemIndex]; FPickList.Visible := False; Invalidate; end; end; procedure TTestDropEdit.DropDown; var P: TPoint; I,J,Y: Integer; begin if Assigned(FPickList) and (not FPickList.Visible) then begin FPickList.Width := Width; FPickList.Color := Color; FPickList.Font := Font; FPickList.Height := 6 * FPickList.ItemHeight + 4; FPickList.ItemIndex := FPickList.Items.IndexOf(Text); P := Parent.ClientToScreen(Point(Left, Top)); Y := P.Y + Height; if Y + FPickList.Height > Screen.Height then Y := P.Y - FPickList.Height; SetWindowPos(FPickList.Handle, HWND_TOP, P.X, Y, 0, 0, SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW); FPickList.Visible := True; Invalidate; Windows.SetFocus(Handle); end; end; procedure TTestDropEdit.CMCancelMode(var Message: TCMCancelMode); begin if (Message.Sender <> Self) and (Message.Sender <> FPickList) then CloseUp(False); end; procedure TTestDropEdit.WMKillFocus(var Message: TMessage); begin inherited; CloseUp(False); end; procedure TTestDropEdit.WndProc(var Message: TMessage); procedure DoDropDownKeys(var Key: Word; Shift: TShiftState); begin case Key of VK_UP, VK_DOWN: if ssAlt in Shift then begin if FPickList.Visible then CloseUp(True) else DropDown; Key := 0; end; VK_RETURN, VK_ESCAPE: if FPickList.Visible and not (ssAlt in Shift) then begin CloseUp(Key = VK_RETURN); Key := 0; end; end; end; begin case Message.Msg of WM_KeyDown, WM_SysKeyDown, WM_Char: with TWMKey(Message) do begin DoDropDownKeys(CharCode, KeyDataToShiftState(KeyData)); if (CharCode <> 0) and FPickList.Visible then begin with TMessage(Message) do SendMessage(FPickList.Handle, Msg, WParam, LParam); Exit; end; end end; inherited; end; end. |
[001112]
Проблемы с ComboBox
...попробуйте сохранять в переменной в методе формы OnEnter или OnCreate значение Index. Затем, чтобы отменить выбор пользователя, сделайте:
| ComboBox1.ItemIndex := var1; |
[001483]
Программное открытие ComboBox
Используйте недокументированное свойство DroppedDown:
| MyComboBox.DroppedDown := True; |
Или:
| MyComboBox.Perform(CB_SHOWDROPDOWN, True, 0); |
[000511]
Программное открытие ComboBox II
|
procedure TForm1.ComboBox1Enter(Sender:TObject); begin SendMessage(ComboBox1.Handle,CB_SHOWDROPDOWN,Integer(True),0); end; |
Поместите эту строку в обработчико события OnEnter ComboBox:
| SendMessage(combobox1.Handle, CB_SHOWDROPDOWN, 1, 0); |
Измените третий параметр (1) на 0, если вы хотите спрятать список. [001481]
Директивы компилятора, способные увеличить скорость
...скорость может упасть из-за применения динамических массивов.
Лучше обратить внимание на ключи компилятора.
После отладки вашего кода установите эти три наиболее важных ключа:
|
{$R-} {Range checking off - проверка диапазона} {$S-} {Stack checking off - проверка стека} {$A+} {Word align data - "выравнивание слов"} |
При неправильной установке этих ключей скорость может упасть больше, чем в случае когда вместо статических массивов вы используете динамические. [000494]
Как во время компиляции модуля определить, под какой версией Delphi она происходит?
Из советов Nomadic'a:
Используйте
|
{$IFDEF VERXXX} . . . {$ELSE} . . . {$ENDIF} |
Пользуйтесь вот такой таблицей: * VER80 -- Delphi 1 * VER90 -- Delphi 2 * VER93 -- C++Builder 1 * VER100 -- Delphi 3 * VER110 -- C++Builder 3 * VER120 -- Delphi 4 * VER130 -- Delphi 5 [001726]
Связывание функций
Delphi содержит очень умный компоновщик, который исключает добавление функций без внешних ссылок в ваш конечный exe-файл.
Это действительно лучшее решение, чем то, которое предлагают (старые сведения, В.О.) все C-компоновщики, компонующие все функции данного модуля (кодового файла), если хотя бы на одну из них имеется внешняя ссылка.
...я тоже так хотел. Но одна из моих форм имела "uses dll_link", где dll_link являлся компонентом, который использовал dll. Хотя компонент и был удален из формы, программа сбоила, если на машине отсутствовала нужная DLL. Естественно, компоновщик удалил весь неиспользуемый код, но почему проблема осталась? Удаление "uses dll_link" решило проблему, и уменьшило размер exe на 100k. Очевидно, компоновщик не может это удалить сам.
Я так полагаю, что "умный" компоновщик ("Smart Linking") недостаточно умен для удаления ссылок на модули, в которых нет функций со внешними ссылками. Может, он делает это намеренно, но пока не ясно почему.
...я тоже задавался этим вопросом: почему, удаляя ссылки на ненужные мне модули, которые Delphi устанавливает по-умолчанию, размер выходного файла уменьшается - почему??? Что делает в это время умный оптимизатор - компилятор?
Я провел тест опции Delphi "Smart Linking" (умное связывание). Я создал пустое приложение, одно окно, ничего более. В обработчик события FormCreate я поместил две переменные и проинициализировал их: первая представляла собой строку, куда я поместил 'Привет!', вторая была Hwnd, куторой я присвоил дескриптор ("handle").
Я создал второй модуль. В этот модуль я включил ссылки на SysUtils, WinTypes и WinProcs. Я создал функцию с именем "This". "This" получает на входе два параметра: Hwnd и String. Она преобразует строку к типу C-строки, и вызывает MessageBox. Я захотел сделать так, чтобы функция "This" все-таки не была тривиальной (ну хорошо, она тривиальная).
Важным является то, что у меня в моей программе нет ни одного места, откуда бы я вызывал "This". В список модуля формы "uses" я поместил ссылку на второй модуль (где расположена функция "This"), но при этом функция "This" нигде не вызывается.
Я собрал приложение, и запомнил размер exe-файла.
Затем я создал обработчик события FormCreate. В нем я вызывал "This" с переменными, инициализированными ранее (строка и дескриптор окна).
Я собрал приложение, и запомнил размер exe-файла.
Во втором случае (с вызовом функции "This") exe-файл получился больше на 300 байт. Из этого следует, что неиспользуемые функции не линкуются к exe-файлу.
Опция "Optimize for size and load time" (оптимизировать для размера и времени загрузки) весьма отличается от опции "smart-linking" (умное связывание). Очевидно, большинство компоновщиков сами по себе являются "умными машинками". Их технологию работы сложно понять, и это является самым строгим секретом фирмы. Некоторые теоретические выкладки можно почерпнуть из статьи, напечатанной в журнале MicroSoft Systems Journal, Июль 1993, статья называется "Liposuction your Corpulent Executables and Remove Excess Fat". Ее можно также найти на CD MSDN, если он у вас, конечно, имеется. По-крайней мере, в статье есть интересный раздел, посвященный технологии выравнивания ("alignment"), которую можно сравнить с проблемой выбора размера кластера в момент создания раздела на диске. Эта технология позволяет сэкономить, или потерять свободное место на диске при большом количестве файлов. В вопросе оптимизации существует масса мелочей. Во всяком случае, "Optimize for size and load time" выполняет ту же работу, что и прорамма W8LOSS.EXE (расположенной в каталоге \Delphi\Bin) с вашим скомпилированным приложением.
Вам нужно помнить об одной вещи: если компоновщик настроен на "умное связывание", то он не будет запускать приложение чтобы посмотреть, используется ли функция/процедура, или нет. В этом случае он проверяет на "возможность" использования той или иной функции/процедуры. Я не проверял это, но, вероятно, даже в VCL наверняка существуют методы, которые включены в ее только потому, что существует "возможность" их применения, и они "тянутся" при компиляции в ваше приложение.
Кроме того, для подтверждения моей мысли, я просто создал приложение с одной формой, работающее с базой данных и имевшее размер более 500Кб, после добавления к которому нескольких форм размер приложения не увеличился.
Типы не линкуются. Они используются только самим компилятором. Переменные "умным" компилятором не удаляются. Код, расположенный в секции initialization вызывается всегда. Процесс компиляции программ Delphi состоит из двух шагов: во-первых, компилируются все модули программы, после чего получаются двоичные промежуточные .DCU-файлы. Во-вторых, они полностью связываются все вместе и получается .EXE-файл. Во время второго шага удаляются любые функции/процедуры без внешних ссылок. Поэтому нет повода для беспокойства: ВСЕ функции, которые присутствуют в программе, будует помещены в .DCU-файл, и только те из них, которые реально используются, будут упакованы в EXE. Все будет работать именно так, как вы и ожидаете, нет никаких сюрпризов, в противном случае это связывание не будет 'smart' (умным), и эту опцию можно не включать. [001793]
