Пример FTP сервера
Пример FTP сервера
unitUnit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdBaseComponent, IdComponent, IdUDPBase, IdUDPServer,
IdTrivialFTPServer, StdCtrls, IdUDPClient, IdTrivialFTP;
type
TForm1 = class(TForm)
IdTrivialFTPServer1: TIdTrivialFTPServer;
IdTrivialFTP1: TIdTrivialFTP;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure IdTrivialFTPServer1ReadFile(Sender: TObject;
var FileName: string; const PeerInfo: TPeerInfo;
var GrantAccess: Boolean; var AStream: TStream;
var FreeStreamOnComplete: Boolean);
procedure IdTrivialFTPServer1TransferComplete(Sender: TObject;
const Success: Boolean; const PeerInfo: TPeerInfo; AStream: TStream;
const WriteOperation: Boolean);
procedure IdTrivialFTPServer1WriteFile(Sender: TObject;
var FileName: string; const PeerInfo: TPeerInfo;
var GrantAccess: Boolean; var AStream: TStream;
var FreeStreamOnComplete: Boolean);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
TFTPPath: string;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
IdTrivialFTPServer1.ThreadedEvent := True;
IdTrivialFTPServer1.Active := True;
{ Set the path to where the files will be stored/retreived }
TFTPPath := IncludeTrailingPathDelimiter('C:\Temp');
end;
procedure TForm1.IdTrivialFTPServer1ReadFile(Sender: TObject;
var FileName: string; const PeerInfo: TPeerInfo;
var GrantAccess: Boolean; var AStream: TStream;
var FreeStreamOnComplete: Boolean);
var
FS: TFileStream;
begin
FreeStreamOnComplete := True;
try
{ Convert UNIX style filenames to WINDOWS style }
while Pos('/', Filename) <> 0 do
Filename[Pos('/', Filename)] := '\';
{ Assure that the filename DOES NOT CONTAIN any path information }
Filename := ExtractFileName(Filename);
{ Check if file exists }
if FileExists(TFTPPath + Filename) then
begin
{ Open file in READ ONLY mode }
FS := TFileStream.Create(TFTPPath + Filename,
fmOpenRead or fmShareDenyWrite);
{ Assign stream to variable }
AStream := FS;
{ Set parameters }
GrantAccess := True;
end
else
begin
GrantAccess := False;
end;
except
{ On errors, deny access }
GrantAccess := False;
if Assigned(FS) then
FreeAndNil(FS);
end;
end;
procedure TForm1.IdTrivialFTPServer1WriteFile(Sender: TObject;
var FileName: string; const PeerInfo: TPeerInfo;
var GrantAccess: Boolean; var AStream: TStream;
var FreeStreamOnComplete: Boolean);
var
FS: TFileStream;
begin
try
{ Convert UNIX style filenames to WINDOWS style }
while Pos('/', Filename) <> 0 do
Filename[Pos('/', Filename)] := '\';
{ Assure that the filename DOES NOT CONTAIN any path information }
Filename := ExtractFileName(Filename);
{ Open file in WRITE ONLY mode }
FS := TFileStream.Create(TFTPPath + Filename,
fmCreate or fmShareExclusive);
{ Copy all the data }
AStream := FS;
{ Set parameters }
FreeStreamOnComplete := True;
GrantAccess := True;
except
{ On errors, deny access }
GrantAccess := False;
if Assigned(FS) then
FreeAndNil(FS);
end;
end;
procedure TForm1.IdTrivialFTPServer1TransferComplete(Sender: TObject;
const Success: Boolean; const PeerInfo: TPeerInfo; AStream: TStream;
const WriteOperation: Boolean);
begin
// Success = TRUE if the read/write operation was successfull
// WriteOperation = TRUE if the client SENT a file to the server
try
{ Close the FileStream }
if Assigned(AStream) then
FreeAndNil(AStream);
except
end;
end;
// Example of how to DOWNLOAD a file from the server
procedure TForm1.Button1Click(Sender: TObject);
var
ST: TMemoryStream;
begin
ST := TMemoryStream.Create;
IdTrivialFTP1.Get('testfile.dat', ST);
if Assigned(ST) then
begin
ShowMessage('Filesize=' + IntToStr(ST.Size));
FreeAndNil(ST);
end;
end;
// Example of how to UPLOAD a file to the server
procedure TForm1.Button2Click(Sender: TObject);
var
ST: TMemoryStream;
I: Integer;
S: string;
begin
{ Create stream }
ST := TMemoryStream.Create;
{ Initialize data }
S := 'This is a test file. It whould appear in the ' +
'TFTP Server upload directory.' + #13#10;
{ Store in stream }
ST.Write(S[1], Length(S));
ST.Position := 0;
{ Send Stream to TFTP Server }
IdTrivialFTP1.Put(ST, 'textfile.txt');
{ Free Stream }
if Assigned(ST) then
FreeAndNil(ST);
{ Show a dialog }
ShowMessage('Done!');
end;
end.
Взято с
Delphi Knowledge BaseПример использования DirectInput для опроса клавиатуры
Пример использования DirectInput для опроса клавиатуры
{******************************************************************************
* *
* Придумал и написал Кода Виктор, Март 2002 *
* *
* Файл: main.pas *
* Содержание: Пример использования DirectInput для опроса клавиатуры *
* *
******************************************************************************}
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ComCtrls,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
gb1: TGroupBox;
gb2: TGroupBox;
gb3: TGroupBox;
lbRemark: TLabel;
imView: TImage;
rbWM: TRadioButton;
rgDI8: TRadioButton;
lbKeys: TLabel;
lbIndex: TLabel;
btnClose: TButton;
procedure FormCreate(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure Hook( var Msg: TMsg; var Handled: Boolean );
procedure Idle( Sender: TObject; var Done: Boolean );
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
DirectInput8;
//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
var
lpDI8: IDirectInput8 = nil;
lpDIKeyboard: IDirectInputDevice8 = nil;
nXPos,
nYPos: Integer;
//------------------------------------------------------------------------------
// Имя: InitDirectInput()
// Описание: Производит инициализацию объектов DirectInput в программе
//------------------------------------------------------------------------------
function InitDirectInput( hWnd: HWND ): Boolean;
begin
Result := FALSE;
// Создаём главный объект DirectInput
if FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION,
IID_IDirectInput8, lpDI8, nil ) ) then
Exit;
lpDI8._AddRef();
// Создаём объект для работы с клавиатурой
if FAILED( lpDI8.CreateDevice( GUID_SysKeyboard, lpDIKeyboard, nil ) ) then
Exit;
lpDIKeyboard._AddRef();
// Устанавливаем предопределённый формат для "простогй клавиатуры". В боль-
// шинстве случаев можно удовлетвориться и установками, заданными в структуре
// c_dfDIKeyboard по умолчанию, но в особых случаях нужно заполнить её самому
if FAILED( lpDIKeyboard.SetDataFormat( @c_dfDIKeyboard ) ) then
Exit;
// Устанавливаем уровень кооперации. Подробности о флагах смотри в DirectX SDK
if FAILED( lpDIKeyboard.SetCooperativeLevel( hWnd, DISCL_BACKGROUND or
DISCL_NONEXCLUSIVE ) ) then
Exit;
// Захвытываем клавиатуру
lpDIKeyboard.Acquire();
Result := TRUE;
end;
//------------------------------------------------------------------------------
// Имя: ReleaseDirectInput()
// Описание: Производит удаление объектов DirectInput
//------------------------------------------------------------------------------
procedure ReleaseDirectInput();
begin
// Удаляем объект для работы с клавиатурой
if lpDIKeyboard <> nil then // Можно проверить if Assigned( DIKeyboard )
begin
lpDIKeyboard.Unacquire(); // Освобождаем устройство
lpDIKeyboard._Release();
lpDIKeyboard := nil;
end;
// Последним удаляем главный объект DirectInput
if lpDI8 <> nil then
begin
lpDI8._Release();
lpDI8 := nil;
end;
end;
//------------------------------------------------------------------------------
// Имя: UpdateKeyboardState()
// Описание: Обрабатывает клавиатурный ввод методом DirectInput
//------------------------------------------------------------------------------
function UpdateKeyboardState(): Boolean;
var
bKeyBuffer: array [0..255] of Byte;
i: Integer;
hr: HRESULT;
begin
Result := FALSE;
// Производим опрос состояния клавиш, данные записываются в буфер-массив
if lpDIKeyboard.GetDeviceState( SizeOf( bKeyBuffer ), @bKeyBuffer ) = DIERR_INPUTLOST then
begin
// Захватываем снова
lpDIKeyboard.Acquire();
// Производим повторный опрос
if FAILED( lpDIKeyboard.GetDeviceState( SizeOf( bKeyBuffer ), @bKeyBuffer ) ) then
Exit;
end;
// Изменяем координаты курсора
if bKeyBuffer[ DIK_NUMPAD4 ] = $080 then Dec( nXPos );
if bKeyBuffer[ DIK_NUMPAD6 ] = $080 then Inc( nXPos );
if bKeyBuffer[ DIK_NUMPAD8 ] = $080 then Dec( nYPos );
if bKeyBuffer[ DIK_NUMPAD2 ] = $080 then Inc( nYPos );
// Выводим список кодов нажатых клавиш
with Form1.lbKeys do
begin
Caption := '';
for i := 0 to 255 do
if bKeyBuffer[ i ] = $080 then
if i <= 9 then Caption := Caption + Format( '0%d ', [ i ] )
else Caption := Caption + Format( '%d ', [ i ] );
end;
Result := TRUE;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.Hook()
// Описание: Обрабатывает клавиатурный ввод подобно главной функции окна
//------------------------------------------------------------------------------
procedure TForm1.Hook( var Msg: TMsg; var Handled: Boolean );
var
i: Integer;
begin
if Msg.message <> WM_KEYDOWN then
Exit;
// Изменяем координаты курсора
case Msg.wParam of
VK_NUMPAD4: Dec( nXPos );
VK_NUMPAD6: Inc( nXPos );
VK_NUMPAD8: Dec( nYPos );
VK_NUMPAD2: Inc( nYPos );
end;
// Выводим код нажатой клавиши
with Form1.lbKeys do
begin
Caption := '';
// Бессмысленно писать for i := 0 to 255 do ... При обработке сообщения
// WM_KEYDOWN мы можем узнать состояние только одной клавиши - ведь массив
// не используется. Справедливоси ради надо сказать, что в Windows есть
// функция GetKeyboardState(), работающая с массивом и очень быстро
if Msg.wParam <= 9 then Caption := Caption + Format( '0%d ', [ Msg.wParam ] )
else Caption := Caption + Format( '%d ', [ Msg.wParam ] );
end;
// Блокируем дальнейшую обработку события
Handled := TRUE;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.Idle()
// Описание: Вызывает функцию опроса состояния клавиатуры
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
i: Integer;
begin
if rbWM.Checked then Application.OnMessage := Hook
else
begin
Application.OnMessage := nil;
// Если данные от клавиатуры не получены
if not UpdateKeyboardState() then
begin
MessageBox( Form1.Handle, 'Потеряно устройство управления!',
'Ошибка!', MB_ICONHAND );
Form1.Close();
end;
end;
// Проверяем выход курсора за пределы диапазона
if nXPos < 0 then nXPos := 0;
if nXPos + 10 > 140 then nXPos := 130;
if nYPos < 0 then nYPos := 0;
if nYPos + 10 > 140 then nYPos := 130;
// Рисуем курсор
with imView.Canvas do
begin
FillRect( Canvas.ClipRect );
Brush.Color := clRed;
Rectangle( nXPos, nYPos, nXPos + 10, nYPos + 10 );
Brush.Color := clWhite;
end;
Done := FALSE;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormCreate()
// Описание: Производит инициализацию DirectInput при старте программы
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
if not InitDirectInput( Form1.Handle ) then
begin
MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!',
'Ошибка!', MB_ICONHAND );
ReleaseDirectInput();
Halt;
end;
// Приводим UI в соответствующий вид
lbKeys.Caption := '';
// Назначаем обработчик Idle-события. Компонент TTimer не позволит раскрыть
// всех преимуществ использования DirectInput
Application.OnIdle := Idle;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.btnCloseClick()
// Описание: Закрывает программу
//------------------------------------------------------------------------------
procedure TForm1.btnCloseClick(Sender: TObject);
begin
Form1.Close();
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormDestroy()
// Описание: Вызывается при удалении программы из памяти
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
ReleaseDirectInput();
end;
end.
Форма:
object Form1: TForm1
Left = 192
Top = 106
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'DirectInput 8: Клавиатура'
ClientHeight = 318
ClientWidth = 377
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object lbRemark: TLabel
Left = 8
Top = 8
Width = 338
Height = 13
Caption = 'Используйте num-клавиши клавиатуры для перемещения курсора'
end
object btnClose: TButton
Left = 294
Top = 288
Width = 75
Height = 23
Cancel = True
Caption = 'Закрыть'
TabOrder = 0
OnClick = btnCloseClick
end
object gb1: TGroupBox
Left = 8
Top = 32
Width = 177
Height = 177
Caption = 'Визуальная проверка'
TabOrder = 1
object imView: TImage
Left = 19
Top = 24
Width = 140
Height = 140
end
end
object gb3: TGroupBox
Left = 8
Top = 216
Width = 361
Height = 65
Caption = 'Клавиши'
TabOrder = 2
object lbKeys: TLabel
Left = 64
Top = 24
Width = 289
Height = 17
AutoSize = False
Caption = 'lbKeys'
end
object lbIndex: TLabel
Left = 8
Top = 24
Width = 49
Height = 13
Caption = 'Индексы:'
end
end
object gb2: TGroupBox
Left = 200
Top = 32
Width = 169
Height = 177
Caption = 'Способ опроса'
TabOrder = 3
object rbWM: TRadioButton
Left = 24
Top = 56
Width = 129
Height = 17
Caption = 'Windows Messaging'
Checked = True
TabOrder = 0
TabStop = True
end
object rgDI8: TRadioButton
Left = 24
Top = 104
Width = 129
Height = 17
Caption = 'DirectInput 8'
TabOrder = 1
end
end
end
Взято с сайта
Анатолия Подгорецкогопо материалам fido7.ru.delphi.*
Пример использования DirectSound на Delphi
пример использования DirectSound на Delphi
рабочий пример использования DirectSound на Delphi + несколько полезных
процедур. В этом примере создается один первичный SoundBuffer и 2
статических, вторичных; в них загружаются 2 WAV файла.
Первичный буфер создается процедурой AppCreateWritePrimaryBuffer,
а любой вторичный - AppCreateWritePrimaryBuffer. Так как
вторичный буфер связан с WAV файлом, то при создании
буфера нужно определить его параметры в соответствии
со звуковым файлом, эти характеристики (Samples, Bits, IsStereo)
задаются в виде параметров процедуры. Time - время WAV'файла
в секундах (округление в сторону увеличения).
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.
Взято с сайта
Пример массива констант (Array of Const)
Пример массива констант (Array of Const)
"Array of const" это массив переменных, декларированных как константы. Непосредственно они представлены структурой TVarRec. Скобки просто ограничивают массив. Массив констант дает вам возможность передавать процедуре переменное количество параметров type-safe (безопасным) способом. Вот пример:
type
TVarRec = record
Data: record case Integer of
0: (L: LongInt);
1: (B: Boolean);
2: (C: Char);
3: (E: ^Extended);
4: (S: ^string);
5: (P: Pointer);
6: (X: PChar);
7: (O: TObject);
end;
Tag: Byte;
Stuff: array[0..2] of Byte;
end;
function PtrToStr(P: Pointer): string;
const
HexChar: array[0..15] of Char = '0123456789ABCDEF';
function HexByte(B: Byte): string;
begin
Result := HexChar[B shr 4] + HexChar[B and 15];
end;
function HexWord(W: Word): string;
begin
Result := HexByte(Hi(W)) + HexByte(Lo(W));
end;
begin
Result := HexWord(HiWord(LongInt(P))) + ':' + HexWord(LoWord(LongInt(P)));
end;
procedure Display(X: array of const);
var
I: Integer;
begin
for I := 0 to High(X) do
with TVarRec(X[I]), Data do
begin
case Tag of
0: ShowMessage('Integer: ' + IntToStr(L));
1: if B then
ShowMessage('Boolean: True')
else
ShowMessage('Boolean: False');
2: ShowMessage('Char: ' + C);
3: ShowMessage('Float: ' + FloatToStr(E^));
4: ShowMessage('String: ' + S^);
5: ShowMessage('Pointer: ' + PtrToStr(P));
6: ShowMessage('PChar: ' + StrPas(X));
7: ShowMessage('Object: ' + O.ClassName);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
P: array[0..5] of Char;
begin
P := 'Привет'#0;
Display([-12345678, True, 'A', 1.2345, 'ABC', Ptr($1234, $5678), P,
Form1]);
end;
Взято с
Массив констант (array of const) фактически является открытым массивом TVarRec (описание предекларированных типов Delphi вы можете найти в электронной справке). Приведенный ниже "псевдокод" на языке Object Pascal может послужить скелетом для дальнейшего развития:
procedure AddStuff(const A: array of const);
var i: Integer;
begin
for i := Low(A) to High(A) do
with A[i] do
case VType of
vtExtended:
begin
{ добавляем натуральное число, все real-форматы
автоматически приводятся к extended }
end;
vtInteger:
begin
{ добавляем целое число, все integer-форматы
автоматически приводятся к LongInt }
end;
vtObject:
begin
if VObject is DArray then
with DArray(VObject) do
begin
{ добавляем массив double-типа }
end
else if VObject is IArray then
with IArray(VObject) do
begin
{ добавляем массив integer-типа }
end;
end;
end; { Case }
end; { AddStuff }
Для получения дополнительной информации загляните в главу "open arrays" электронной справки.
Взято из
Советов по Delphi от
Сборник Kuliba
Пример написания FileListBox
Пример написания FileListBox
1)WinAPI
{uses ShellApi}
procedure TForm1.ListBox1DblClick(Sender: TObject);
var s:string;
begin
s:=listbox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)];
if edit1.Text[length(edit1.text)]<>'\' then edit1.text:=concat(edit1.text+'\');
if (not FileExists(edit1.text+s)) and (s[1]='[')and(s[length(s)]=']') then
DlgDirList( handle,
PChar(edit1.text+copy(s,2,length(s)-2)),
ListBox1.Handle,
Edit1.Handle,
faAnyFile
);
if edit1.Text[length(edit1.text)]<>'\' then edit1.text:=concat(edit1.text+'\');
if FileExists(edit1.text+s) then
begin
caption:=edit1.text+s;
ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show);
end
end;
procedure TForm1.FormShow(Sender: TObject);
begin
edit1.Width:=1024*8-1;
edit1.Visible:=false;
DlgDirList(handle,
PChar('c:\'),
ListBox1.Handle,
Edit1.Handle,
faAnyFile
);
listbox1.Sorted:=false;
listbox1.Sorted:=true;
end;
2)
{uses ShellAPI}
type PListBox=^TListBox;
Procedure FillList(List:PListBox;pathh,mask:string;attr:Cardinal);
var path:string;
ser:TSearchRec;
begin
path:=pathh;
if path[length(path)]<>'\' then path:=path+'\';
List^.Items.Clear;
if FindFirst(path+mask,attr,ser)<>0 then exit;
List^.Items.Add(ser.Name);
while FindNext(ser)=0 do
begin
if ser.Attr and faDirectory=faDirectory then
List^.Items.Add(' ['+Ser.Name+']')
else
List^.Items.Add(Ser.Name);
end;
List^.Sorted:=false;
list^.Sorted:=true;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FillList(@ListBox1,edit1.text,'*.*',faAnyFile);
end;
procedure TForm1.ListBox1DblClick(Sender: TObject);
var s:string;
begin
s:=ListBox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)];
if (not FileExists(edit1.text+s)) and (s[1]+s[2]=' [') and (s[length(s)]=']') then
begin
FillList(@ListBox1,edit1.text+copy(s,3,length(s)-3),'*.*',faAnyFile);
edit1.text:=edit1.text+copy(s,3,length(s)-3)+'\';
end;
if FileExists(edit1.text+s) then
ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show);
end;
Добавим иконки:
{uses ShellAPI}
type PListBox=^TListBox;
Procedure FillList(List:PListBox;pathh,mask:string;attr:Cardinal);
var path:string;
ser:TSearchRec;
begin
path:=pathh;
if path[length(path)]<>'\' then path:=path+'\';
List^.Items.Clear;
if FindFirst(path+mask,attr,ser)<>0 then exit;
List^.Items.Add(ser.Name);
while FindNext(ser)=0 do
begin
if ser.Attr and faDirectory=faDirectory then
List^.Items.Add(' ['+Ser.Name+']')
else
List^.Items.Add(Ser.Name);
end;
List^.Sorted:=false;
list^.Sorted:=true;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FillList(@ListBox1,edit1.text,'*.*',faAnyFile);
listbox1.itemheight:=18;
end;
procedure TForm1.ListBox1DblClick(Sender: TObject);
var s:string;
Icon:hIcon;
IconIndex:word;
begin
IconIndex:=1;
s:=ListBox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)];
if (not FileExists(edit1.text+s)) and (s[1]+s[2]=' [') and (s[length(s)]=']') then
begin
FillList(@ListBox1,edit1.text+copy(s,3,length(s)-3),'*.*',faAnyFile);
edit1.text:=edit1.text+copy(s,3,length(s)-3)+'\';
end;
if FileExists(edit1.text+s) then
ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show);
end;
procedure TForm1.Button1Click(Sender: TObject);
var a:array of integer;
i:integer;
begin
SetLength(a,ListBox1.Items.Count+1);
//ZeroMemory(@a,ListBox1.Items.Count*4);
for i:=0 to ListBox1.Items.Count+1 do
a[i]:=10;
beep;
beep;
beep;
beep;
beep;
SendMessage(ListBox1.Handle,lb_SetTabStops,ListBox1.Items.Count,Integer(@a));
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var icon:hIcon;
iconindex:word;
bm:TBitmap;
begin
iconindex:=1;
bm:=TBitmap.create;
bm.Width:=34;
bm.Height:=34;
ListBox1.Canvas.TextOut(17+Rect.Left,Rect.Top,ListBox1.Items[index]);
if (copy(ListBox1.Items[index],1,2)=' [') and
(not FileExists(edit1.text+ListBox1.Items[Index])) then
begin
Icon := ExtractAssociatedIcon(HInstance,
PChar(edit1.text+copy(ListBox1.Items[Index],3,length(ListBox1.Items[Index])-3)),
IconIndex);
DrawIcon(bm.Canvas.Handle, 0, 0, Icon);
bm.Canvas.StretchDraw(classes.rect(0,0,16,16),bm);
ListBox1.Canvas.CopyRect(classes.rect(0,rect.top,16,rect.top+16),bm.canvas,classes.rect(0,0,16,16));
end
else
begin
Icon := ExtractAssociatedIcon(HInstance,
PChar(edit1.text+ListBox1.Items[Index]),
IconIndex);
DrawIcon(bm.Canvas.Handle, 0, 0, Icon);
bm.Canvas.StretchDraw(classes.rect(0,0,16,16),bm);
ListBox1.Canvas.CopyRect(classes.rect(0,rect.top,16,rect.top+16),bm.canvas,classes.rect(0,0,16,16));
end;
bm.Free;
CloseHandle(Icon);
end;
procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
ListBox1.Repaint;
end;
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var k:word;
begin
k:=0;
Listbox1.OnKeyDown(sender,k,shift);
end;
Автор ответа: Mikel
Взято с Vingrad.ru
Пример опроса мыши методами DirectInput
Пример опроса мыши методами DirectInput
(******************************************************************************
* *
* Придумал и написал Кода Виктор, Март 2002 *
* *
* Файл: main.pas *
* Содержание: Пример буферизированного опроса мыши методами DirectInput *
* *
******************************************************************************)
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
ExtCtrls;
type
TForm1 = class(TForm)
gb1: TGroupBox;
lbX0: TLabel;
lbY0: TLabel;
lbX: TLabel;
lbY: TLabel;
lb1: TLabel;
lb2: TLabel;
lb3: TLabel;
lb4: TLabel;
lbBtn1: TLabel;
lbBtn2: TLabel;
lbBtn3: TLabel;
lbBtn4: TLabel;
imCursor: TImage;
procedure FormActivate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure Idle( Sender: TObject; var Done: Boolean );
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
DirectInput8;
//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
var
lpDI8: IDirectInput8 = nil;
lpDIMouse: IDirectInputDevice8 = nil;
mouseX: LongInt = 0;
mouseY: LongInt = 0;
//------------------------------------------------------------------------------
// Имя: InitDirectInput()
// Описание: Производит инициализацию объектов DirectInput в программе
//------------------------------------------------------------------------------
function InitDirectInput( hWnd: HWND ): Boolean;
var
dipropdw: TDIPROPDWORD; // Структура для задания характеристик мыши
begin
Result := FALSE;
// Создаём главный объект DirectInput
if FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION,
IID_IDirectInput8, lpDI8, nil ) ) then
Exit;
lpDI8._AddRef();
// Создаём объект для работы с мышью
if FAILED( lpDI8.CreateDevice( GUID_SysMouse, lpDIMouse, nil ) ) then
Exit;
lpDIMouse._AddRef();
// Устанавлаваем предопределённый формат данных
if FAILED( lpDIMouse.SetDataFormat( @c_dfDIMouse ) ) then
Exit;
// Устанавливаем уровень кооперации
if FAILED( lpDIMouse.SetCooperativeLevel( hWnd, DISCL_FOREGROUND or
DISCL_EXCLUSIVE ) ) then
Exit;
// Подготавливаем структуру TDIPROPDWORD, она поможет установить нам
// буферизированный опрос мыши
ZeroMemory( @dipropdw, SizeOf( TDIPROPDWORD ) );
dipropdw.diph.dwSize := SizeOf( TDIPROPDWORD );
dipropdw.diph.dwHeaderSize := SizeOf( TDIPROPHEADER );
dipropdw.diph.dwObj := 0;
dipropdw.diph.dwHow := DIPH_DEVICE; // Изменяем х-ки всего устройства
dipropdw.dwData := 16; // Размер буфера для данных (по умолчанию 0)
// Устанавливаем размер буфера для мыши
if FAILED( lpDIMouse.SetProperty( DIPROP_BUFFERSIZE, dipropdw.diph ) ) then
Exit;
// Захвытываем мышь
lpDIMouse.Acquire();
Result := TRUE;
end;
//------------------------------------------------------------------------------
// Имя: ReleaseDirectInput()
// Описание: Производит удаление объектов DirectInput
//------------------------------------------------------------------------------
procedure ReleaseDirectInput();
begin
// Удаляем объект для работы с мышью
if lpDIMouse <> nil then
begin
lpDIMouse.Unacquire();
lpDIMouse._Release();
lpDIMouse := nil;
end;
// Удаляем главный объект DirectInput (всегда последним)
if lpDI8 <> nil then
begin
lpDI8._Release();
lpDI8 := nil;
end;
end;
//------------------------------------------------------------------------------
// Имя: GetMouseCaps()
// Описание: Получает характеристики мыши (определяет кол-во кнопок)
//------------------------------------------------------------------------------
procedure GetMouseCaps();
var
lpCaps: TDIDEVCAPS; // Структура для получения данных об элементах мыши
begin
// Подготавливаем структуру TDIDEVCAPS (для получения характеристик мыши)
ZeroMemory( @lpCaps, SizeOf( TDIDEVCAPS ) );
lpCaps.dwSize := SizeOf( TDIDEVCAPS );
// Получаем характеристики мыши, данные записывааются в структуру lpCaps
lpDIMouse.GetCapabilities( lpCaps );
// Приводим UI в соответствующий вид
with Form1 do
begin
if lpCaps.dwButtons > 0 then
begin
lb1.Enabled := TRUE; lbBtn1.Enabled := TRUE;
end;
if lpCaps.dwButtons > 1 then
begin
lb2.Enabled := TRUE; lbBtn2.Enabled := TRUE;
end;
if lpCaps.dwButtons > 2 then
begin
lb3.Enabled := TRUE; lbBtn3.Enabled := TRUE;
end;
if lpCaps.dwButtons > 3 then
begin
lb4.Enabled := TRUE; lbBtn4.Enabled := TRUE;
end;
end;
end;
//------------------------------------------------------------------------------
// Имя: UpdateMouseState()
// Описание: Производит опрос мыши и выводит данные в окно
//------------------------------------------------------------------------------
function UpdateMouseState( var(*по параметру*)dwX, dwY: DWORD ): Boolean;
var
od: TDIDEVICEOBJECTDATA;
dwElements: DWORD;
begin
Result := FALSE;
// Обазательно обнуляем!
dwX := 0;
dwY := 0;
dwElements := 1;
// Пока количество опрашиваемых элементов мыши (оси, кнопки, колёсики ) <> 0
while dwElements <> 0 do
begin
// Получаем данные от мыши
if lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od,
dwElements, 0 ) = DIERR_INPUTLOST then
begin
// Снова захватываем
lpDIMouse.Acquire();
// Если всё бесполезно, то выходим
if FAILED( lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od,
dwElements, 0 ) ) then
Exit;
end;
with Form1 do
begin
case od.dwOfs of
DIMOFS_X: dwX := od.dwData;
DIMOFS_Y: dwY := od.dwData;
DIMOFS_BUTTON0: if od.dwData = $080 then lbBtn1.Caption := 'Нажата'
else lbBtn1.Caption := '';
DIMOFS_BUTTON1: if od.dwData = $080 then lbBtn2.Caption := 'Нажата'
else lbBtn2.Caption := '';
DIMOFS_BUTTON2: if od.dwData = $080 then lbBtn3.Caption := 'Нажата'
else lbBtn3.Caption := '';
DIMOFS_BUTTON3: if od.dwData = $080 then lbBtn4.Caption := 'Нажата'
else lbBtn4.Caption := '';
end;
end;
end;
Result := TRUE;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.Idle()
// Описание: Вызывает функцию опроса состояния мыши
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
dwOffsX,
dwOffsY: DWORD; // Смещение мыши
begin
// Получаем данные и записываем их в offsX и offsY
if not UpdateMouseState( dwOffsX, dwOffsY ) then
begin
MessageBox( Form1.Handle, 'Потеряно устройство ввода!',
'Ошибка', MB_ICONHAND );
Form1.Close();
end;
// Вычисляем абсолютные координаты
Inc( mouseX, dwOffsX );
Inc( mouseY, dwOffsY );
lbX.Caption := Format( '%d', [ mouseX ] );
lbY.Caption := Format( '%d', [ mouseY ] );
imCursor.Left := 234 + mouseX; // 234 - координата, если мы хотим, чтобы
imCursor.Top := 234 + mouseY; // курсор был с начала работы в центре окна
Done := FALSE;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormActivate()
// Описание: Производит инициализацию DirectInput при активизации окна
//------------------------------------------------------------------------------
procedure TForm1.FormActivate(Sender: TObject);
begin
if not InitDirectInput( Form1.Handle ) then
begin
MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!',
'Ошибка!', MB_ICONHAND );
Form1.Close();
end;
// Получаем характеристики мыши (сколько кнопок?). Кстати, я не знаю - как
// определить, есть ли у мыши колёсико?
GetMouseCaps();
// Приводим UI в соответствующий вид
lbBtn1.Caption := '';
lbBtn2.Caption := '';
lbBtn3.Caption := '';
lbBtn4.Caption := '';
Application.OnIdle := Idle;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormKeyDown()
// Описание: Обрабатывает клавиатурный ввод
//------------------------------------------------------------------------------
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_ESCAPE then Form1.Close();
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormDestroy()
// Описание: Вызывается при удалении программы из памяти
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
ReleaseDirectInput();
end;
end.
Форма:
object Form1: TForm1
Left = 221
Top = 31
BorderIcons = []
BorderStyle = bsSingle
Caption =
'DirectInput 8: буферизированный опрос мыши (нажмите Esc для выхо' +
'да)'
ClientHeight = 500
ClientWidth = 500
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
KeyPreview = True
OldCreateOrder = False
Position = poScreenCenter
OnActivate = FormActivate
OnDestroy = FormDestroy
OnKeyDown = FormKeyDown
PixelsPerInch = 96
TextHeight = 13
object imCursor: TImage
Left = 234
Top = 234
Width = 32
Height = 32
AutoSize = True
Picture.Data = {
055449636F6E0000010001002020000001000800A80800001600000028000000
2000000040000000010008000000000080040000000000000000000000010000
0000000000000000800080008000000080800000008000000080800000008000
C0C0C000C0DCC000F0CAA60080808000FF00FF00FF000000FFFF000000FF0000
00FFFF000000FF00FFFFFF00F0FBFF00A4A0A000D4F0FF00B1E2FF008ED4FF00
6BC6FF0048B8FF0025AAFF0000AAFF000092DC00007AB90000629600004A7300
00325000D4E3FF00B1C7FF008EABFF006B8FFF004873FF002557FF000055FF00
0049DC00003DB900003196000025730000195000D4D4FF00B1B1FF008E8EFF00
6B6BFF004848FF002525FF000000FF000000DC000000B9000000960000007300
00005000E3D4FF00C7B1FF00AB8EFF008F6BFF007348FF005725FF005500FF00
4900DC003D00B900310096002500730019005000F0D4FF00E2B1FF00D48EFF00
C66BFF00B848FF00AA25FF00AA00FF009200DC007A00B900620096004A007300
32005000FFD4FF00FFB1FF00FF8EFF00FF6BFF00FF48FF00FF25FF00FF00FF00
DC00DC00B900B900960096007300730050005000FFD4F000FFB1E200FF8ED400
FF6BC600FF48B800FF25AA00FF00AA00DC009200B9007A009600620073004A00
50003200FFD4E300FFB1C700FF8EAB00FF6B8F00FF487300FF255700FF005500
DC004900B9003D00960031007300250050001900FFD4D400FFB1B100FF8E8E00
FF6B6B00FF484800FF252500FF000000DC000000B90000009600000073000000
50000000FFE3D400FFC7B100FFAB8E00FF8F6B00FF734800FF572500FF550000
DC490000B93D0000963100007325000050190000FFF0D400FFE2B100FFD48E00
FFC66B00FFB84800FFAA2500FFAA0000DC920000B97A000096620000734A0000
50320000FFFFD400FFFFB100FFFF8E00FFFF6B00FFFF4800FFFF2500FFFF0000
DCDC0000B9B90000969600007373000050500000F0FFD400E2FFB100D4FF8E00
C6FF6B00B8FF4800AAFF2500AAFF000092DC00007AB90000629600004A730000
32500000E3FFD400C7FFB100ABFF8E008FFF6B0073FF480057FF250055FF0000
49DC00003DB90000319600002573000019500000D4FFD400B1FFB1008EFF8E00
6BFF6B0048FF480025FF250000FF000000DC000000B900000096000000730000
00500000D4FFE300B1FFC7008EFFAB006BFF8F0048FF730025FF570000FF5500
00DC490000B93D00009631000073250000501900D4FFF000B1FFE2008EFFD400
6BFFC60048FFB80025FFAA0000FFAA0000DC920000B97A000096620000734A00
00503200D4FFFF00B1FFFF008EFFFF006BFFFF0048FFFF0025FFFF0000FFFF00
00DCDC0000B9B900009696000073730000505000F2F2F200E6E6E600DADADA00
CECECE00C2C2C200B6B6B600AAAAAA009E9E9E0092929200868686007A7A7A00
6E6E6E0062626200565656004A4A4A003E3E3E0032323200262626001A1A1A00
0E0E0E0000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000BABA00000000000000000000000000000000000000
00000000000000000000C5C5C5BA000000000000000000000000000000000000
00000000000000000000C5ABC5BA000000000000000000000000000000000000
000000000000000000C5ABC5BA00000000000000000000000000000000000000
00000000C500000000C5ABC5BA00000000000000000000000000000000000000
00000000C2C50000C5ABC5BA0000000000000000000000000000000000000000
00000000C2C3C500C5ABC5BA0000000000000000000000000000000000000000
00000000C2C3C3C5ABBABA000000000000000000000000000000000000000000
00000000C2C3C3C4C4C4C5C5BABAD30000000000000000000000000000000000
00000000C2C3C3C4C4D1D1D1BAD3000000000000000000000000000000000000
00000000C2C3C3C4C4D1D1BAD300000000000000000000000000000000000000
00000000C2C3C4C4D1D1D1D30000000000000000000000000000000000000000
00000000C2C3C4C4D1D1D3000000000000000000000000000000000000000000
00000000C2C3C4D1D1BA00000000000000000000000000000000000000000000
00000000C2C4D1D1BA0000000000000000000000000000000000000000000000
00000000C2C4D1C5000000000000000000000000000000000000000000000000
00000000C2C5C500000000000000000000000000000000000000000000000000
00000000C2C50000000000000000000000000000000000000000000000000000
00000000D0000000000000000000000000000000000000000000000000000000
00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE7FFFFFFC3FFFFF
FC3FFFFFF87FFFFF787FFFFF30FFFFFF10FFFFFF01FFFFFF001FFFFF003FFFFF
007FFFFF00FFFFFF01FFFFFF03FFFFFF07FFFFFF0FFFFFFF1FFFFFFF3FFFFFFF
7FFFFFFF}
end
object gb1: TGroupBox
Left = 360
Top = 8
Width = 129
Height = 145
Caption = 'Состояние мыши'
TabOrder = 0
object lbX0: TLabel
Left = 17
Top = 24
Width = 10
Height = 13
Caption = 'X:'
end
object lbY0: TLabel
Left = 17
Top = 40
Width = 10
Height = 13
Caption = 'Y:'
end
object lb1: TLabel
Left = 16
Top = 64
Width = 46
Height = 13
Caption = 'Кнопка1:'
Enabled = False
end
object lb2: TLabel
Left = 16
Top = 80
Width = 46
Height = 13
Caption = 'Кнопка2:'
Enabled = False
end
object lb3: TLabel
Left = 16
Top = 96
Width = 46
Height = 13
Caption = 'Кнопка3:'
Enabled = False
end
object lbBtn1: TLabel
Left = 72
Top = 64
Width = 30
Height = 13
Caption = 'lbBtn1'
Enabled = False
end
object lbBtn2: TLabel
Left = 72
Top = 80
Width = 30
Height = 13
Caption = 'lbBtn2'
Enabled = False
end
object lbBtn3: TLabel
Left = 72
Top = 96
Width = 30
Height = 13
Caption = 'lbBtn3'
Enabled = False
end
object lb4: TLabel
Left = 16
Top = 112
Width = 46
Height = 13
Caption = 'Кнопка4:'
Enabled = False
end
object lbBtn4: TLabel
Left = 72
Top = 112
Width = 30
Height = 13
Caption = 'lbBtn4'
Enabled = False
end
object lbX: TLabel
Left = 72
Top = 24
Width = 6
Height = 13
Caption = '0'
end
object lbY: TLabel
Left = 72
Top = 40
Width = 6
Height = 13
Caption = '0'
end
end
end
(******************************************************************************
* *
* Придумал и написал Кода Виктор, Март 2002 *
* *
* Файл: main.pas *
* Содержание: Пример непосредственного опроса мыши методами DirectInput *
* *
******************************************************************************)
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
ExtCtrls;
type
TForm1 = class(TForm)
gb1: TGroupBox;
lbX0: TLabel;
lbY0: TLabel;
lbX: TLabel;
lbY: TLabel;
lb1: TLabel;
lb2: TLabel;
lb3: TLabel;
lb4: TLabel;
lbBtn1: TLabel;
lbBtn2: TLabel;
lbBtn3: TLabel;
lbBtn4: TLabel;
imCursor: TImage;
lbEMail: TLabel;
procedure FormActivate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure Idle( Sender: TObject; var Done: Boolean );
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
DirectInput8;
//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
const
CURSOR_SPEED = 2.0;
var
lpDI8: IDirectInput8 = nil;
lpDIMouse: IDirectInputDevice8 = nil;
dwMouseXPos: DWORD = 0;
dwMouseYPos: DWORD = 0;
//------------------------------------------------------------------------------
// Имя: InitDirectInput()
// Описание: Производит инициализацию объектов DirectInput в программе
//------------------------------------------------------------------------------
function InitDirectInput( hWnd: HWND ): Boolean;
var
dipropdw: TDIPROPDWORD; // Структура для задания характеристик мыши
begin
Result := FALSE;
// Создаём главный объект DirectInput
if FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION,
IID_IDirectInput8, lpDI8, nil ) ) then
Exit;
lpDI8._AddRef();
// Создаём объект для работы с мышью
if FAILED( lpDI8.CreateDevice( GUID_SysMouse, lpDIMouse, nil ) ) then
Exit;
lpDIMouse._AddRef();
// Устанавлаваем предопределённый формат данных
if FAILED( lpDIMouse.SetDataFormat( @c_dfDIMouse ) ) then
Exit;
// Устанавливаем уровень кооперации
if FAILED( lpDIMouse.SetCooperativeLevel( hWnd, DISCL_FOREGROUND or
DISCL_EXCLUSIVE ) ) then
Exit;
// Захвытываем мышь
lpDIMouse.Acquire();
Result := TRUE;
end;
//------------------------------------------------------------------------------
// Имя: ReleaseDirectInput()
// Описание: Производит удаление объектов DirectInput
//------------------------------------------------------------------------------
procedure ReleaseDirectInput();
begin
// Удаляем объект для работы с мышью
if lpDIMouse <> nil then
begin
lpDIMouse.Unacquire();
lpDIMouse._Release();
lpDIMouse := nil;
end;
// Удаляем главный объект DirectInput (всегда последним)
if lpDI8 <> nil then
begin
lpDI8._Release();
lpDI8 := nil;
end;
end;
//------------------------------------------------------------------------------
// Имя: GetMouseCaps()
// Описание: Получает характеристики мыши (определяет кол-во кнопок)
//------------------------------------------------------------------------------
procedure GetMouseCaps();
var
lpCaps: TDIDEVCAPS; // Структура для получения данных об элементах мыши
begin
// Подготавливаем структуру TDIDEVCAPS (для получения характеристик мыши)
ZeroMemory( @lpCaps, SizeOf( TDIDEVCAPS ) );
lpCaps.dwSize := SizeOf( TDIDEVCAPS );
// Получаем характеристики мыши, данные записывааются в структуру lpCaps
lpDIMouse.GetCapabilities( lpCaps );
// Приводим GUI в соответствующий вид
with Form1 do
begin
if lpCaps.dwButtons > 0 then
begin
lb1.Enabled := TRUE; lbBtn1.Enabled := TRUE;
end;
if lpCaps.dwButtons > 1 then
begin
lb2.Enabled := TRUE; lbBtn2.Enabled := TRUE;
end;
if lpCaps.dwButtons > 2 then
begin
lb3.Enabled := TRUE; lbBtn3.Enabled := TRUE;
end;
if lpCaps.dwButtons > 3 then
begin
lb4.Enabled := TRUE; lbBtn4.Enabled := TRUE;
end;
end;
end;
//------------------------------------------------------------------------------
// Имя: UpdateMouseState()
// Описание: Производит опрос мыши и выводит данные в окно
//------------------------------------------------------------------------------
function UpdateMouseState( var(*по параметру*)x, y: DWORD ): Boolean;
var
ms: TDIMOUSESTATE;
begin
Result := FALSE;
// Получаем данные от мыши
if lpDImouse.GetDeviceState( SizeOf( TDIMOUSESTATE ), @ms ) = DIERR_INPUTLOST then
begin
// Снова захватываем
lpDIMouse.Acquire();
// Если всё бесполезно, то выходим
if FAILED( lpDImouse.GetDeviceState( SizeOf( TDIMOUSESTATE ), @ms ) ) then
Exit;
end;
with Form1 do
begin
// Вот так можно сделать движение курсора с переменной скоростью
if ms.lX < 0 then ms.lX := Round( ms.lX * CURSOR_SPEED ) else
if ms.lX > 0 then ms.lX := Round( ms.lX * CURSOR_SPEED );
if ms.lY < 0 then ms.lY := Round( ms.lY * CURSOR_SPEED ) else
if ms.lY > 0 then ms.lY := Round( ms.lY * CURSOR_SPEED );
x := ms.lX ;
y := ms.lY;
//------
if ms.rgbButtons[ 0 ] = $080 then lbBtn1.Caption := 'Нажата'
else lbBtn1.Caption := '';
if ms.rgbButtons[ 1 ] = $080 then lbBtn2.Caption := 'Нажата'
else lbBtn2.Caption := '';
if ms.rgbButtons[ 2 ] = $080 then lbBtn3.Caption := 'Нажата'
else lbBtn3.Caption := '';
if ms.rgbButtons[ 3 ] = $080 then lbBtn4.Caption := 'Нажата'
else lbBtn4.Caption := '';
end;
Result := TRUE;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.Idle()
// Описание: Вызывает функцию опроса состояния мыши
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
dwOffsX,
dwOffsY: DWORD; // Смещение мыши
begin
// Получаем данные и записываем их в offsX и offsY
if not UpdateMouseState( dwOffsX, dwOffsY ) then
begin
MessageBox( Form1.Handle, 'Потеряно устройство управления!',
'Ошибка!', MB_ICONHAND );
Form1.Close();
end;
// Смещаем позицию курсора
Inc( dwMouseXPos, dwOffsX );
Inc( dwMouseYPos, dwOffsY );
lbX.Caption := Format( '%d', [ dwMouseXPos ] );
lbY.Caption := Format( '%d', [ dwMouseYPos ] );
imCursor.Left := 234 + dwMouseXPos; // 234 - координата, если мы хотим, чтобы
imCursor.Top := 234 + dwMouseYPos; // курсор был с начала работы в центре окна
Done := FALSE;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormActivate()
// Описание: Производит инициализацию DirectInput при активизации окна
//------------------------------------------------------------------------------
procedure TForm1.FormActivate(Sender: TObject);
begin
if not InitDirectInput( Form1.Handle ) then
begin
MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!',
'Ошибка!', MB_ICONHAND );
Form1.Close();
end;
// Получаем характеристики мыши (сколько кнопок?). Кстати, я не знаю - как
// определить, есть ли у мыши колёсико?
GetMouseCaps();
// Приводим UI в соответствующий вид
lbBtn1.Caption := '';
lbBtn2.Caption := '';
lbBtn3.Caption := '';
lbBtn4.Caption := '';
imCursor.Left := 184; // Курсор центре окна
imCursor.Top := 184;
Application.OnIdle := Idle;
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormKeyDown()
// Описание: Обрабатывает клавиатурный ввод
//------------------------------------------------------------------------------
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_ESCAPE then Form1.Close();
end;
//------------------------------------------------------------------------------
// Имя: TForm1.FormDestroy()
// Описание: Вызывается при удалении программы из памяти
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
ReleaseDirectInput();
end;
end.
форма:
object Form1: TForm1
Left = 155
Top = 34
BorderIcons = []
BorderStyle = bsSingle
Caption =
'DirectInput 8: непосредственный опрос мыши (нажмите Esc для выхо' +
'да)'
ClientHeight = 500
ClientWidth = 500
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
KeyPreview = True
OldCreateOrder = False
Position = poScreenCenter
OnActivate = FormActivate
OnDestroy = FormDestroy
OnKeyDown = FormKeyDown
PixelsPerInch = 96
TextHeight = 13
object imCursor: TImage
Left = 234
Top = 234
Width = 32
Height = 32
AutoSize = True
Picture.Data = {
055449636F6E0000010001002020000001000800A80800001600000028000000
2000000040000000010008000000000080040000000000000000000000010000
0000000000000000800080008000000080800000008000000080800000008000
C0C0C000C0DCC000F0CAA60080808000FF00FF00FF000000FFFF000000FF0000
00FFFF000000FF00FFFFFF00F0FBFF00A4A0A000D4F0FF00B1E2FF008ED4FF00
6BC6FF0048B8FF0025AAFF0000AAFF000092DC00007AB90000629600004A7300
00325000D4E3FF00B1C7FF008EABFF006B8FFF004873FF002557FF000055FF00
0049DC00003DB900003196000025730000195000D4D4FF00B1B1FF008E8EFF00
6B6BFF004848FF002525FF000000FF000000DC000000B9000000960000007300
00005000E3D4FF00C7B1FF00AB8EFF008F6BFF007348FF005725FF005500FF00
4900DC003D00B900310096002500730019005000F0D4FF00E2B1FF00D48EFF00
C66BFF00B848FF00AA25FF00AA00FF009200DC007A00B900620096004A007300
32005000FFD4FF00FFB1FF00FF8EFF00FF6BFF00FF48FF00FF25FF00FF00FF00
DC00DC00B900B900960096007300730050005000FFD4F000FFB1E200FF8ED400
FF6BC600FF48B800FF25AA00FF00AA00DC009200B9007A009600620073004A00
50003200FFD4E300FFB1C700FF8EAB00FF6B8F00FF487300FF255700FF005500
DC004900B9003D00960031007300250050001900FFD4D400FFB1B100FF8E8E00
FF6B6B00FF484800FF252500FF000000DC000000B90000009600000073000000
50000000FFE3D400FFC7B100FFAB8E00FF8F6B00FF734800FF572500FF550000
DC490000B93D0000963100007325000050190000FFF0D400FFE2B100FFD48E00
FFC66B00FFB84800FFAA2500FFAA0000DC920000B97A000096620000734A0000
50320000FFFFD400FFFFB100FFFF8E00FFFF6B00FFFF4800FFFF2500FFFF0000
DCDC0000B9B90000969600007373000050500000F0FFD400E2FFB100D4FF8E00
C6FF6B00B8FF4800AAFF2500AAFF000092DC00007AB90000629600004A730000
32500000E3FFD400C7FFB100ABFF8E008FFF6B0073FF480057FF250055FF0000
49DC00003DB90000319600002573000019500000D4FFD400B1FFB1008EFF8E00
6BFF6B0048FF480025FF250000FF000000DC000000B900000096000000730000
00500000D4FFE300B1FFC7008EFFAB006BFF8F0048FF730025FF570000FF5500
00DC490000B93D00009631000073250000501900D4FFF000B1FFE2008EFFD400
6BFFC60048FFB80025FFAA0000FFAA0000DC920000B97A000096620000734A00
00503200D4FFFF00B1FFFF008EFFFF006BFFFF0048FFFF0025FFFF0000FFFF00
00DCDC0000B9B900009696000073730000505000F2F2F200E6E6E600DADADA00
CECECE00C2C2C200B6B6B600AAAAAA009E9E9E0092929200868686007A7A7A00
6E6E6E0062626200565656004A4A4A003E3E3E0032323200262626001A1A1A00
0E0E0E0000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000BABA00000000000000000000000000000000000000
00000000000000000000C5C5C5BA000000000000000000000000000000000000
00000000000000000000C5ABC5BA000000000000000000000000000000000000
000000000000000000C5ABC5BA00000000000000000000000000000000000000
00000000C500000000C5ABC5BA00000000000000000000000000000000000000
00000000C2C50000C5ABC5BA0000000000000000000000000000000000000000
00000000C2C3C500C5ABC5BA0000000000000000000000000000000000000000
00000000C2C3C3C5ABBABA000000000000000000000000000000000000000000
00000000C2C3C3C4C4C4C5C5BABAD30000000000000000000000000000000000
00000000C2C3C3C4C4D1D1D1BAD3000000000000000000000000000000000000
00000000C2C3C3C4C4D1D1BAD300000000000000000000000000000000000000
00000000C2C3C4C4D1D1D1D30000000000000000000000000000000000000000
00000000C2C3C4C4D1D1D3000000000000000000000000000000000000000000
00000000C2C3C4D1D1BA00000000000000000000000000000000000000000000
00000000C2C4D1D1BA0000000000000000000000000000000000000000000000
00000000C2C4D1C5000000000000000000000000000000000000000000000000
00000000C2C5C500000000000000000000000000000000000000000000000000
00000000C2C50000000000000000000000000000000000000000000000000000
00000000D0000000000000000000000000000000000000000000000000000000
00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE7FFFFFFC3FFFFF
FC3FFFFFF87FFFFF787FFFFF30FFFFFF10FFFFFF01FFFFFF001FFFFF003FFFFF
007FFFFF00FFFFFF01FFFFFF03FFFFFF07FFFFFF0FFFFFFF1FFFFFFF3FFFFFFF
7FFFFFFF}
end
object lbEMail: TLabel
Left = 8
Top = 480
Width = 195
Height = 13
Caption = 'Кода Виктор, e-mail kodavic@rambler.ru'
Font.Charset = DEFAULT_CHARSET
Font.Color = clBlue
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
end
object gb1: TGroupBox
Left = 360
Top = 8
Width = 129
Height = 145
Caption = 'Состояние мыши'
TabOrder = 0
object lbX0: TLabel
Left = 17
Top = 24
Width = 10
Height = 13
Caption = 'X:'
end
object lbY0: TLabel
Left = 17
Top = 40
Width = 10
Height = 13
Caption = 'Y:'
end
object lb1: TLabel
Left = 16
Top = 64
Width = 46
Height = 13
Caption = 'Кнопка1:'
Enabled = False
end
object lb2: TLabel
Left = 16
Top = 80
Width = 46
Height = 13
Caption = 'Кнопка2:'
Enabled = False
end
object lb3: TLabel
Left = 16
Top = 96
Width = 46
Height = 13
Caption = 'Кнопка3:'
Enabled = False
end
object lbBtn1: TLabel
Left = 72
Top = 64
Width = 30
Height = 13
Caption = 'lbBtn1'
Enabled = False
end
object lbBtn2: TLabel
Left = 72
Top = 80
Width = 30
Height = 13
Caption = 'lbBtn2'
Enabled = False
end
object lbBtn3: TLabel
Left = 72
Top = 96
Width = 30
Height = 13
Caption = 'lbBtn3'
Enabled = False
end
object lb4: TLabel
Left = 16
Top = 112
Width = 46
Height = 13
Caption = 'Кнопка4:'
Enabled = False
end
object lbBtn4: TLabel
Left = 72
Top = 112
Width = 30
Height = 13
Caption = 'lbBtn4'
Enabled = False
end
object lbX: TLabel
Left = 72
Top = 24
Width = 6
Height = 13
Caption = '0'
end
object lbY: TLabel
Left = 72
Top = 40
Width = 6
Height = 13
Caption = '0'
end
end
end
Взято с сайта Анатолия Подгорецкого
по материалам fido7.ru.delphi.*
Пример программирования com портов
Пример программирования com портов
unitTestRosh;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
PortCombo: TComboBox;
Label2: TLabel;
BaudCombo: TComboBox;
Label3: TLabel;
ByteSizeCombo: TComboBox;
Label4: TLabel;
ParityCombo: TComboBox;
Label5: TLabel;
StopBitsCombo: TComboBox;
Label6: TLabel;
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
Memo2: TMemo;
Edit2: TEdit;
Label7: TLabel;
Button2: TButton;
Label8: TLabel;
Edit3: TEdit;
procedure Button1Click(Sender: TObject);
procedure Memo2Change(Sender: TObject);
procedure Memo1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure PortComboChange(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Memo1DblClick(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
Registry;
var
hPort: THandle;
procedure TForm1.Memo1Change(Sender: TObject);
var
i: Integer;
begin
Edit1.Text := '';
for i := 1 to Length(Memo1.Text) do
Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '
end;
procedure TForm1.Memo2Change(Sender: TObject);
var
i: Integer;
begin
Edit2.Text := '';
for i := 1 to Length(Memo2.Text) do
Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '
end;
procedure TForm1.Button1Click(Sender: TObject);
var
S, D: array[0..127] of Char;
actual_bytes: Integer;
DCB: TDCB;
begin
FillChar(S, 128, #0);
FillChar(D, 128, #0);
DCB.DCBlength := SizeOf(DCB);
if not GetCommState(hPort, DCB) then
begin
ShowMessage('Can not get port state: ' + IntToStr(GetLastError));
Exit;
end;
try
DCB.BaudRate := StrToInt(BaudCombo.Text);
except
BaudCombo.Text := IntToStr(DCB.BaudRate);
end;
try
DCB.ByteSize := StrToInt(ByteSizeCombo.Text);
except
ByteSizeCombo.Text := IntToStr(DCB.ByteSize);
end;
if ParityCombo.ItemIndex > -1 then
DCB.Parity := ParityCombo.ItemIndex
else
ParityCombo.ItemIndex := DCB.Parity;
if StopBitsCombo.ItemIndex > -1 then
DCB.StopBits := StopBitsCombo.ItemIndex
else
StopBitsCombo.ItemIndex := DCB.StopBits;
if not SetCommState(hPort, DCB) then
begin
ShowMessage('Can not set new port settings: ' + IntToStr(GetLastError));
Exit;
end;
PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
StrPCopy(S, Memo1.Text);
if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then
begin
ShowMessage('Can not write to port: ' + IntToStr(GetLastError));
Exit;
end;
if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then
ShowMessage('Can not read from port: ' + IntToStr(GetLastError))
else
ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes');
Memo2.Text := D;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
with TRegistry.Create do
begin
OpenKey('Shkila', True);
WriteString('Port', PortCombo.Text);
WriteString('Baud Rate', BaudCombo.Text);
WriteString('Byte Size', ByteSizeCombo.Text);
WriteString('Parity', IntToStr(ParityCombo.ItemIndex));
WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex));
Destroy;
end;
if not CloseHandle(hPort) then
begin
ShowMessage('Can not close port: ' + IntToStr(GetLastError));
Exit;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
hPort := CreateFile(PChar(PortCombo.Text),
GENERIC_READ + GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hPort = INVALID_HANDLE_VALUE then
ShowMessage('Can not open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))
else
Button2.Hide;
end;
procedure TForm1.PortComboChange(Sender: TObject);
begin
FormDestroy(Sender);
Button2.Show;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
with TRegistry.Create do
begin
OpenKey('Shkila', True);
PortCombo.Text := ReadString('Port');
BaudCombo.Text := ReadString('Baud Rate');
ByteSizeCombo.Text := ReadString('Byte Size');
ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));
StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits'));
Destroy;
end;
end;
procedure TForm1.Memo1DblClick(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo2.Lines.Clear;
Edit1.Text := '';
Edit2.Text := '';
end;
end.
Взято с
Пример простейшего HTTP сервера
Пример простейшего HTTP сервера
unituMainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IdBaseComponent, IdComponent, IdTCPServer, IdHTTPServer, StdCtrls,
ExtCtrls, HTTPApp;
type
TfrmServer = class(TForm)
httpServer: TIdHTTPServer;
chkActive: TCheckBox;
Label1: TLabel;
edtRootFolder: TEdit;
btnGetFolder: TButton;
Label2: TLabel;
edtDefaultDoc: TEdit;
lstLog: TListBox;
Bevel1: TBevel;
btnClearLog: TButton;
procedure btnGetFolderClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure chkActiveClick(Sender: TObject);
procedure btnClearLogClick(Sender: TObject);
procedure httpServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
procedure pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
const TagString: string; TagParams: TStrings;
var ReplaceText: string);
private
procedure Log(Data: string);
procedure LogServerState;
public
end;
var
frmServer: TfrmServer;
implementation
uses
ShlObj, FileCtrl;
{$R *.DFM}
// copied from the last "Latium Software - Pascal Newsletter #33"
function BrowseCallbackProc(Wnd: HWND; uMsg: UINT;
lParam, lpData: LPARAM): Integer stdcall;
var
Buffer: array[0..MAX_PATH - 1] of char;
begin
case uMsg of
BFFM_INITIALIZED:
if lpData <> 0 then
SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData);
BFFM_SELCHANGED:
begin
SHGetPathFromIDList(PItemIDList(lParam), Buffer);
SendMessage(Wnd, BFFM_SETSTATUSTEXT, 0, Integer(@Buffer));
end;
end;
Result := 0;
end;
// copied from the last "Latium Software - Pascal Newsletter #33"
function BrowseForFolder(Title: string; RootCSIDL: integer = 0;
InitialFolder: string = ''): string;
var
BrowseInfo: TBrowseInfo;
Buffer: array[0..MAX_PATH - 1] of char;
ResultPItemIDList: PItemIDList;
begin
with BrowseInfo do
begin
hwndOwner := Application.Handle;
if RootCSIDL = 0 then
pidlRoot := nil
else
SHGetSpecialFolderLocation(hwndOwner, RootCSIDL,
pidlRoot);
pszDisplayName := @Buffer;
lpszTitle := PChar(Title);
ulFlags := BIF_RETURNONLYFSDIRS or BIF_STATUSTEXT;
lpfn := BrowseCallbackProc;
lParam := Integer(Pointer(InitialFolder));
iImage := 0;
end;
Result := '';
ResultPItemIDList := SHBrowseForFolder(BrowseInfo);
if ResultPItemIDList <> nil then
begin
SHGetPathFromIDList(ResultPItemIDList, Buffer);
Result := Buffer;
GlobalFreePtr(ResultPItemIDList);
end;
with BrowseInfo do
if pidlRoot <> nil then
GlobalFreePtr(pidlRoot);
end;
// clear log file
procedure TfrmServer.btnClearLogClick(Sender: TObject);
begin
lstLog.Clear;
end;
// got http server root folder
procedure TfrmServer.btnGetFolderClick(Sender: TObject);
var
NewFolder: string;
begin
NewFolder := BrowseForFolder('Web Root Folder', 0, edtRootFolder.Text);
if NewFolder <> '' then
if DirectoryExists(NewFolder) then
edtRootFolder.Text := NewFolder;
end;
// de-activate http server
procedure TfrmServer.chkActiveClick(Sender: TObject);
begin
if chkActive.Checked then
begin
// root folder must exists
if AnsiLastChar(edtRootFolder.Text)^ = '\' then
edtRootFolder.Text :=
Copy(edtRootFolder.Text, 1, Pred(Length(edtRootFolder.Text)));
chkActive.Checked := DirectoryExists(edtRootFolder.Text);
if not chkActive.Checked then
ShowMessage('Root Folder does not exist.');
end;
// de-/activate server
httpServer.Active := chkActive.Checked;
// log to list box
LogServerState;
// set interactive state for user fields
edtRootFolder.Enabled := not chkActive.Checked;
edtDefaultDoc.Enabled := not chkActive.Checked;
end;
// prepare !
procedure TfrmServer.FormCreate(Sender: TObject);
begin
edtRootFolder.Text := ExtractFilePath(Application.ExeName) + 'WebSite';
ForceDirectories(edtRootFolder.Text);
end;
// incoming client request for download
procedure TfrmServer.httpServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
I: Integer;
RequestedDocument, FileName, CheckFileName: string;
EHTMLParser: TPageProducer;
begin
// requested document
RequestedDocument := RequestInfo.Document;
// log request
Log('Client: ' + RequestInfo.RemoteIP + ' request for: ' + RequestedDocument);
// 001
if Copy(RequestedDocument, 1, 1) <> '/' then
// invalid request
raise Exception.Create('invalid request: ' + RequestedDocument);
// 002
// convert all '/' to '\'
FileName := RequestedDocument;
I := Pos('/', FileName);
while I > 0 do
begin
FileName[I] := '\';
I := Pos('/', FileName);
end;
// locate requested file
FileName := edtRootFolder.Text + FileName;
try
// check whether file or folder was requested
if AnsiLastChar(FileName)^ = '\' then
// folder - reroute to default document
CheckFileName := FileName + edtDefaultDoc.Text
else
// file - use it
CheckFileName := FileName;
if FileExists(CheckFileName) then
begin
// file exists
if LowerCase(ExtractFileExt(CheckFileName)) = '.ehtm' then
begin
// Extended HTML - send through internal tag parser
EHTMLParser := TPageProducer.Create(Self);
try
// set source file name
EHTMLParser.HTMLFile := CheckFileName;
// set event handler
EHTMLParser.OnHTMLTag := pgpEHTMLHTMLTag;
// parse !
ResponseInfo.ContentText := EHTMLParser.Content;
finally
EHTMLParser.Free;
end;
end
else
begin
// return file as-is
// log
Log('Returning Document: ' + CheckFileName);
// open file stream
ResponseInfo.ContentStream :=
TFileStream.Create(CheckFileName, fmOpenRead or fmShareCompat);
end;
end;
finally
if Assigned(ResponseInfo.ContentStream) then
begin
// response stream does exist
// set length
ResponseInfo.ContentLength := ResponseInfo.ContentStream.Size;
// write header
ResponseInfo.WriteHeader;
// return content
ResponseInfo.WriteContent;
// free stream
ResponseInfo.ContentStream.Free;
ResponseInfo.ContentStream := nil;
end
else if ResponseInfo.ContentText <> '' then
begin
// set length
ResponseInfo.ContentLength := Length(ResponseInfo.ContentText);
// write header
ResponseInfo.WriteHeader;
// return content
end
else
begin
if not ResponseInfo.HeaderHasBeenWritten then
begin
// set error code
ResponseInfo.ResponseNo := 404;
ResponseInfo.ResponseText := 'Document not found';
// write header
ResponseInfo.WriteHeader;
end;
// return content
ResponseInfo.ContentText := 'The document requested is not availabe.';
ResponseInfo.WriteContent;
end;
end;
end;
procedure TfrmServer.Log(Data: string);
begin
lstLog.Items.Add(DateTimeToStr(Now) + ' - ' + Data);
end;
procedure TfrmServer.LogServerState;
begin
if httpServer.Active then
Log(httpServer.ServerSoftware + ' is active')
else
Log(httpServer.ServerSoftware + ' is not active');
end;
procedure TfrmServer.pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
const TagString: string; TagParams: TStrings; var ReplaceText: string);
var
LTag: string;
begin
LTag := LowerCase(TagString);
if LTag = 'date' then
ReplaceText := DateToStr(Now)
else if LTag = 'time' then
ReplaceText := TimeToStr(Now)
else if LTag = 'datetime' then
ReplaceText := DateTimeToStr(Now)
else if LTag = 'server' then
ReplaceText := httpServer.ServerSoftware;
end;
end.
Взято с
Delphi Knowledge Baseпростейшей DLL в Delphi
Пример простейшей DLL в Delphi
Код, представленный ниже демонстрирует простейшую DLL с всего одной функцией "TestDLL". Результат этой процедуры - диалоговое окошко с текстом.
Library Test;
{ В хелпе Delphi 5 рекомендуют добавлять юнит ShareMem для улучшения управления памятью и экспортирования вызываемых строк. }
Uses ShareMem, SysUtils, Windows, Dialogs;
{$R *.RES}
Const TestConst = 'This is a tests DLL.';
{ Так же рекомендуется использовать параметр StdCall. Это позволяет сделать DLL совместимую с другими языками... }
Procedure TestDLL (TestStr : String); Stdcall
Begin
MessageDlg (TestConst + Chr (13) + Chr (13) + 'Your string is: ' + TestStr, mtInformation, [mbOk], 0);
End;
Exports TestDLL; // С таким именем процедура будет доступна в приложении...
Begin
End.
Теперь достаточно достаточно объявить в приложении процедуру из DLL и скопировать саму DLL в директорию с приложением.
Procedure TestDLL (TestStr : Sting); Stdcall; External 'Test.dll';
Взято с Исходников.ru
Пример работы чтения и сохранении wav-файлов
Пример работы чтения и сохранении wav-файлов
Статья Даниила Карапетяна ()
Сразу оговорюсь, что рассматривать я буду только PCM формат - самый простой. Wav-файл состоит из заголовка и собственно информации. В заголовке находится информация о типе файла, частоте, каналах и т.д. Сама информация состоит из массива чисел по 8 или 16 бит. Если в файле 2 канала, то значения левого и правого каналов записываются поочередно.
Для работы с заголовком удобнее всего использовать запись, расположение полей в которой будет повторять расположение информации в файле. Например, первая запись в wav-файле - это символы "RIFF". Соответственно, первое поле в записи должно быть массивом из четырех элементов типа char. Вторая запись - длина файла без 8 байт (без первых двух записей). Длина записана в четырех байтах целым числом. Поэтому взят тип longint. Так составляется эта запись. Когда нужно целое число длиной 2 байта - берется smallint.
О создании wav-файлов и хранении самой информации я расскажу в следующем выпуске.
Эта программа выводит в Memo длину wav-файла, количество каналов, частоту и количество бит на запись.
Скачать необходимые для компиляции файлы проекта можно на .
type
TWaveHeader = record
idRiff: array[0..3] of char;
RiffLen: longint;
idWave: array[0..3] of char;
idFmt: array[0..3] of char;
InfoLen: longint;
WaveType: smallint;
Ch: smallint;
Freq: longint;
BytesPerSec: longint;
align: smallint;
Bits: smallint;
end;
TDataHeader = record
idData: array[0..3] of char;
DataLen: longint;
end;
// Процедура ?тения заголовка wav-файлов
procedure ReadWaveHeader(Stream: TStream;
var SampleCount, SamplesPerSec: integer;
var BitsPerSample, Channeles: smallint);
var
WaveHeader: TWaveHeader;
DataHeader: TDataHeader;
begin
Stream.Read(WaveHeader, sizeof(TWaveHeader));
with WaveHeader do
begin
if idRiff <> 'RIFF' then raise EReadError.Create('Wrong idRIFF');
if idWave <> 'WAVE' then raise EReadError.Create('Wrong idWAVE');
if idFmt <> 'fmt ' then raise EReadError.Create('Wrong idFmt');
if WaveType <> 1 then raise EReadError.Create('Unknown format');
Channeles := Ch;
SamplesPerSec := Freq;
BitsPerSample := Bits;
Stream.Seek(InfoLen - 16, soFromCurrent);
end;
Stream.Read(DataHeader, sizeof(TDataHeader));
if DataHeader.idData = 'fact' then
begin
Stream.Seek(4, soFromCurrent);
Stream.Read(DataHeader, sizeof(TDataHeader));
end;
with DataHeader do
begin
if idData <> 'data' then raise EReadError.Create('Wrong idData');
SampleCount := DataLen div (Channeles * BitsPerSample div 8)
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenDialog1.Filter := 'Wave files|*.wav';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
F: TFileStream;
SampleCount, SamplesPerSec: integer;
BitsPerSample, Channeles: smallint;
begin
// Вызов OpenDialog1:
if not OpenDialog1.Execute then Exit;
try
// Открытие файла:
F := TFileStream.Create(OpenDialog1.FileName, fmOpenRead);
// Чтение заголовка:
ReadWaveHeader(F, SampleCount, SamplesPerSec,
BitsPerSample, Channeles);
F.Free;
Memo1.Clear;
// Заполнение Memo информацией о файле:
Memo1.Lines.Add('SampleCount: ' + IntToStr(SampleCount));
Memo1.Lines.Add(Format('Length: %5.3f sec', [SampleCount / SamplesPerSec]));
Memo1.Lines.Add('Channeles: ' + IntToStr(Channeles));
Memo1.Lines.Add('Freq: ' + IntToStr(SamplesPerSec));
Memo1.Lines.Add('Bits: ' + IntToStr(BitsPerSample));
except
raise Exception.Create('Problems with file reading');
end;
end;
Взято с Vingrad.ru
Пример работы с DrawIcon(Ex)
Пример работы с DrawIcon(Ex)
DrawIcon(Canvas.Handle, 5, 5, Application.Icon.Handle);
DrawIconEx(Canvas.Handle, 40, 40, Application.Icon.Handle, 0, 0, 0, Canvas.Brush.Handle, DI_NORMAL);
Автор cully
Взято с Vingrad.ru
Пример работы с MailSlot
Пример работы с MailSlot
procedureTForm1.Button1Click(Sender: TObject);
var
hSlot1 : THandle;
lpszSlotName: LPSTR;
begin
lpszSlotName := '\\\\.\\mailslot\\sample_mailslot';
hslot1 := CreateMailslot (lpszSlotName,
0,
MAILSLOT_WAIT_FOREVER,
nil);
//тут поидее должна быть обработка ошибки, если не удалось создать
//Далее работаем
с ним, как с файлом т.е. WriteFile и т.д.
CloseHandle(hSlot1); //а кады закрываем за собой дескриптор,
то память чистится т.е. все, что мы туда поназаписали удаляется
end;
Автор ответа: Baa
Взято с Vingrad.ru
WinAPI->Windows->Процессы...->Пример работы с MailSlot
Тут Baa немного ошибся. Он написал открытие мэйлслота в C++ стиле:
lpszSlotName := '\\\\.\\mailslot\\sample_mailslot';
а надо так:
lpszSlotName := '\\.\mailslot\sample_mailslot';
т.е. вместо \\ надо просто \
Автор p0s0l
Пример работы с SMTP
Пример работы с SMTP
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, Psock, NMsmtp;
type
TForm1 = class(TForm)
Memo: TRichEdit;
Panel1: TPanel;
SMTP: TNMSMTP;
Panel2: TPanel;
FromAddress: TEdit;
predefined: TLabel;
FromName: TEdit;
Subject: TEdit;
LocalProgram: TEdit;
ReplyTo: TEdit;
islog: TCheckBox;
Host: TEdit;
Port: TEdit;
userid: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
Procedure CleanContext;
procedure PerformConnection;
procedure AddMessage(msg:string; color:integer);
procedure log(inpt :string);
Procedure SetSMTP;
public
function SendEmail(_to, cc, bcc, Subject, body, attachment:string; HTMLFormat:boolean):boolean;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
Procedure TForm1.SetSMTP;
begin
SMTP.Host:=Host.Text;
SMTP.Port:=strtoint(Port.text);
SMTP.UserID:=userid.text;
end;
Function GetEmailDateTime:string;
var tz:_time_Zone_information;
s:string;
begin
GetTimeZoneInformation(tz);
if (tz.Bias*100 div 60)<1000 then
s:=format(' -0%d',[tz.Bias*100 div 60])
else
s:=format(' -%d',[tz.Bias*100 div 60]);
result:=formatdatetime('ddd, dd mmm yyyy hh:nn:ss',now)+s;
end;
Procedure TForm1.CleanContext;
{set default values, some of them comes from "Setup" form}
begin
SMTP.PostMessage.FromAddress:=FromAddress.text;
SMTP.PostMessage.FromName:=FromName.text;
SMTP.PostMessage.ToAddress.Clear;
SMTP.PostMessage.ToCarbonCopy.clear;
SMTP.PostMessage.ToBlindCarbonCopy.clear;
SMTP.PostMessage.Body.clear;
SMTP.PostMessage.Attachments.clear;
SMTP.PostMessage.Subject:=Subject.text;
SMTP.PostMessage.LocalProgram:=LocalProgram.text;
(*Mon, 27 Nov 2000 12:37:46 -0700*)
SMTP.PostMessage.Date:=GetEmailDateTime;
SMTP.PostMessage.ReplyTo:=ReplyTo.Text;
end;
procedure TForm1.log(inpt :string);
var outf:textfile;
begin {writing in the log file}
if not islog.checked then exit;
assignfile(outf, changefileext(paramstr(0), '.log'));
if fileexists(changefileext(paramstr(0), '.log')) then
append(outf)
else
rewrite(outf);
writeln(outf, datetimetostr(now)+'|'+inpt);
closefile(outf);
end;
procedure TForm1.AddMessage(msg:string; color:integer);
begin {showing in the memo field progress...}
while memo.lines.Count>2000 do memo.lines.Delete(0);
memo.sellength:=0;
memo.selstart:=length(memo.text);
memo.selattributes.Color:=Color;
memo.seltext:=#13#10+DateTimeTostr(now)+' '+msg;
memo.perform($00B7,0,0);
Application.ProcessMessages;
if color<>clRed then log(DateTimeTostr(now)+' '+msg) else log('Error: '+DateTimeTostr(now)+' '+msg);
end;
procedure TForm1.PerformConnection;
begin
while (not SMTP.connected) do
begin
SetSMTP;
AddMessage('Connecting to SMTP',clBlue);
application.processmessages;
try
SMTP.Connect;
AddMessage('No Errors',clBlue);
except
on e:exception do AddMessage('Error conection: '+e.message,clBlue);
end;
end;
end;
Function TForm1.SendEmail(_to, cc, bcc, Subject, body, attachment:string; HTMLFormat:boolean):boolean;
begin
PerformConnection;
result:=true;
CleanContext;
try
if (attachment<>'') and (not Fileexists(attachment)) then
begin
AddMessage('Attachment is not ready yet ('+ attachment+') ', clNavy);
sleep(300);
result:=false;
exit;
end;
SMTP.PostMessage.ToAddress.text:=StringReplace(_to, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
if cc<>'' then SMTP.PostMessage.ToCarbonCopy.text:=StringReplace(cc, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
if bcc<>'' then SMTP.PostMessage.ToBlindCarbonCopy.text:=StringReplace(bcc, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
if Subject<>'' then SMTP.PostMessage.Subject:=Subject;
if HTMLFormat then SMTP.SubType:=mtPlain else SMTP.SubType:=mtHtml;
SMTP.PostMessage.Body.Text:=Body;
if attachment<>'' then SMTP.PostMessage.Attachments.add(attachment);
AddMessage('Sending to '+ _to, clGreen);
SMTP.SendMail;
AddMessage('Complete.'+#13#10, clGreen);
except
on e:sysutils.exception do
begin
AddMessage(e.message, clRed);
result:=false;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendEmail('vit@vingrad.ru', '', '', 'test', 'body', '', False);
end;
end.
А это форма для этого примера:
object Form1: TForm1
Left = 278
Top = 108
Width = 539
Height = 480
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Memo: TRichEdit
Left = 0
Top = 0
Width = 346
Height = 420
Align = alClient
Lines.Strings = ('Memo')
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Top = 420
Width = 531
Height = 33
Align = alBottom
Caption = 'Panel1'
TabOrder = 1
object Button1: TButton
Left = 440
Top = 8
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end
object Panel2: TPanel
Left = 346
Top = 0
Width = 185
Height = 420
Align = alRight
Caption = 'Panel2'
TabOrder = 2
object predefined: TLabel
Left = 8
Top = 8
Width = 87
Height = 13
Caption = 'predefined values:'
end
object FromAddress: TEdit
Left = 24
Top = 32
Width = 121
Height = 21
TabOrder = 0
Text = 'FromAddress'
end
object FromName: TEdit
Left = 24
Top = 56
Width = 121
Height = 21
TabOrder = 1
Text = 'FromName'
end
object Subject: TEdit
Left = 24
Top = 80
Width = 121
Height = 21
TabOrder = 2
Text = 'Subject'
end
object LocalProgram: TEdit
Left = 24
Top = 104
Width = 121
Height = 21
TabOrder = 3
Text = 'LocalProgram'
end
object ReplyTo: TEdit
Left = 24
Top = 128
Width = 121
Height = 21
TabOrder = 4
Text = 'ReplyTo'
end
object islog: TCheckBox
Left = 32
Top = 168
Width = 97
Height = 17
Caption = 'islog'
TabOrder = 5
end
object Host: TEdit
Left = 24
Top = 240
Width = 121
Height = 21
TabOrder = 6
Text = 'Host'
end
object Port: TEdit
Left = 24
Top = 264
Width = 121
Height = 21
TabOrder = 7
Text = 'Port'
end
object userid: TEdit
Left = 24
Top = 288
Width = 121
Height = 21
TabOrder = 8
Text = 'userid'
end
end
object SMTP: TNMSMTP
Port = 25
ReportLevel = 0
EncodeType = uuMime
ClearParams = True
SubType = mtPlain
Charset = 'us-ascii'
Left = 296
Top = 32
end
end
Автор ответа Vit
Взято с Vingrad.ru
В следующем примере E-mail отправляется автоматически сразу после нажатия кнопки.
ЗАМЕЧАНИЕ: Вам потребуется компонент 'TNMSMTP'. Этот компонент входит в поставляется с Delphi 4 и 5 и его можно найти на закладке 'Fastnet'.
procedure TForm1.Button1Click(Sender: TObject);
begin
NMSMTP1.Host := 'smtp.mailserver.com';
NMSMTP1.UserID := 'h.abdullah';
NMSMTP1.Connect;
NMSMTP1.PostMessage.FromAddress := 'hasan@excite.com';
NMSMTP1.PostMessage.ToAddress.Text := 'someone@xmail.com';
NMSMTP1.PostMessage.Body.Text := 'Текст письма';
NMSMTP1.PostMessage.Subject := 'Тема письма';
NMSMTP1.SendMail;
end;
Взято с Исходников.ru
Пример работы с указателями
Пример работы с указателями
var
p1 : ^String;
s1 : String;
begin
s1 := 'NotTest';
new (p1);
p1 := @s1;
p1^ := 'Test';
Label1.Caption := s1
Автор ответа: Baa
Взято с Vingrad.ru
Пример шифрования данных
Пример шифрования данных
procedure DoEncode(var Source:String; const Key:string);
asm
Push ESI
Push EDI
Push EBX
Or EAX,EAX
Jz @Done
Push EAX
Push EDX
Call UniqueString
Pop EDX
Pop EAX
Mov EDI,[EAX]
Or EDI,EDI
Jz @Done
Mov ECX,[EDI-4]
Jecxz @Done
Mov ESI,EDX
Or ESI,ESI
Jz @Done
Mov EDX,[ESI-4]
Dec EDX
Js @Done
Mov EBX,EDX
Mov AH,DL
Cld
@L1:
Test AH,8
Jnz @L3
Xor AH,1
@L3:
Not AH
Ror AH,1
Mov AL,[ESI+EBX]
Xor AL,AH
Xor AL,[EDI]
Stosb
Dec EBX
Jns @L2
Mov EBX,EDX
@L2:
Dec ECX
Jnz @L1
@Done:
Pop EBX
Pop EDI
Pop ESI
end;
Автор ответа:Vit
Взято с Vingrad.ru
Комментарий от Chingachguk'a:
Мне кажется, у этого алгоритма есть два недостатка:
1) Код, сильно зависимый от компилятора. Далеко не всегда
регистр EAX будет указывать на ячейку с адресом Source,
а регистр EDX - на пароль(Key). Но это мелочь.
2) Единственный байт гаммы(или ксорирующей последовательности),
который меняется при шифровании - это длина пароля. Остальные
символы пароля НИКАК НЕ ПЕРЕМЕШИВАЮТСЯ в ходе шифрования. Алгоритм
шифрования примерно такой:
Len:=Lengh(Key);
Index:=Lengh(Key)-1;
i:=1;
repeat
Len:=func1(Len);
Source[i]:=(Key[Index] xor Len) xor Source[i];
dec(Index);
if Index:=0 then Index:=Lengh(Key)-1;
until i<Lenght(Source);
Нетрудно видеть, что основной для тупого подбора является
длина пароля. Пусть она равна 10. Очевидно, что 1-ый,11,21..
символы будут зашифрованы ОДИНАКОВЫМ значением Key[Index],
но разными значениями Len. Казалось бы, Len для 1,11,21...
будет разным, но это ерунда - ведь Len вычисляется однозначно
на ЛЮБОМ шаге через реккурентный закон func1 !
И это - фатальный недостаток.
Информацию по шифрованию можно найти на
Автор ответа: Shaman
Взято с Vingrad.ru
Пример вычисления контрольной суммы (CRC32)
function CRC32(const IniCRC:Integer;Source:AnsiString):Integer;
asm
Push EBX
Push ESI
Push EDI
Or EDX,EDX
Jz @Done
Mov ESI,EDX
Mov ECX,[EDX-4]
Jecxz @Done
Lea EDI,@CRCTbl
Mov EDX,EAX
Xor EAX,EAX
Cld
@L1:
Lodsb
Mov EBX,EDX
Xor EBX,EAX
And EBX,$FF
Shl EBX,2
Shr EDX,8
And EDX,$FFFFFF
Xor EDX,[EDI+EBX]
Dec ECX
Jnz @L1
Mov EAX,EDX
@Done:
Pop EDI
Pop ESI
Pop EBX
Ret
@CRCTbl:
DD $00000000, $77073096, $ee0e612c, $990951ba
DD $076dc419, $706af48f, $e963a535, $9e6495a3
DD $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988
DD $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91
DD $1db71064, $6ab020f2, $f3b97148, $84be41de
DD $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7
DD $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec
DD $14015c4f, $63066cd9, $fa0f3d63, $8d080df5
DD $3b6e20c8, $4c69105e, $d56041e4, $a2677172
DD $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b
DD $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940
DD $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59
DD $26d930ac, $51de003a, $c8d75180, $bfd06116
DD $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f
DD $2802b89e, $5f058808, $c60cd9b2, $b10be924
DD $2f6f7c87, $58684c11, $c1611dab, $b6662d3d
DD $76dc4190, $01db7106, $98d220bc, $efd5102a
DD $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433
DD $7807c9a2, $0f00f934, $9609a88e, $e10e9818
DD $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01
DD $6b6b51f4, $1c6c6162, $856530d8, $f262004e
DD $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457
DD $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c
DD $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65
DD $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2
DD $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb
DD $4369e96a, $346ed9fc, $ad678846, $da60b8d0
DD $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9
DD $5005713c, $270241aa, $be0b1010, $c90c2086
DD $5768b525, $206f85b3, $b966d409, $ce61e49f
DD $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4
DD $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad
DD $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a
DD $ead54739, $9dd277af, $04db2615, $73dc1683
DD $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8
DD $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1
DD $f00f9344, $8708a3d2, $1e01f268, $6906c2fe
DD $f762575d, $806567cb, $196c3671, $6e6b06e7
DD $fed41b76, $89d32be0, $10da7a5a, $67dd4acc
DD $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5
DD $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252
DD $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b
DD $d80d2bda, $af0a1b4c, $36034af6, $41047a60
DD $df60efc3, $a867df55, $316e8eef, $4669be79
DD $cb61b38c, $bc66831a, $256fd2a0, $5268e236
DD $cc0c7795, $bb0b4703, $220216b9, $5505262f
DD $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04
DD $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d
DD $9b64c2b0, $ec63f226, $756aa39c, $026d930a
DD $9c0906a9, $eb0e363f, $72076785, $05005713
DD $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38
DD $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21
DD $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e
DD $81be16cd, $f6b9265b, $6fb077e1, $18b74777
DD $88085ae6, $ff0f6a70, $66063bca, $11010b5c
DD $8f659eff, $f862ae69, $616bffd3, $166ccf45
DD $a00ae278, $d70dd2ee, $4e048354, $3903b3c2
DD $a7672661, $d06016f7, $4969474d, $3e6e77db
DD $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0
DD $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9
DD $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6
DD $bad03605, $cdd70693, $54de5729, $23d967bf
DD $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94
DD $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
end;
Автор ответа: Vit
Взято с Vingrad.ru
Пример вызова TUTILITY DLL из Delphi?
Пример вызова TUTILITY DLL из Delphi?
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.
Взято из
Советов по Delphi от
Сборник Kuliba
Пример загрузки файлов в ListView с иконками
Пример загрузки файлов в ListView с иконками
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, comctrls,
StdCtrls;
type
TForm1 = class(TForm)
ListView1: TListView;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure SaveListViewToFile(AListView: TListView; sFileName: string);
procedure LoadListViewToFile(AListView: TListView; sFileName: string);
public
end;
const
Msg1 = 'File "%s" does not exist!';
Msg2 = '"%s" is not a ListView file!';
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.SaveListViewToFile(AListView: TListView; sFileName: string);
var
idxItem, idxSub, IdxImage: Integer;
F: TFileStream;
pText: PChar;
sText: string;
W, ItemCount, SubCount: Word;
MySignature: array [0..2] of Char;
begin
//Initialization
with AListView do
begin
ItemCount := 0;
SubCount := 0;
//****
MySignature := 'LVF';
// ListViewFile
F := TFileStream.Create(sFileName, fmCreate or fmOpenWrite);
F.Write(MySignature, SizeOf(MySignature));
if Items.Count = 0 then
// List is empty
ItemCount := 0
else
ItemCount := Items.Count;
F.Write(ItemCount, SizeOf(ItemCount));
if Items.Count > 0 then
begin
for idxItem := 1 to ItemCount do
begin
with Items[idxItem - 1] do
begin
//Save subitems count
if SubItems.Count = 0 then SubCount := 0 else SubCount := Subitems.Count;
F.Write(SubCount, SizeOf(SubCount));
//Save ImageIndex
IdxImage := ImageIndex;
F.Write(IdxImage, SizeOf(IdxImage));
//Save Caption
sText := Caption;
w := Length(sText);
pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText));
F.Write(w, SizeOf(w));
F.Write(pText^, w);
StrDispose(pText);
if SubCount > 0 then
begin
for idxSub := 0 to SubItems.Count - 1 do
begin
//Save Item's subitems
sText := SubItems[idxSub];
w := Length(sText);
pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText));
F.Write(w, SizeOf(w));
F.Write(pText^, w);
StrDispose(pText);
end;
end;
end;
end;
end;
F.Free;
end;
end;
procedure TForm1.LoadListViewToFile(AListView: TListView; sFileName: string);
var
F: TFileStream;
IdxItem, IdxSubItem, IdxImage: Integer;
W, ItemCount, SubCount: Word;
pText: PChar;
PTemp: PChar;
MySignature: array [0..2] of Char;
sExeName: string;
begin
with AListView do
begin
ItemCount := 0;
SubCount := 0;
sExeName := ExtractFileName(sFileName);
if not FileExists(sFileName) then
begin
MessageBox(Handle, PChar(Format(Msg1, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit;
end;
F := TFileStream.Create(sFileName, fmOpenRead);
F.Read(MySignature, SizeOf(MySignature));
if MySignature <> 'LVF' then
begin
MessageBox(Handle, PChar(Format(Msg2, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit;
end;
F.Read(ItemCount, SizeOf(ItemCount));
Items.Clear;
for idxItem := 1 to ItemCount do
begin
with Items.Add do
begin
//Read imageindex
F.Read(SubCount, SizeOf(SubCount));
//Read imageindex
F.Read(IdxImage, SizeOf(IdxImage));
ImageIndex := IdxImage;
//Read the Caption
F.Read(w, SizeOf(w));
pText := StrAlloc(w + 1);
pTemp := StrAlloc(w + 1);
F.Read(pTemp^, W);
StrLCopy(pText, pTemp, W);
Caption := StrPas(pText);
StrDispose(pTemp);
StrDispose(pText);
if SubCount > 0 then
begin
for idxSubItem := 1 to SubCount do
begin
F.Read(w, SizeOf(w));
pText := StrAlloc(w + 1);
pTemp := StrAlloc(w + 1);
F.Read(pTemp^, W);
StrLCopy(pText, pTemp, W);
Items[idxItem - 1].SubItems.Add(StrPas(pText));
StrDispose(pTemp);
StrDispose(pText);
end;
end;
end;
end;
F.Free;
end;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
// Save Items and Clear the ListView
SaveListViewToFile(ListView1, 'MyListView.sav');
ListView1.Items.Clear;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
// Load Items
LoadListViewToFile(ListView1, 'MyListView.sav');
end;
Автор ответа: Song
Взято с Vingrad.ru
Пример запуска макроса в MS WinWord
Пример запуска макроса в MS WinWord
vvWord:= CreateOleObject('Word.Application.8');
vvWord.Application.Visible:=true;
vvWord.Documents.Open( TempFileName );
vvWord.ActiveDocument.SaveAs( FileName, 1 ); // as .DOC
vvWord.Application.Run( 'Macros Name' );
Примеры использования Drag and Drop для различных визуальных компонентов
Примеры использования Drag and Drop для различных визуальных компонентов
Перетаскивание информации с помощью мыши стало стандартом для программ, работающих в Windows. Часто это бывает удобно и позволяет добиться более быстрой работы. В данной статье я постарался показать максимальное количество примеров использования данной технологии при разработке приложений в среде Delphi. Конечно, результат может быть достигнут различными путями, продемонстрированные приемы не являются единственными и, возможно, не всегда самые оптимальные, но вполне работоспособны, и указывают направление поиска. Надеюсь, что они побудят начинающих программистов к более широкому использованию Drag'n'Drop в своих программах, тем более что пользователи, особенно неопытные, быстро привыкают к перетаскивание и часто его применяют.
Проще всего делать Drag из тех компонентов, для которых однозначно ясно, что именно перетаскивать. Для этого устанавливаем у источника DragMode = dmAutomatic, а у приемника пишем обработчики событий OnDragOver - разрешение на прием, и OnDragDrop - действия, производимые при окончании перетаскивания.
procedure TForm1.StringGrid2DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := Source = Edit1;
// разрешено перетаскивание только из Edit1,
// при работе программы меняется курсор
end;
procedure TForm1.StringGrid2DragDrop(Sender, Source: TObject; X,
Y: Integer);
var
ACol, ARow: Integer;
begin
StringGrid2.MouseToCell( X, Y, ACol, ARow);
// находим, над какой ячейкой произвели Drop
StringGrid2.Cells[ Acol, Arow] := Edit1.Text;
// записываем в нее содержимое Edit1
end;
Теперь рассмотрим копирование в упорядоченный список ListBox1 из другого списка. В OnDragOver проверяем, выбран ли хоть один элемент в источнике:
Accept := (Source = ListBox2) and (ListBox2.ItemIndex >= 0);
В OnDragDrop ищем отмеченные в источнике строки (установлен множественный выбор) и добавляем только те, которых еще нет в приемнике:
for i := 0 to ListBox2.Items.Count - 1 do
if (ListBox2.Selected[i]) and (ListBox1.Items.IndexOf(ListBox2.Items[i])<0)
then
ListBox1.Items.Add(ListBox2.Items[i]);
Для ListBox2 реализуем перенос строк из ListBox1 и перестановку элементов в желаемом порядке. В OnDragOver разрешаем Drag из любого ListBox:
Accept := (Source is TListBox) and ((Source as TListBox).ItemIndex >= 0);
А OnDragDrop будет выглядеть так:
var
s: string;
begin
if Source = ListBox1 then
begin
ListBox2.Items.Add(ListBox1.Items[ListBox1.ItemIndex]);
ListBox1.Items.Delete(ListBox1.ItemIndex);
//удаляем перенесенный элемент
end
else //внутренняя перестановка
begin
s := ListBox2.Items[ListBox2.ItemIndex];
ListBox2.Items.Delete(ListBox2.ItemIndex);
ListBox2.Items.Insert(ListBox2.ItemAtPos(Point(X, Y), False), s);
//находим, в какую позицию переносить и вставляем
end;
end;
Научимся переносить текст в Memo, вставляя его в нужное место. Поскольку я выбрал в качестве источника любой из ListBox, подключим в Инспекторе Объектов для OnDragOver уже написанный ранее обработчик ListBox2DragOver, а в OnDragDrop напишем
if not CheckBox1.Checked then // при включении добавляется в конец текста
begin
Memo1.SelStart := LoWord(Memo1.Perform(EM_CHARFROMPOS, 0, MakeLParam(X,Y)));
// устанавливаем позицию вставки согласно координатам мыши
Memo1.SelText := TListBox(Source).Items[TListBox(Source).ItemIndex];
end
else
memo1.lines.add(TListBox(Source).Items[TListBox(Source).ItemIndex]);
Замечу, что для RichEdit EM_CHARFROMPOS работает несколько иначе, что продемонстрировано в следующем примере. Перенос из Memo реализован с помощью правой кнопки мыши, для того, чтобы не изменять стандартное поведение Memo, и поскольку нажатие левой кнопки снимает выделение. Для Memo1 установлено DragMode = dmManual, а перетаскивание инициируется в OnMouseDown
if (Button = mbRight) and (Memo1.SelLength > 0) then
Memo1.BeginDrag(True);
Обработчик RichEdit1DragOver очевиден, а в RichEdit1DragDrop пишем
var
p: tpoint;
begin
if not CheckBox1.Checked then
begin
p := point(x, y);
RichEdit1.SelStart := RichEdit1.Perform(EM_CHARFROMPOS, 0, Integer(@P));
RichEdit1.SelText := Memo1.SelText;
end
else
RichEdit1.Lines.Add(Memo1.SelText);
end;
Рассмотрим теперь перетаскивание в ListView1 (ViewStyle = vsReport). В OnDragOver разрешим прием из ListBox2 и из себя же:
Accept := ((Source = ListBox2) and (ListBox2.ItemIndex >= 0)) or
(Source = Sender);
А вот OnDragDrop теперь будет посложнее
var
Item, CurItem: TListItem;
begin
if Source = ListBox2 then
begin
Item := ListView1.DropTarget;
if Item <> nil then
// случай перетаскивания на Caption
if Item.SubItems.Count = 0 then
Item.SubItems.Add(ListBox2.Items[ListBox2.ItemIndex])
// добавляем SubItem, если их еще нет
else
Item.SubItems[0]:=ListBox2.Items[ListBox2.ItemIndex]
// иначе заменяем имеющийся SubItem
else
begin
// при перетаскивании на пустое место создаем новый элемент
Item := ListView1.Items.Add;
Item.Caption := ListBox2.Items[ListBox2.ItemIndex];
end;
end
else // случай внутренней перестановки
begin
CurItem := ListView1.Selected;
// запомним выбранный элемент
Item := ListView1.GetItemAt(x, y);
// другой метод определения элемента на который делаем Drop
if Item <> nil then
Item := ListView1.Items.Insert(Item.Index)
// вставляем новый элемент перед найденным
else
Item := ListView1.Items.Add;
// или добавляем новый элемент в конец
Item.Assign(CurItem);
// копируем исходный в новый
CurItem.Free;
// уничтожаем исходный
end;
end;
Для ListView2 установим ViewStyle = vsSmallIcon и покажем, как вручную расставлять значки. В OnDragOver зададим условие
Accept := (Sender = Source) and
([htOnLabel,htOnItem, htOnIcon] * ListView2.GetHitTestInfoAt(x, y) = []);
// пересечение множеств должно быть пустым - запрещаем накладывать элементы
а код в OnDragDrop очень простой:
ListView2.Selected.SetPosition(Point(X,Y));
Перетаскивание в TreeView - довольно любопытная тема, здесь порой приходится разрабатывать алгоритмы обхода ветвей для достижения желаемого поведения. Для TreeView1 разрешим перестановку своих узлов в другое положение. В OnDragOver проверим, не происходит ли перетаскивание узла на свой же дочерний во избежание бесконечной рекурсии:
var
Node, SelNode: TTreeNode;
begin
Node := TreeView1.GetNodeAt(x, y);
// находим узел-приемник
Accept := (Sender = Source) and (Node <> nil);
if not Accept then
Exit;
SelNode := Treeview1.Selected;
while (Node.Parent <> nil) and (Node <> SelNode) do
begin
Node := Node.Parent;
if Node = SelNode then
Accept := False;
end;
Код OnDragDrop выглядит так:
var
Node, SelNode: TTreeNode;
begin
Node := TreeView1.GetNodeAt(X, Y);
if Node = nil then
Exit;
SelNode := TreeView1.Selected;
SelNode.MoveTo(Node, naAddChild);
// все уже встроено в TreeView
end;
Теперь разрешим перенос в TreeView2 из TreeView1
Accept := (Source = TreeView1) and (TreeView2.GetNodeAt(x, y) <> nil);
И в OnDragDrop копируем выбранную в TreeView1 ветвь во всеми подветвями, для чего придется сделать рекурсивный обход:
var
Node: TTreeNode;
procedure CopyNode(FromNode, ToNode: TTreeNode);
var
TempNode: TTreeNode;
i: integer;
begin
TempNode := TreeView2.Items.AddChild(ToNode, '');
TempNode.Assign(FromNode);
for i := 0 to FromNode.Count - 1 do
CopyNode(FromNode.Item[i], TempNode);
end;
begin
Node := TreeView2.GetNodeAt(X, Y);
if Node = nil then
Exit;
CopyNode(TreeView1.Selected, Node);
end;
Рассмотрим теперь перенос ячеек в StringGrid1. Поскольку, как и в случае с Memo, простое нажатие левой кнопки занято под другие действия, установим DragMode = dmManual и будем запускать Drag при нажатии левой кнопки, удерживая клавиши Alt или Ctrl. Запишем в OnMouseDown:
var
Acol, ARow: Integer;
begin
with StringGrid1 do
if (ssAlt in Shift) or (ssCtrl in Shift) then
begin
MouseToCell(X, Y, Acol, Arow);
if (Acol >= FixedCols) and (Arow >= FixedRows) then
// не будем перетаскивать из фиксированных ячеек
begin
if ssAlt in Shift then
Tag := 1
else
if ssCtrl in Shift then
Tag := 2;
// запомним что нажато - Alt или Ctrl - в Tag StringGrid1
BeginDrag(True)
end
else
Tag := 0;
end;
end;
Код OnDragOver учитывает также возможность перетаскивания из StringGrid2 (описание ниже)
var
Acol, ARow: Integer;
begin
with StringGrid1 do
begin
MouseToCell(X, Y, Acol, Arow);
Accept := (Acol >= FixedCols) and (Arow >= FixedRows)
and (((Source = StringGrid1) and (Tag > 0))
or (Source = StringGrid2));
end;
Часть OnDragDrop, относящаяся к внутреннему переносу:
var
ACol, ARow, c, r: Integer;
GR: TGridRect;
begin
StringGrid1.MouseToCell(X, Y, ACol, ARow);
if Source = StringGrid1 then
with StringGrid1 do
begin
Cells[Acol, Arow] := Cells[Col,Row];
//копируем ячейку-источник в приемник
if Tag = 1 then
Cells[Col,Row] := '';
// очищаем источник, если было нажато Alt
Tag := 0;
end;
А вот из StringGrid2 сделаем перенос выбранного диапазона ячеек с помощью правой кнопки, для этого в OnMouseDown
if Button = mbRight then
StringGrid2.BeginDrag(True);
И теперь часть StringGrid1DragDrop, относящаяся к переносу из StringGrid2:
if Source = StringGrid2 then
begin
GR := StringGrid2.Selection;
// Selection - выделенные в StringGrid2 ячейки
for r := 0 to GR.Bottom - GR.Top do
for c := 0 to GR.Right - GR.Left do
if (ACol + c < StringGrid1.ColCount) and
(ARow + r < StringGrid1.RowCount) then
// застрахуемся от записи вне StringGrid1
StringGrid1.Cells[ACol + c, ARow + r] :=
StringGrid2.Cells[c + GR.Left, r + GR.Top];
end;
Теперь покажем, как этот диапазон ячеек из StringGrid2 перенести в Memo2. Для этого в OnDragOver Memo2 пишем:
Accept := (Source = StringGrid2) or (Source = DBGrid1);
и в OnDragDrop Memo2:
var
c, r: integer;
s: string;
begin
Memo2.Clear;
if Source = StringGrid2 then
with StringGrid2 do
for r := Selection.Top to Selection.Bottom do
begin
s := '';
for c := Selection.Left to Selection.Right do
s := s + Cells[c, r] + #9;
// разделим ячейки табуляцией
memo2.lines.add(s);
end
Кроме того, в Memo2 можно переносить выбранную запись из DBGrid1, у которого установлено в Options dgRowSelect = True. В сетке отображается таблица из стандартной поставки Delphi DBDEMOS - Animals.dbf. Перетаскивание осуществляется аналогично StringGrid2, правой кнопкой мыши, только по событию OnMouseMove
if ssRight in Shift then
DBGrid1.BeginDrag(true);
Код в Memo2DragDrop, относящийся к переносу из DBGrid1:
else
with DBGrid1.DataSource.DataSet do
begin
s := '';
for c := 0 to FieldCount - 1 do
s := s + Fields[c].AsString + ' | ';
memo2.lines.add(s);
end;
// в случае dgRowSelect = False для переноса одного поля достаточно сделать
// memo2.lines.add(DbGrid1.SelectedField.AsString);
Drag из DBGrid1 принимается также на Panel3, условие приема очевидно, а OnDragDrop выглядит так:
Panel3.Height := 300; // раскрываем панель
Image1.visible := True;
OleContainer1.Visible := false;
Image1.Picture.Assign(DBGrid1.DataSource.DataSet.FieldByName('BMP'));
// показываем графическое поле текущей записи таблицы
Теперь покажу, как можно передвигать мышью визуальные компоненты в Run-Time. Для Panel1 установим DragMode = dmAutomatic, в OnDragOver формы пишем:
var
Ct: TControl;
begin
Ct := ControlAtPos(Point(X + Panel1.Width, Y + Panel1.Height), True, True);
// для упрощения проверяем перекрытие с другими контролами только правого нижнего угла
Accept := (Source = Panel1) and ((Ct = nil) or (Ct = Panel1));
и в OnDragDrop формы очень просто
Panel1.Left := X;
Panel1.Top := Y;
Другой метод перетаскивания можно встретить в каждом FAQ по Delphi:
procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012;
begin
ReleaseCapture;
Panel2.Perform(WM_SysCommand, SC_DragMove, 0);
end;
И в завершение реализация популярной задачи перетаскивания значков файлов на форму из Проводника. Для этого следует описать обработчик сообщения WM_DROPFILES
private
procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
В OnCreate формы разрешить прием файлов
DragAcceptFiles(Handle, true);
и в OnDestroy отключить его
DragAcceptFiles(Handle, False);
Процедура обработки приема файлов может выглядеть так:
procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
const
maxlen = 254;
var
h: THandle;
//i,num:integer;
pchr: array[0..maxlen] of char;
fname: string;
begin
h := Msg.Drop;
// дана реализация для одного файла, а
//если предполагается принимать группу файлов, то можно добавить:
//num:=DragQueryFile(h,Dword(-1),nil,0);
//for i:=0 to num-1 do begin
// DragQueryFile(h,i,pchr,maxlen);
//...обработка каждого
//end;
DragQueryFile(h, 0, pchr, maxlen);
fname := string(pchr);
if lowercase(extractfileext(fname)) = '.bmp' then
begin
Image1.visible := True;
OleContainer1.Visible := false;
image1.Picture.LoadFromFile(fname);
Panel3.Height := 300;
end
else if lowercase(extractfileext(fname)) = '.doc' then
begin
Image1.visible := False;
OleContainer1.Visible := True;
OleContainer1.CreateObjectFromFile(fname, false);
Panel3.Height := 300;
end
else if lowercase(extractfileext(fname)) = '.htm' then
ShellExecute(0, nil, pchr, nil, nil, 0)
else if lowercase(extractfileext(fname)) = '.txt' then
Memo2.Lines.LoadFromFile(fname)
else
Memo2.Lines.Add(fname);
DragFinish(h);
end;
При перетаскивании на форму файла с расширением Bmp он отображается в Image1, находящемся на Panel3, Doc загружается в OleContainer, для Htm запускается Internet Explorer или другой браузер по умолчанию, Txt отображается в Memo2, а для остальных файлов в Memo2 будет просто показано имя.
Полагаю, на основе содержащихся в статье приемов будет нетрудно организовать перетаскивание и для других, не описанных здесь, визуальных компонентов.
В заключение хочу выразить благодарность Игорю Шевченко и Максиму Власову за ценные советы при подготовке примеров... Автор статьи: Борис Новгородов, Новосибирск, 2002
Взято с сайта
Примеры работы с динамическими массивами
Примеры работы с динамическими массивами
Очень простой пример...
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?
Да. Для начала вам необходимо создать тип массива, использующего самый большой размер, который вам, вероятно, может понадобиться. В действительности, при создании типа никакой памяти не распределяется. Вот когда вы создаете переменную этого типа, тогда компилятор пытается распределить для вас необходимую память. Вместо этого создайте переменную, являющуюся указателем на этот тип. Этим вы заставите компилятор распределить лишь четыре байта, необходимые для размещения указателя.
Прежде, чем вы сможете пользоваться массивом, вам необходимо распределить для него память. Используя AllocMem, вы можете точно управлять выделяемым размером памяти. Для того, чтобы определить необходимое количество байт, которые вы должны распределить, просто умножьте размер массива на размер отдельного элемента массива. Имейте в виду, что самый большой блок, который вы сможете распределить в любой момент в 16-битной среде равен 64Kб. Самый большой блок, который вы можете в любой момент распределить в 32-битной среде равен 4Гб. Для определения максимального числа элементов, которые вы можете иметь в вашем конкретном массиве (в 16-битной среде), разделите 65,520 на размер отдельного элемента. Например: 65520 div SizeOf(LongInt)
Пример объявления типа массива и указателя:
type
ElementType = LongInt;
const
MaxArraySize = (65520 div SizeOf(ElementType));
(* в 16-битной среде *)
type
MyArrayType = array[1..MaxArraySize] of ElementType;
var
P: ^MyArrayType;
const
ArraySizeIWant: Integer = 1500;
Затем, для распределения памяти под массив, вы могли бы использоваться следующую процедуру:
procedure AllocateArray;
begin
if ArraySizeIWant <= MaxArraySize then
P := AllocMem(ArraySizeIWant * SizeOf(LongInt));
end;
Не забывайте о том, что величина ArraySizeIWant должна быть меньше или равна MaxArraySize.
Вот процедура, которая с помощью цикла устанавливает величину каждого члена:
procedure AssignValues;
var
I: Integer;
begin
for I := 1 to ArraySizeIWant do
P^[I] := I;
end;
Имейте в виду, что вам необходимо самому организовать контроль допустимого диапазона. Если вы распределили память для массива с пятью элементами, и пытаетесь назначить какое-либо значение шестому, вы получите ошибку и, возможно, порчу памяти.
Помните также о том, что после использования массива всю распределенную память необходимо освободить. Вот пример того, как избавиться от этого массива:
procedure DeallocateArray;
begin
P := AllocMem(ArraySizeIWant * SizeOf(LongInt));
end;
Ниже приведен пример динамического массива:
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls;
type
ElementType = Integer;
const
MaxArraySize = (65520 div SizeOf(ElementType));
{ в 16-битной среде }
type
{ Создаем тип массива. Убедитесь в том, что вы установили
максимальный диапазон, который вам, вероятно, может понадобиться. }
TDynamicArray = array[1..MaxArraySize] of ElementType;
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
{ Создаем переменную типа указатель на ваш тип массива. }
P: ^TDynamicArray;
const
{ Это типизированные константы. В действительности они
являются статическими переменными, инициализирующимися
во время выполнения указанными в исходном коде значениями.
Это означает, что вы можете использовать типизированные
константы точно также, как и любые другие переменные.
Удобство заключается в автоматически инициализируемой величине. }
DynamicArraySizeNeeded: Integer = 10;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Распределяем память для нашего массива. Будь внимательны
и распределяйте размер, в точности необходимый для размещения нового массива.
Если вы попытаетесь записать элемент, выходящий за допустимый диапазон,
компилятор не ругнется, но объект исключения вам обеспечен. }
DynamicArraySizeNeeded := 500;
P := AllocMem(DynamicArraySizeNeeded * SizeOf(Integer));
{ Как присвоить значение пятому элементу массива. }
P^[5] := 68;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
{ Вывод данных. }
Button1.Caption := IntToStr(P^[5]);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Освобождаем распределенную для массива память. }
FreeMem(P, DynamicArraySizeNeeded * SizeOf(Integer));
end;
end.
Вот "демо-модуль", демонстрирующий три различных способа (далеко не все) создания динамических массивов. Все три способа для распределения достаточного количества памяти из кучи используют GetMem, tList используют для добавления элементов в список массива и используют tMemoryStream для того, чтобы распределить достаточно памяти из кучи и иметь к ней доступ, используя поток. Старый добрый GetMem вполне подходит для такой задачи при условии, что массив не слишком велик (<64K).
PS. Я не стал ловить в коде исключения (с помощью блоков Try...Finally}, которые могли бы мне помочь выявить ошибки, связанные с распределением памяти. В реальной системе вы должны быть уверены в своем грациозном владении низкоуровневыми операциями с памятью.
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ Форма, демонстрирующая различные методы создания массива с }
{ динамически изменяемым размером. Разместите на форме четыре кнопки,}
{ компоненты ListBox и SpinEdit и создайте, как показано ниже, }
{ обработчики событий, возникающие при нажатии на кнопки. Button1, }
{ Button2 и Button3 демонстрируют вышеуказанных метода. Button4 }
{ очищает ListBox для следующего примера. }
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit Dynarry1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Spin;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
SpinEdit1: TSpinEdit;
ListBox1: TListBox;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
pSomeType = ^SomeType;
SomeType = Integer;
procedure TForm1.Button1Click(Sender: TObject);
type
pDynArray = ^tDynArray;
tDynArray = array[1..1000] of SomeType;
var
DynArray: pDynArray;
I: Integer;
begin
{ Распределяем память }
GetMem(DynArray, SizeOf(SomeType) * SpinEdit1.Value);
{ Пишем данные в массив }
for I := 1 to SpinEdit1.Value do
DynArray^[I] := I;
{ Читаем данные из массива }
for I := SpinEdit1.Value downto 1 do
ListBox1.Items.Add('Элемент ' + IntToStr(DynArray^[I]));
{ Освобождаем память }
FreeMem(DynArray, SizeOf(SomeType) * SpinEdit1.Value);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
List: tList;
Item: pSomeType;
I: Integer;
begin
{ Создаем список }
List := tList.Create;
{ Пишем данные для списка }
for I := 1 to SpinEdit1.Value do
begin
{ Распределяем уникальный экземпляр данных }
New(Item); Item^ := I;
List.Add(Item);
end;
{ Читаем данные из списка - базовый индекс списка 0, поэтому вычитаем из I единицу }
for I := SpinEdit1.Value downto 1 do
ListBox1.Items.Add('Элемент ' +
IntToStr(pSomeType(List.Items[I - 1])^));
{ Освобождаем лист }
for I := 1 to SpinEdit1.Value do
Dispose(List.Items[I - 1]);
List.Free;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
Stream: tMemoryStream;
Item: SomeType;
I: Integer;
begin
{ Распределяем память потока }
Stream := tMemoryStream.Create;
Stream.SetSize(SpinEdit1.Value);
{ Пишем данные в поток }
for I := 1 to SpinEdit1.Value do
{ Stream.Write автоматически отслеживает позицию записи,
поэтому при записи данных за ней следить не нужно }
Stream.Write(I, SizeOf(SomeType));
{ Читаем данные из потока }
for I := SpinEdit1.Value downto 1 do
begin
Stream.Seek((I - 1) * SizeOf(SomeType), 0);
Stream.Read(Item, SizeOf(SomeType));
ListBox1.Items.Add('Элемент ' + IntToStr(Item));
end;
{ Освобождаем поток }
Stream.Free;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
ListBox1.Items.Clear;
end;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
Примеры работы с репортами
Примеры работы с репортами
In the next small example I'll demonstrate how you can call the report in MS Access:
var
Access: Variant;
begin
// open the Access application
try
Access := GetActiveOleObject('Access.Application');
except
Access := CreateOleObject('Access.Application');
end;
Access.Visible := True;
// open the database
//The second parameter specifies whether you want to open the database in Exclusive mode
Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);
// open the report
{The value for the second parameter should be one of
acViewDesign, acViewNormal, or acViewPreview. acViewNormal, which is the default, prints the report immediately. If you are not using the type library, you can define these values like this:
const
acViewNormal = $00000000;
acViewDesign = $00000001;
acViewPreview = $00000002;
The third parameter is for the name of a query in the current
database.The fourth parameter is for a SQL WHERE clause - the string must be valid
SQL, minus the WHERE.}
Access.DoCmd.OpenReport('Titles by Author', acViewPreview,
EmptyParam, EmptyParam);
{ ... }
// close the database
Access.CloseCurrentDatabase;
// close the Access application
{const
acQuitPrompt = $00000000;
acQuitSaveAll = $00000001;
acQuitSaveNone = $00000002;}
Access.Quit(acQuitSaveAll);
end;
Взято с
Delphi Knowledge BaseПринцип создания плугинов в Delphi
Принцип создания плугинов в Delphi
Иногда нужные мысли приходят после того, как программа сдана заказчику. Для этого придумали плугины. Плугины - это простая dll библиотека, в которой обязательно присутствует ряд процедур и функций, которые выполняют определенные разработчиком действия, например (из моей практики) : function PluginType : PChar; - функция, определяющая назначение плугина. function PluginName : PChar; - функция, которая возвращает название плугина. Это название будет отоброжаться в меню. function PluginExec(AObject:ТТип) : boolean; - главный обработчик, выполняет определённые действия и возвращает TRUE; и ещё, я делал res файл с небольшим битмапом и компилировал его вместе с плугином, который отображался в меню соответствующего плугина. Откомпилировать res фaйл можно так: 1. создайте файл с расширением *.rc 2. напишите в нём : bitmap RCDATA LOADONCALL 1.bmp где bitmap - это идентификатор ресурса RCDATA LOADONCALL - тип и параметр 1.bmp - имя локального файла для кампиляций 3. откомпилируйте этот файл программой brcc32.exe, лежащей в папке ...\Delphi5\BIN\ .
Загрузка плугина
Перейдём к теоретической части.
раз плугин это dll значит её можно подгрузить следующими способами:
1. Прищипыванием её к программе!
function PluginType : PChar; external 'myplg.dll';
//в таком случае dll должна обязательно лежать возле exe и мы не можем передать
туда конкретное имя! не делать же все плугины одного имени! это нам не подходит.
Программа просто не загрузится без этого файла! Выдаст сообщение об ошибке. Этот способ
может подойти для поддержки обновления вашей программы!
2. Динамический
это оэночает, что мы грузим её так, как нам надо! Вот пример:
var
PluginType: function: PChar; // объявляем процедурный тип функции из плугина
PlugHandle: THandle; //объявляем переменную типа хендл в которую мы занесём хендл плугина
procedure Button1Click(Sender: TObject);
begin
PlugHandle := LoadLibrary('MYplg.DLL'); //грузим плугин
if PlugHandle <> 0 then //Получилось или нет??
begin
@PluginType := GetProcAddress(plugHandle,'Plugintype'); // ищем функцию в dll
if @PluginType <> nil then ShowMessage(PluginType); //вызываем функцию
end;
FreeLibrary(LibHandle);//освобождаем библиотеку
end;
Вот этот способ больше подходит для построения плугинов!
Функции:
function LoadLibrary(lpLibFileName : Pchar):THandle;
//как вы поняли загружает dll и возвращает её хендл
function GetProcAddress(Module: THandle; ProcName: PChar): TFarProc
// пытается найти обработчик в переданной ей хендле dll,
при успешном выполнении возвращает указатель обработчика.
function FreeLibrary(LibModule: THandle); //освобождает память, занитую dll
Самое сложное в построений плугинов, это не реализация всего кода, а придусмотрение всего, для чего в программе могут они понадобиться! То есть придусмотреть все возможные типы плугинов! А это не так просто.
Вот полноценный пример реализации простой программы для поддержки плугинов...
Исходный текст модуля программы:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, menus,
Grids, DBGrids;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
N1231: TMenuItem; //меню, которое будет содержать ссылки на плугины
procedure FormCreate(Sender: TObject);
private
PlugList : TStringList; //лист, в котором мы будем держать имена файлов плугинов
procedure LoadPlug(fileName : string); //Процедура загрузки плугина
procedure PlugClick(sender : TObject);
//Процедура инициализации и выполнения плугина
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
Процедура загрузки плугина. Здесь мы загружаем, вносим имя dll в список
и создаём для него пункт меню; загружаем из dll картинку для пункта меню
procedure TForm1.LoadPlug(fileName: string);
var
PlugName : function : PChar;
//Объявление функции, которая будет возвращать имя плугина
item : TMenuItem; //Новый пункт меню
handle : THandle; //Хендл dll
res :TResourceStream; //Объект, с помощью которого мы загрузим картинку из dll
begin
item := TMenuItem.create(mainMenu1); //Создаём новый пункт меню
handle := LoadLibrary(Pchar(FileName)); //загружаем dll
if handle <> 0 then //Если удачно, то идём дальше...
begin
@PlugName := GetProcAddress(handle,'PluginName'); //грузим процедуру
if @PlugName <> nil then item.caption := PlugName else
//Если всё прошло, идём дальше...
begin
ShowMessage('dll not identifi '); //Иначе, выдаём сообщение об ошибке
Exit; //Обрываем процедуру
end;
PlugList.Add(FileName); //Добавляем название dll
res:= TResourceStream.Create(handle,'bitmap',rt_rcdata); //Загружаем ресурс из dll
res.saveToFile('temp.bmp'); res.free; //Сохраняем в файл
item.Bitmap.LoadFromFile('Temp.bmp'); //Загружаем в пункт меню
FreeLibrary(handle); //Уничтожаем dll
item.onClick:=PlugClick; //Даём ссылку на обработчик
Mainmenu1.items[0].add(item); //Добавляем пункт меню
end;
end;
Процедура выполнения плугина. Здесь мы загружаем, узнаём тип и выполняем
procedure TForm1.PlugClick(sender: TObject);
var
PlugExec : function(AObject : TObject): boolean;
//Объявление функции, которая будет выполнять плугин
PlugType : function: PChar; //Объявление функции, которая будет возвращать тип плугина
FileName : string; //Имя dll
handle : Thandle; //Хендл dll
begin
with (sender as TmenuItem) do filename:= plugList.Strings[MenuIndex];
//Получаем имя dll
handle := LoadLibrary(Pchar(FileName)); //Загружаем dll
if handle <> 0 then //Если всё в порядке, то идём дальше
begin
//Загружаем функции
@plugExec := GetProcAddress(handle,'PluginExec');
@plugType := GetProcAddress(handle,'PluginType');
//А теперь, в зависимости от типа, передаём нужный ей параметр...
if PlugType = 'FORM' then PlugExec(Form1) else
//Если плугин для формы, то передаём форму
if PlugType = 'CANVAS' then PlugExec(Canvas) else
//Если плугин для канвы, то передаём канву
if PlugType = 'MENU' then PlugExec(MainMenu1) else
//Если плугин для меню, то передаём меню
if PlugType = 'BRUSH' then PlugExec(Canvas.brush) else
//Если плугин для заливки, то передаём заливку
if PlugType = 'NIL' then PlugExec(nil);
//Если плугину ни чего не нужно, то ни чего не передаём
end;
FreeLibrary(handle); //Уничтожаем dll
end;
procedure TForm1.FormCreate(Sender: TObject);
var
SearchRec : TSearchRec; //Запись для поиска
begin
plugList:=TStringList.create; //Создаём запись для имён dll'ок
if FindFirst('*.dll',faAnyFile, SearchRec) = 0 then //ищем первый файл
begin
LoadPlug(SearchRec.name); //Загружаем первый найденный файл
while FindNext(SearchRec) = 0 do LoadPlug(SearchRec.name);
//Загружаем последующий
FindClose(SearchRec); //Закрываем поиск
end;
//Левые параметры
canvas.Font.pitch := fpFixed;
canvas.Font.Size := 20;
canvas.Font.Style:= [fsBold];
end;
end.
здесь написан простой исходный текст dll, то есть нашего плугина
Он обязательно возвращает название, тип и выполняет свои задачи
library plug;
uses
SysUtils, graphics, Classes, windows;
{$R bmp.RES}
function PluginType : Pchar;
begin
Plugintype := 'CANVAS'; //Мы указали реакцию на этот тип
end;
function PluginName:Pchar;
begin
PluginName := 'Canvas painter';
//Вот оно, название плугина. Эта строчка будет в менюшке
end;
Функция выполнения плугина! Здесь мы рисуем на переданной канве
анимационную строку.
function PluginExec(Canvas:TCanvas):Boolean;
var
X : integer;
I : integer;
Z : byte;
S : string;
color : integer;
proz : integer;
begin
color := 10;
proz :=0;
S:= 'hello всем это из плугина ля -- ля';
for Z:=0 to 200 do
begin
proz:=proz+2;
X:= 0;
for I:=1 to length(S) do
begin
X:=X + 20;
Canvas.TextOut(X,50,S[i]);
color := color+X*2+Random(Color);
canvas.Font.Color := color+X*2;
canvas.font.color := 10;
canvas.TextOut(10,100,'execute of '+inttostr(proz div 4) + '%');
canvas.Font.Color := color+X*2;
sleep(2);
end;
end;
PluginExec:=True;
end;
exports
PluginType, PluginName, PluginExec;
end.
Пару советов :
1. Не оставляйте у своих плугинов расширение *.dll, это не катит. А вот сделайте, например *.plu . Просто в исходном тексте плугина напишите {$E plu} Ну и в исходном тексте программы ищите не Dll, а уже plu.
2. Когда вы сдаёте программу, напишите к ней уже готовых несколько плугинов, что бы юзеру было интересно искать новые.
3. Сделайте поддержку обновления через интернет. То есть программа заходит на ваш сервер, узнаёт, есть ли новые плугины или нет, если есть - то она их загружает. Этим вы увеличите спрос своей программы и конечно трафик своего сайта!
Взято с сайта
Принципы построения API-библиотеки
Принципы построения API-библиотеки
Стандартным видом API-программирования является структурное программирование. Примеры такого программирования на Win32 API есть практически в любой книжке по Borland Pascal, Borland C++, Microsoft Visual C++ и другим системам разработки. Множество примеров API-программирования на С содержится в поставке Microsoft Visual C++.
Структурное программирование с оконными функциями, процедурами обработки команд, не в состоянии обеспечить быструю и эффективную разработку программ. В современной ситуации большинство программистов привыкло к объектно-ориентированному методу, с возможностью инкапсуляции, наследования и переопределения методов объектов. Такое программирование оказывается наиболее эффективным.
Кроме того, для построения эффективной API-библиотеки прежде всего нужно выяснить, какие задачи при работе с Win32 API являются наиболее трудоемкими. Практика показывает, что наиболее неудобным и трудоемким элементом является реализация основного диспетчера логики программы - оконной функции. Реализация этой функции в качестве метода класса, а не простой глобальной функции, позволила бы улучшить структуру кода и облегчить программирование путем инкапсулирования всех переменных внутри оконного класса.
Программирование может быть еще более облегчено, есть возпользоваться механизмом message-процедур языка Object Pascal. Вызов этих процедур полностью лежит на компиляторе и корневом объекте TObject и включает в себя методы Dispatch, DefaultHandler, а также все методы, объявленные с директивой message. Такое решениее позволит полностью отказаться от громоздкого оператора case в оконной функции.
Учитывая все вышеперечисленное автором была создана компактная библиотека оконных классов WinLite. Эта библиотека является минимальной, она не вводит более высоких уровней абстракции чем существуют в Win32 API - она только облегчает работу, переводом программирования в объектно-ориентированное русло. Размер библиотеки очень небольшой и вся она помещается в один модуль. Библиотека реализует базовый класс TLiteFrame и построенные на основе него оконные классы:
·TLiteWindow - класс окна, с возможностью subclass'инга;
·TLiteDialog - класс немодального диалога;
·TLiteDialogBox - класс модального диалога.
Библиотека может быть использована совместно с VCL. На первый взгляд, это возможность является абсурдной и ненужной, так как об экономии размера в этом случае не может быть и речи. Однако, иногда бывают моменты, когда реализация специфических оконных элементов на основе объектов TWinControl или TCustomControl может быть затруднена или неэффективна из-за их сложности и неочевидного поведения. В этом случае, можно реализовать такой элемент на базе класса TLiteWindow - он будет вести себя стандартным образом, как и полагается вести себя стандартному оконному элементу Win32.
Благодаря своей простой архитектуре библиотека может быть использована в многопоточной программе. Конечно, вы не сможете вызывать методы классов одного потока из другого потока без соответствующей синхронизации. Однако, вы можете беспрепятственно создавать оконные классы в различных потоках без блокировки и синхронизации, а также посылать сообщения оконным классам в другом потоке.
Практический совет: при API-программировании программист должен сам следить за корректным освобождением многочисленных ресурсов, которые занимает программа во время выполнения. Поэтому, для облегчения этой задачи используйте какую-либо контролирующую утилиту, например MemProof или Numega BoundsChecker. Корректное освобождение занятых ресурсов крайне необходимо !
К тому же, прежде чем вы решите работать над своим проектом в русле Win32 API, подумайте, а зачем вам это нужно? В подавляющем числе случаев размер программы не имеет никакого значения. Я не хочу сказать, что API-программирование сложнее чем VCL-программирование. Во многих случаях легче изучить и написать 10 вызовов API с кучей аргументов и понимать, что происходит, чем написать 1 вызов простой, на первый взгляд, VCL-инструкции и потом долго исследовать дебри VCL в поисках ответа. Просто API-программирование - это другая культура, к которой вы, возможно, не привыкли. И первоначальная работа может вызвать у вас сильное разочарование. API-программирование требует дотошности, кропотливости и внимательного изучения документации.
Те же, кто отважился программировать на API, наряду с библиотекой WinLite могут совместно использовать невизуальные классы как из состава VCL (модули SysUtils, Classes), так и многие сторонние - естественно, что размер вашей программы при этом увеличится.
·Невизуальные классы библиотеки ACL - http://a-press.parad.ru/pc/bokovikov/delphi/acl/acl.zip
·Невизуальные классы библиотеки XCL - http://xcl.cjb.net
·JEDI Code Library - http://www.delphi-jedi.com
·Системные компоненты на Torry - www.torry.ru
Для редактирования шаблонов диалогов можно использовать любой редактор ресурсов, например Borland Resource WorkShop, правда он несколько неудобен, а окончательный
Привлечение внимания к окну
Привлечение внимания к окну
Часто возникает проблема - в многооконном приложении необходимо обратить внимание пользователя на то, что какое-то из окон требует внимания (например, к нему пришло сообщение по DDE, в нем завершился какой-либо процесс, произошла ошибка ...). Это легко сделать, используя команду API FlashWindow:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
FlashWindow(Handle,true);
end;
Источник:
Прячем форму
Прячем форму
Cодержание раздела:
Problem generating font matrix in Kylix.
Problem generating font matrix in Kylix.
My install of Kylix was successfull but after startup with "startkylix" I see the message "generating font matrix" forever. What should I do about this?
If you installed as root the font matrix will be created for each user the first time they start Kylix. How long it takes depends on the number of fonts that you have installed and the speed of your machine. If it seems to freeze or last a long time you should still be able to run Kylix even if you terminate the font matrix generation.
Possible workarounds
This problem could be caused by a bad truetype font. If you have any Windows tt-fonts installed try removing them. Another thing to try is to change the order of the font search path in XF86Config or in your tt-fontserver. Try to put the tt-fonts at the end of the list.
Here is another suggestion from our newsgroups:
Rename the file "transdlg" located in your Kylix bin directory to "transdlg.renamed" and then run Kylix.
This is an issue we are currently looking into. This document will be updated when more information is available.
Проблема использования компонентов в D6/7 от предыдущих версий
Проблема использования компонентов в D6/7 от предыдущих версий
Решение в случае ошибок компиляции пакетов типа: Missing unit 'Proxies.pas' и Missing DsgnIntf.pas
1) Сначала заменить
uses DsgnIntf;
на
uses DesignIntf, DesignEditors;
2) Затем
Добавить
DesignIde.dcp
в лист требуемых модулейВзято с сайта
Проблема с установками принтера
Проблема с установками принтера
Обнаружил, что компонент QReport никак не реагирует на установки принтера PrinterSetup диалога, вызываемого нажатием кнопочкисобственного Preview!
В QuickReport есть собственный объект TQRPrinter, установки которого он использует при печати, а стандартные установки принтеров на него не влияют. В диалоге PrinterSetup, вызываемом из Preview можно лишь выбрать принтер на который нужно печатать (если, конечно, установлено несколько принтеров).
Советую поставить обновление QReport на 2.0J с www.qusoft.com.
Перед печатью (не только из QReport) программно установите требуемый драйвер принтера текущим для Windows
function SetDefPrn(const stDriver : string) : boolean;
begin
SetPrinter(nil).Free;
Result := WriteProfileString('windows', device, PChar( stDriver));
end;
После печати восстановите установки.
Источник:
Проблема всплывающих подсказок в дочерних MDI-формах
Проблема всплывающих подсказок в дочерних MDI-формах
Если вам просто нужно отобразить всплывающие подсказки от элементов управления вашей дочерней формы, то сделайте это в вашей главной форме.
Объявите следующую процедуру в классе вашей главной формы:
private
{============================================================}
{Процедура, вызываемая приложением всякий раз, когда }
{ приложение хотело бы показать всплывающую подсказку. }
{ Добавляет хинт на панель статуса. }
{============================================================}
procedure ShowHint(Sender : TObject);
затем в процедуре главной формы .create добавьте следующую строку:
{ Отображает хинт на статусной панели}
Application.OnHint := ShowHint;
Теперь приведем код функции ShowHint, принадлежащей главной форме:
{================================================================}
{ Обновляем pnlStatusText.Caption с текстом всплывающей подсказки}
{ элемента управления, над которым находится курсор мыши. }
{================================================================}
procedure
TMainFrame.ShowHint
(
Sender: TObject {Объект, вызывающий данную процедуру}
);
begin
pnlStatusText.Caption := Application.Hint;
end; { TMainFrame.ShowHint }
Это должно работать. Вам нужно будет только задать текст подсказок для элементов управления во всех окнах, включая главное. Устанавливая свойство показа хинтов в false или true, вы тем самым указываете способ показа хинтов: обычным способом в виде всплывающих окошек, или совместно с показом в строке состояния.
Взято с
Проблемы использования компонента TStoredProc
Проблемы использования компонента TStoredProc
Недавно я перешел на использование Oracle, но все мои попытки использовать компонент TStoredProc оказываются неудачными. Почему?
Причины неработоспособности компонента TStoredProc могут быть следующими.
Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают).
Во-вторых, имеется известная проблема, описание которой содержится в разделе Developers Support корпоративного сайта Inprise (http://www.inprise.com). Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.
Наталия Елманова
Взято с Исходников.ru
Проблемы использования TRegistry под NT/2000/XP
Проблемы использования TRegistry под NT/2000/XP
При использованиии компонента TRegistry под NT пользователь с права доступа ниже чем "администратор" не может получить доступа к информации реестра в ключе HKEY_LOCAL_MACHINE. Как это обойти?
Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра.
Примечание p0s0l
Вообще-то можно ничего не переписывать:
Reg := TRegistry.Create(KEY_READ);
т.е. у TRegistry есть два конструктора - один без параметра, тогда доступ будет
KEY_ALL_ACCESS, а другой конструктор - с параметром...
Примечание к примечанию Vit
Дополнительные конструкторы появились только в последних версиях Дельфи
Проблемы с автоинкрементальными полями
Проблемы с автоинкрементальными полями
Оказывается, что Interbase триггер "before insert" срабатывает только после того, как запись "запостится" из Delphi приложения. В связи с чем становится невозможным увеличение автоинкрементальных ключевых полей. Есть решение?
Большинство программистов решило эту проблему созданием хранимой процедуры (stored procedure), позволяющей от InterBase получить следующий номер и поместить его в вашу запись посредством метода onBeforePost или onNewRecord.
Автор: Steve Koterski (Borland)
Я пытаюсь сгенерировать последовательный ключ для первичной ключевой колонки, но LIBS мне отвечает "nested select is not support in this context." (вложенный выбор не поддерживается в данном контексте.)
Как насчет:
CREATE TRIGGER AUTOINCREMENT FOR MYTABLE
BEFORE INSERT AS
DECLARE VARIABLE new_key INTEGER;
BEGIN
UPDATE AUTOKEYS
SET KEY_VALUE = KEY_VALUE + 1
WHERE (KEY_ID = "A");
SELECT KEY_VALUE
FROM AUTOKEYS
WHERE KEY_ID = "A"
INTO :new_key;
new.my_key_column = new_key;
END ^
Автор: Mike Downey
Я пытаюсь добавить запись в таблицу InterBase, содержащую триггеры и blob-поля, тем не менее, всякий раз при выполнении метода "post" после установки ("append") значений, я получаю ошибку: 'Record/Key deleted.' (запись/ключ удален).
Вот реальный пример того, как я обошел эту проблему:
Определение хранимой процедуры:
Create Procedure NewEmployeeKey Returns ( EmployeeKey Integer ) as
begin
EmployeeKey = Gen_Id( gnEmployeeKey, 1 ) ;
end
Определение триггера:
Create Trigger SetEmployeeKey for tbEmployee Active Before Insert Position 0 as
begin
if ( New.EmployeeKey is Null ) then begin
Execute Procedure NewEmployeeKey Returning_Values New.EmployeeKey ;
end
end
Код Delphi для использования в обработчике события OnNewRecord, или AfterInsert, или BeforePost:
{ qyProviderData - это tQuery }
{ spProviderKey - это tStoredProc }
if qyProviderData.State in [dsInsert] then
begin
spProviderKey.ExecProc ;
qyProviderData.FieldByName( 'ProviderKey' ).AsInteger :=
spProviderKey.ParamByName( 'ProviderKey' ).AsInteger ;
end ; { if }
Это все, что вам необходимо. Хранимая процедура возвращает следующее сгенерированное значение. Триггер это гарантирует, даже если бы данные не были доступны из вашей Delphi-программы, первичный ключ все еще назначает значение. В Delphi-коде, я полагаю, вы могли бы проверять наличие пустого поля первичного ключа вместо .State in [dsInsert], хотя это то же работает.
Взято с
Проблемы с дробными числами
Проблемы с дробными числами
Иногда возникают трудности интерпретации дробных чисел - что есть разделитель точка или запятая?
В Дельфи есть системные переменные:
DECIMALSEPARATOR - десятичный разделитель который принят в системе
THOUSANDSEPARATOR - разделитель тысяч, который принят в системе
Для USA регионального стандарта
DECIMALSEPARATOR будет "."
THOUSANDSEPARATOR будет ","
Для России
DECIMALSEPARATOR будет ","
THOUSANDSEPARATOR будет "." или " " (не помню уже)
Автор Vit
Взято с Vingrad.ru
Проблемы с TCanvas.StretchDraw при рисовании иконок
Проблемы с TCanvas.StretchDraw при рисовании иконок
При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку
увеличенной ее размер не изменяется. Что делать?
Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод TCanvas.StretchDraw.
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;
Проблемы установки Kylix и запуска Kylix приложений
Проблемы установки Kylix и запуска Kylix приложений
Cодержание раздела:
Процедуры и функции RxLib
Процедуры и функции RxLib
Процедуры и функции RX_lib
AppUtils unit:
AppBroadcast
- Функция посылает сообщение Msg всем формам приложения.FindForm
- Функция перебирает формы приложения, проверяя для каждой из них, является ли она экземпляром класса FormClassFindShowForm
- Функция перебирает формы приложения, проверяя для каждой из них, является ли она экземпляром класса FormClassGetDefaultIniName
- Функция возвращает имя INI-файла "по умолчанию" для приложения.GetDefaultIniRegKey
- Функция возвращает имя ключа регистрационной базы данных Windows (Registry) "по умолчанию" для приложенияGetDefaultSection
- Функция возвращает строку для указанной компоненты Component,GetUniqueFileNameInDir
- Возвращает уникальное для заданного каталога имя файла, InstantiateForm- функция создает экземпляр формы типа FormClassReadFormPlacement
- Процедура ReadFormPlacement используется для восстановления формыRestoreFormPlacement
- Процедура RestoreFormPlacement используется для восстановл. формыRestoreGridLayout
- Восстанавливает из INI-файла ширины колонок компонент TCustomGridRestoreMDIChildren
- Создает и показывает MDIChild-формыSaveFormPlacement
- Процедура используется для сохранения состояния формыSaveGridLayout
SaveMDIChildren
ShowDialog
- Создание и модальное исполнение диалогаWriteFormPlacement
- Процедура используется для сохранения состояния формы,BdeUtils unit:
AsyncQrySupported
- Функция возвращает True, если драйвер специфицированной базы данных Database поддерживает асинхронное выполнение запросовCheckOpen
- Функция служит для обрамления вызовов функций BDE API, открыв. курсорыConvertStringToLogicType
- Процедура предназначена для конвертации строки Value в BDE,CurrentRecordDeleted
- Функция определяет, является ли текущая запись набора данных удаленной (помеченной как удаленная) или нетDataSetFindValue
- Функция пытается установить набор данных, переданный в качестве параметра DataSet, на первую от начала запись, удовлетворяющую заданному условиюDataSetPositionStr
- Для драйверов DBase и Paradox функция возвращает строку, содержащую текущий номер записи и полное число записей в DataSetDataSetRecNo
- Функция возвращает номер текущей записи в DataSet.DataSetShowDeleted
- Процедура устанавливает режим показа удаленных записей в таблицах формата DBase.DeleteRange
- Удаление диапазона записей из таблицы.ExecuteQuery
- Процедура предназначена для выполнения SQL-запросовExportDataSet
- Процедура служит для экспорта данных из таблицы БД или результата запроса Source в выходную таблицу DestTable.FetchAllRecords
FieldLogicMap
- Функция возвращает для конкретного значения FldType получить для целочисленное значение, идентифицирующее логический тип данных BDE.GetAliasPath
- Функция возвращает физический путь для алиаса (псевдонима) BDEGetBDEDirectory
- Функция возвращает имя каталога, в котором установлены библиотеки BDE InitRSRun - Инициализация RUNTIME ReportSmith.IsBookmarkStable
- Return True, if specified DataSet supports stable bookmarksPackTable
- Процедура предназначена для "упаковки" таблиц формата DBase и ParadoxRestoreIndex
- Восстанавливает свойство IndexFieldNames у TableSetIndex
-Устанавливает свойство IndexFieldNames у TableSetToBookmark
- Функция устанавливает ADataSet в позицию, соответствующую переданному значению ABookmarkTransActive
- Функция определяет, имеет ли база данных Database активную транзакцию и в этом случае возвращает True, в противном случае результат - False.BoxProcs unit:
BoxDragOver
- Предполагается вызывать из обработчика события OnDragOver.BoxMoveAllItems
- Копирует все элементы SrcList в DstList, затем очищает SrcList.BoxMoveFocusedItem
- Предполагается использовать в обработчике события OnDragDrop.BoxMoveSelectedItems
- Перемещает выделенные элементы из SrcList в DstListClipIcon unit:
AssignClipboardIcon
- Процедура заполняет иконку Icon данными из буфера обмена (Clipboard)CopyIconToClipboard
CreateIconFromClipboard
- Функция создает объект класса TIcon, если буфер обмена (Clipboard) содержит данные в формате CF_ICON.CreateRealSizeIcon
- Функция создает иконку из объекта Icon класса TIconDrawRealSizeIcon
- Функция рисует иконку Icon на устройстве Canvas,GetIconSize
- Процедура возвращает ширину и высоту иконки,DateUtil unit:
CutTime
- Устанавливает время в переданном аргументе ADate в значение 00:00:00:00.DateDiff
- Определяет разницу между датами, заданными Date1 и Date2 в днях, месяцах и годах.DaysBetween
- Вычисляет число дней между датами Date1 и Date2,DaysInPeriod
- Вычисляет число дней между датами Date1 и Date2DaysPerMonth
DefDateFormat
- Функция возвращает строку формата даты по ShortDateFormat,DefDateMask
- Функция возвращает строку маски для ввода датыFirstDayOfNextMonth
FirstDayOfPrevMonth
GetDateOrder
- Функция возвращает порядок расположения дня, месяца и года в формате даты,IncDate
- Увеличивает дату ADate на заданное количество дней, месяцев и лет, возвращая полученную дату как результат.IncDay
- Увеличивает дату на заданное количество дней, возвращая полученную датуIncHourIncMinute
- Увеличивает время на заданное количество минут, возвращая полученное время IncMonthIncMSec
IncSecond
IncTime
- Увеличивает время на заданное количество часов, минут, секи мс, возвращая время IncYearIsLeapYear
- Проверяет является ли заданный параметром AYear год високосным.LastDayOfPrevMonth
MonthsBetween
StrToDateDef
- Функция преобразует строку в дату в соответствии с форматом ShortDateFormatStrToDateFmt
StrToDateFmtDef
ValidDate
- Функция определяет, представляет ли собой аргумент ADate действительное значение существующей даты.DBFilter unit
DropAllFilters
- Процедура деактивирует все фильтры, установленные ранее на набор данных DataSet, и освобождает захваченные ими ресурсы.DBUtils unit:
AssignRecord
- Процедура предназначена для копирования значений полей из текущей записи набора данных Source в поля текущей записи набора данных Dest,CheckRequiredField
- Процедура проверяет заполнение поля Field значением, отличным от NULLConfirmDataSetCancel
- Процедура проверяет, находится ли переданный набор данных DataSet в режиме вставки или замены, модифицированы ли данные текущей записи, и если да, то запрашивает, надо ли сохранять сделанные изменения.ConfirmDelete
- Функция вызывает появление диалога с запросом подтверждения на удаление записи, аналогичного диалогу, появляющемуся у TDBGrid.DataSetSortedSearch
- Функция пытается установить набор данных, переданный в качестве параметра , на первую от начала запись, удовлетворяющую заданному условиюFormatAnsiSQLCondition
- Функция сходна по назначению и результатам с FormatSQLConditionFormatSQLCondition
- Функция возвращает строковое выражение, соответствующее записи логического условия на языке SQL. Используется, в основном, для подстановки параметров (макросов) TRxQuery.FormatSQLDateRange
- Возвращает логическое условие для языка SQL нахождения значения поля, заданного FieldName в интервале, заданном Date1 и Date2. Учитываются особые случаи:RefreshQuery
- Процедура "обновляет" данные для набора данныхRestoreFields
- Процедура восстанавливает из INI-файла IniFile аттрибуты полей набора данных, заданного в DataSet.SaveFields
FileUtil unit:
BrowseComputer
- BrowseComputer brings up a dialog to allow the user to select a network computerBrowseDirectory
ClearDir
CopyFile
DeleteFiles
DeleteFilesEx
DirExists
- The DirExists function determines whether the directory specified as the value of the Name parameter exists.FileDateTime
FileLock
- he FileLock function locks a region in an open fileFileUnlock
GetFileSize
- Функция возвращает размер в байтах файла, заданного параметром FileName.GetSystemDir
- The GetSystemDir function retrieves the path of the Windows system directoryGetTempDir
GetWindowsDir
HasAttr
- Функция возвращает True, если файл FileName имеет аттрибут Attr.LongToShortFileName
LongToShortPath
MoveFile
- Процедура перемещает или переименовывает FileName в файл с именем DestName.NormalDir
- Функция служит для нормализации имени каталогаShortToLongFileName
ShortToLongPath
ValidFileName
- Функция определяет, является ли имя, переданное как параметр FileName, допустимым именем файла.MaxMin unit:
Max
MaxFloat
- Функция MaxFloat возвращает наибольшее число из массива действительных чисел .MaxInteger
- Функция MaxInteger возвращает наибольшее число из массива целых чиселMaxOf
- Функция MaxOf возвращает наибольшее значение из массива значений ValuesMin
MinFloat
MinInteger
MinOf
SwapInt
- Процедура взаимно заменяет значения двух аргументов Int1 и Int2 между собой.SwapLong
Parsing unit:
GetFormulaValue
- Функция вычисляет результат математического выражения, заданного параметром Formula. Для вычислений используется объект типа TRxMathParser.PickDate unit:
PopupDate
- Функция PopupDate вызывает появление диалога выбора датыSelectDate
- Функция SelectDate позволяет пользователю выбрать дату, используя диалог выбора даты с календарем и кнопками навигацииSelectDateStr
- Функция полностью аналогична функции SelectDate, за исключением того, что значение даты передается в нее в виде строки.RxGraph unit:
BitmapToMemory
GetBitmapPixelFormat
GrayscaleBitmap
- This procedure transforms a color bitmap image into grayscaleSaveBitmapToFile
SetBitmapPixelFormat
- Процедура позволяет изменить число цветов (бит на пиксель), используемое для отрисовки битового изображения ABitmapRxHook unit
FindVirtualMethodIndex
- Функция находит индекс виртуального метода объекта класса AClass по адресу метода MethodAddr.GetVirtualMethodAddress
SetVirtualMethodAddress
RxMenus Unit
procedure SetDefaultMenuFont(AFont: TFont);
RxShell unit
FileExecute
FileExecuteWait
- Функция полностью аналогична функции FileExecute, но в отличие от нее приостанавливает выполнение вызвавшего ее потока до завершения запущенного приложения.IconExtract
- Функция создает объект класса TIcon из ресурсов исполнимого файла FileNameWinAbout
- Процедура вызывает стандартное диалоговое окно "About" системы MSWindows.Speedbar Unit
function FindSpeedBar(const Pos: TPoint): TSpeedBar;
SplshWnd Unit
ShowSplashWindow
- Функция создает и отображает форму без заголовка с установленным стилем fsStayOnTop, которую можно использовать как заставку при загрузке приложения или при выполнении длительных операцийStrUtils unit:
AddChar
- Добавляет слева к стpоке S символы C до длины S=N.AddCharR
- Добавляет справа к стpоке S символы C до длины S=N.AnsiProperCase
- Returns string, with the first letter of each word in uppercase, all other letters in lowercase.CenterStr
CompStr
- Сравнивает строки S1 и S2 (с учетом регистра)CompText
- Сравнивает строки S1 и S2 (без учета регистра)Copy2Space
- Копирует с начала строки до первого пробела.Copy2SpaceDel
- Копирует с начала строки до первого пробела и удаляет эту частьCopy2Symb
- Копирует с начала строки S до первого символа Symb и возвращает эту часть исходной строки.Copy2SymbDel
Dec2Hex
- Пpеобpазует целое число N в шестнадцатеричное число, дополняя слева нулями до длины A.Dec2Numb
- Пpеобpазует целое число N в число по основанию B, дополняя слева нулями до длины A.DelBSpace
- Функция удаляет ведущие пpобелы из стpоки S.DelChars
- Функция даляет все символы Сhr из строки S.DelESpace
- Функция удаляет конечные пpобелы из стpоки S.DelRSpace
- Функция удаляет начальные и конечные пpобелы из стpоки S.DelSpace
- Функция удаляет все пробелы из строки.DelSpace1
- Функция удаляет все, кpоме одного, пpобелы из стpоки S.ExtractDelimited
- Функция аналогична функции ExtractWordExtractQuotedString
- ExtractQuotedString removes the Quote characters from the beginning and end of a quoted stringExtractSubstr
- Функция предназначена для выделения подстроки из строки S, если подстроки разделены символами из набора Delims.ExtractWord
- Выделяет N-ое слово из строки S, используя WordDelims (типа TCharSet) как разделитель между словами.ExtractWordPos
- Выделяет N-ое слово из строки S, используя WordDelims (типа TCharSet) как разделитель между словамиFindCmdLineSwitch
FindPart
- FindCmdLineSwitch determines whether a string was passed as a command line argument to the application.GetCmdLineArg
- GetCmdLineArg определяет, имеется ли параметр Switch среди параметров командной строки, переданных в приложение, и возвращает значение этого параметраHex2Dec
- Пpеобpазует шестнадцатеpичное число в стpоке S в целое десятичное.IntToRoman
- IntToRoman converts the given value to a roman numeric string representation.IsEmptyStr
- Функция возвращает True, если строка S содержит только символы из EmptyChars.IsWild
- Функция IsWild сравнивает строку InputString со строкой WildCard, содержащей символы маски, и возвращает True, если строка InputStr соответствует маске.IsWordPresent
- Определяет, присутствует ли слово W в строке S, используя символыWordDelims как возможные разделители между словами.
LeftStr
- Добавляет строку S до длины N справа.MakeStr
- Фоpмиpует стpоку из N символов C.MS
- Фоpмиpует стpоку из N символов C.Npos
- Ищет позицию N-го вхождения подстроки C в стpоке S.Numb2Dec
- Пpеобpазует число по основанию B в стpоке S в целое десятичное.Numb2USA
- Пpеобpазует числовую стpоку S к фоpмату США. Напpимеp: Входная стpока: '12365412'; Выходная стpока: '12,365,412'.OemToAnsiStr
- OemToAnsiStr translates a string from the OEM character set into the Windows character set.QuotedString
- QuotedString returns the given string as a quoted string, using the providedQuote character.
ReplaceStr
- Функция заменяет в строке S все вхождения подстроки Srch на подстроку, переданную в качестве аргумента Replace.RightStr
- Добавляет строку S до длины N слева.RomanToInt
- RomanToInt converts the given string to an integer value.StrToOem
- Конвертирует переданную в качестве аргумента AnsiStr строку (в ANSI-кодировке Windows) в кодировку OEM.Tab2Space
- Преобразует знаки табуляции в строке S в Numb пробелов.WordCount
- Считает число слов в строке S, используя параметр WordDelims (типа TCharSet) как разделитель между словами.WordPosition
- Возвращает позицию первого символа N-го слова в строке S, используя параметр WordDelims (типа TCharSet) как разделитель между словами.VCLUtils unit:
ActivatePrevInstance
- Функция ActivatePrevInstance предназначена для активизации предыдущей копии приложенияActivateWindow
- Процедура ActivateWindow активизирует окно Windows, обработчик которого специфицируется параметром Wnd.AllocMemo
- Функция предназначена для динамического выделения блока памяти размером Size.AnsiUpperFirstChar
- Функция приводит к верхнему регистру первый символ в переданной строке S, используя набор символов ANSI.AssignBitmapCell
- Процедура копирует прямоугольную область из картинки Source в битовое изображение Dest,CenterControl
- Процедура центрирует элемент управления Control относительно "родителя"CenterWindow
- Процедура центрирует окно Wnd на экране дисплея.ChangeBitmapColor
- создает новое графическое изображение, являющееся копией переданного, однако заменяя цвет всех точек изображения,CompareMem
- Функция CompareMem сравнивает содержимое двух блоков памятиCopyParentImage
- Процедура копирует в заданный контекст устройства Dest изображение,CreateBitmapFromIcon
CreateIconFromBitmap
CreateRotatedFont
- Создает "наклонный" шрифтCreateTwoColorsBrushPattern
- Функция создает битовое изображение, состоящее из точек двух цветов: Color1 и Color2, чередующихся в шахматном порядке.DefineCursor
- Загружает курсор из ресурса исполняемого модуля и определяет его уникальный индекс в массиве курсоров Screen.Cursors.Delay
- Процедура вызывает задержку выполнения программы на заданное параметром MSecs число миллисекунд.DialogUnitsToPixelsX
- Функция преобраз. диалоговые единицы в пиксели по горизонтали.DialogUnitsToPixelsY
DrawBitmapRectTransparent
- Процедура DrawBitmapRectTransparent рисует на устройстве Dest прямоугольный участок графического изображенияDrawBitmapTransparent
- Процедура DrawBitmapTransparent рисует на устройстве Dest графическое изображение BitmapDrawCellBitmap
- Процедура DrawCellBitmap предназначена для отрисовки битового изображения BmpDrawCellText
- для отрисовки строки текста S в ячейке объекта - наследника TCustomGrid.DrawInvertFrame
- Процедура рисует на экране инвертированную рамку, определяемую координатами ScreenRectFreeMemo
- Процедура освобождает память, выделенную функцией AllocMemo.FreeUnusedOLE
GetEnvVar
- Возвращает значение переменной окружения DOS, заданной параметром VarName.GetMemoSize
- Функция GetMemoSize возвращает размер блока памяти, выделенного функциейAllocMemo.
GetWindowsVersion
- Функция возвращает версию Windows в виде строки, содержащей название платформы и номер версии операционной системы.GradientFillRect
- Процедура GradientFillRect рисует прямоугольник Rect на устройстве Canvas, цвет которого плавно изменяется от BeginColor до EndColor в направлении Direction.HeightOf
- Функция возвращает высоту (в пикселях) переданного прямоугольника R.HugeDec
- Decrement a huge pointer.HugeInc
HugeMove
HugeOffset
ImageListDrawDisabled
- Процедура рисует изображение из списка Images, заданное индексом Index, на устройстве Canvas с координатами X, YIsForegroundTask
- Функция проверяет, является ли приложение, вызвавшее эту функцию, текущей активной (foreground) задачей Windows.KillMessage
- KillMessage deletes the requested message Msg from the window message queueLoadAniCursor
- The LoadAniCursor function loads the specified animated cursor resource from the executable (.EXE or .DLL) file associated with the specified application instance.LoadDLL
- Функция загружает динамическую библиотеку или модуль, заданный именемLibName.
MakeBitmap
- Функция создает объект класса TBitmap из ресурса вашего приложения.MakeBitmapID
- Функция создает объект класса TBitmap из ресурса вашего приложения.MakeIcon
- Функция создает объект класса TIcon из ресурса вашего приложения.MakeIconID
MakeModuleBitmap
- Функция создает объект класса TBitmap из ресурса любого загруженного модуля (исполняемого файла или DLL)MakeModuleIcon
- Функция создает объект класса TIcon из ресурса любого загруженного модуля (исполняемого файла или DLL).MergeForm
- Процедура предназначена для вставки обычной формы AForm (например, созданной в дизайнере и загруженной из DFM-файла) в элемент управления AControl.MinimizeText
- Эта функция может быть использована для того, чтобы сократить текстовую строку Text до длины, позволяющей отобразить ее целиком на устройстве Canvas на участке длиной MaxWidth.MsgBox
- Функция представляет собой оболочку стандартной функции Windows API MessageBox, только в качестве параметров принимает не PChar, а строки в формате языка Pascal.NotImplemented
- Процедура вызывает появление диалогового окна с сообщением "Функция не реализована" ("Function not yet implemented"), PaintInverseRectPixelsToDialogUnitsX
- Функция преобр пиксели в диалоговые единицы по горизонтали.PixelsToDialogUnitsY
PointInPolyRgn
- Функция возвращает True, если точка с координатами P расположена внутри региона, ограниченного фигурой с вершинами, заданными набором точек Points.PointInRect
- Функция возвращает True, если точка с координатами P расположена внутри прямоугольника R.RegisterServer
- Функция предназначена для регистрации в Windows элементов управления OLE (OCX, ActiveX)ResourceNotFound
- Процедура предназначена для вывода сообщения об ошибке (с генерацией исключения EResNotFound) при ошибке загрузки ресурса из исполняемого файла.ShadeRect
- Процедура служит для "штриховки" прямоугольника RectSplitCommandLine
- Процедура SplitCommandLine разделяет командную строку запуска любой программы на имя исполняемого файла и строку параметров.StartWait
- Процедура StartWait меняет изображение курсора мыши на экране на то, которое определено типизированной константой WaitCursor (по умолчанию crHourGlass), и увеличивает счетчик вызовов StartWait на 1.StopWait
- Процедура StopWait восстанавливает изображение курсора мыши на экране по умолчанию, если оно было изменено процедурой StartWait.WidthOf
- Функция возвращает ширину (в пикселях) переданного прямоугольника R.Win32Check
- Процедура предназначена для использования при вызове функций Win32 API, возвращающих значение типа BOOL, которое определяет, успешно ли выполнилась функция Win32 API.Автор: Pegas
Взято с Vingrad.ru
Процессор, сопроцессор
Процессор, сопроцессор
Cодержание раздела:
Процессы, потоки и функции ShellExecute и WinExec
Процессы, потоки и функции 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.
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;
Взято с сайта
Процессы, потоки, память, задачи
Процессы, потоки, память, задачи
Cодержание раздела:
См. также в других разделах:
Прочитать boot сектор
Прочитать boot сектор
Вообще-то загрузочный сектор можно прочитать вот так:
type
TSector = array[0..511] of Byte;
var
Boot: TSector;
begin
ReadBoot(Drive, Boot);
Но учитывая разницу платформ 95, 98, Me и NT, 2000, XP можно сделать 2 процедуры, а в главной части проги вызывать необходимую:
//для 95, 98, Me
type
TDiocRegisters = record
EBX, EDX, ECX, EAX, EDI, ESI, Flags: LongWord end;
TVWin32CtlCode = (ccNone, ccVWin32IntIoctl, ccVWin32Int25,
ccVWin32Int26, ccVWin32Int13);
function VWin32(CtlCode: TVWin32CtlCode;
var Regs: TDiocRegisters): Boolean; // вспомогательная процедура
var
Device: THandle;
Count: LongWord;
begin
Device := CreateFile('\.\VWIN32', 0, 0, nil, 0,
FILE_FLAG_DELETE_ON_CLOSE, 0);
if Device = INVALID_HANDLE_VALUE then
raise Exception.Create(SysErrorMessage(GetLastError));
try
Result := DeviceIoControl(Device, Ord(CtlCode), @Regs,
SizeOf(Regs), @Regs, SizeOf(Regs), Count, nil);
finally
CloseHandle(Device) end end;
//само чтение
procedure ReadBoot95(Drive: Char; var Boot: TSector);
var
Regs: TDiocRegisters;
begin
with Regs do begin
EAX := Ord(UpCase(Drive)) - Ord('A');
EBX := LongWord(@Boot);
ECX := 1;
EDX := 0 end;
if not VWin32(ccVWin32Int25, Regs) then
raise Exception.Create(SysErrorMessage(GetLastError)) end;
//для NT, 2000, XP попроще
type
TSector = array[0..511] of Byte;
procedure ReadBootNT(Drive: Char; var Boot: TSector);
var
BytesRead: Cardinal;
H: THandle;
begin
H := CreateFile(PChar(Format('\.\%s:', [UpCase(Drive)])),
GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if H = INVALID_HANDLE_VALUE then
raise Exception.Create(SysErrorMessage(GetLastError));
try
if not ReadFile(H, Boot, SizeOf(Boot), BytesRead, nil)then
raise Exception.Create(SysErrorMessage(GetLastError));
finally
CloseHandle(H) end end;
// а юзать так
var
Boot: TSector;
begin
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
ReadBoot95(Drive, Boot);
VER_PLATFORM_WIN32_NT:
ReadBootNT(Drive, Boot) end;
Boot и есть необходимый массив.
Автор:
startingerВзято из
Прочитать список всех запущенных Exe/ Проверить запущен ли Exe?
Прочитать список всех запущенных Exe/ Проверить запущен ли Exe?
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;
Взято с сайта
Проектирование баз данных (статья)
Проектирование баз данных (статья)
Цель данного доклада - оценить сегодняшние проблемы и тенденции развития технологий проектирования БД, а также, хотя бы отчасти - требования завтрашнего дня. Доклад может сыграть еще одну роль: задать набор актуальных требований, которые будут служить координатами для позиционирования конкретных частных методов и инструментов проектирования БД (отчасти также - средств их использования и управления ими), которые представляются в двух специальных секциях данной конференции.
Интегрированная база данных - констатация идеи
Широко известные методы проектирования баз данных (БД) появились в процессе разработки все более сложных Информационных Систем (ИС), которые должны были рассматривать потребности не одного пользователя, но больших групп и коллективов. Одна такая интегрированная БД создавалась для решения многих задач, каждая из которых использовала только "свою" часть данных, обычно, пересекающуюся с частями, используемыми в других задачах. Поэтому главнейшими методами проектирования стали методы исключения избыточности в данных. Эти методы связывались с другими средствами обеспечения логической целостности данных.
Было сформулировано принципиальное требование отделения программ от интегрированных данных. Этот принцип направлен на отчуждение данных в качестве ресурса предприятия, важен также тем, что консервативные по характеру данные отделялись от прикладных программ, которые могли часто подвергаться изменениям.
Другой важной проблемой проектирования БД явилось обеспечение нужных эксплуатационных параметров, таких как объем внешней памяти или время выполнения различных операций. Известны и другие требования. Например, информация не должна потеряться не только из-за отказов оборудования, но и вследствие ошибки пользователя. Это отличается от того положения, при котором тот, кто решает некую задачу, сам и отвечает за сохранность данных для этой задачи.
Сформировалось понимание интегрированной БД как общего информационного ресурса предприятия. Хранимые данные стали аналогичны большому компьютеру, который одновременно используется многими пользователями с различными целями и должен быть все время работоспособен.
За идеей - классическая методология проектирования
Классическая методология проектирования БД - это мощное и красивое течение со своей философией, способами восприятия реальности и способами существования в ней. В этом течении возникла своя прикладная математика, свое понятие "Мира", "Предметной Области" (ПрО) и их моделей. В отношении проектирования БД осознаны и интегрированы в стройные схемы методы выполнения таких проектных этапов:
сбор сведений о ПрО (анализ потребностей и описание ПрО с использованием так называемых "процессного" или 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б]) классические методы проектирования БД должны продолжать использоваться, но только в тех в областях, где они действительно полезны. Методы проектирования, рассматриваемые в конкретных проектах корпоративных ИС и БД, и соответствующие инструменты должны проверяться на свои возможности обеспечивать функции в соответствии с требованиями Нового Системного Проектирования.
Взято из
Программирование без VCL, работа с WinAPI
Программирование без VCL, работа с WinAPI
Cодержание раздела:
См. также в других разделах:
Программирование CGI в Delphi и Kylix (статья)
Программирование CGI в Delphi и Kylix (статья)
Автор: Paul TOTH
Перевод с французского: Valery Votintsev
Взято с Исходников.ru
Содержание:
·Введение ·
·
·
·
·
·
·
Введение
В настоящем руководстве объясняется, как программировать CGI на Delphi и Kylix. Автор будет рад Вашим замечаниям и пожеланиям!
Уточнения:
Для работы с CGI вам потребуется Web-сервер (для Delphi - под Windows, а для Kylix - под Linux)...
Автор тестировал свои программы на сервере Lotus Domino под NT, и на сервере Apache под Mandrake 7.0 (linux).
Автор использовал Delphi 2.0, однако это руководство применимо и для Delphi 3,4,5, 6... и Kylix !
Примечание:
Если вы планируете использовать ISAPI/NSAPI DLL, то лучше будет программировать на Delphi 5/6; однако настоящее руководство остается весьма полезным, если Вы желаете разобраться в том, как функционирует CGI.
Основные понятия
Ссылки на CGI-программу:
На HTML-странице (или непосредственно в строке URL браузера) вы помещаете ссылку на вашу программу. Вот несколько примеров ссылок: Простая ссылка: <a href="/cgi-bin/program.exe">
Запрос вывода изображения: <img src="/cgi-bin/program.exe">
Форма с запросом типа GET: <form method=GET action="/cgi-bin/program.exe"> ... </form>
Форма с запросом типа POST: <form method=POST action="/cgi-bin/program.exe"> ... </form>
Прямое обращение по URL: http://www.tonserver.fr/cgi-bin/program.exe
Что такое cgi-bin:
cgi-bin - это псевдоним каталога на сервере, который указывает на реальный каталог, в котором размещены все CGI программы. Например:
Под Windows: c:\internet\delphi\cgi
Под Linux: /home/httpd/cgi-bin
Запуск CGI-программ:
Когда пользователь кликает на ссылке, указывающей на CGI-программу, сервер запускает данную программу и ожидает от нее ответа. Ответ CGI-программы:
Самым простым вариантом CGI программы может служить консольное приложение {$apptype console}, которое похоже на DOS-программу, однако работает под Windows 95/NT, или под Linux. Эта возможность позволяет тестировать CGI-программу локально, выводя результат работу на экран.
Пример простейшей CGI-программы:
Program ExampleCGI;
{$apptype console}
begin
WriteLn('Content-type: text/html');
WriteLn;
WriteLn('Всем привет !');
end.
Разберем строки, выводимые программой:
1) WriteLn('Content-type: text/html'); - Content-type - это описание типа выводимых данных (в данном случае - текста HTML)
2) WriteLn; - Вывод пустой строки ОБЯЗАТЕЛЕН, для того, чтобы отделить "заголовок" документа от выводимого далее содержимого этого документа.
3) WriteLn('Всем привет !'); - Здесь выводится собственно тело документа, т.е. то, что мы увидим, если нажмем в браузере "Файл - Просмотр в виде HTML"
Для обращения к программе в строке адреса в браузере необходимо набрать:
http://ваш_сервер/cgi-bin/ExampleCGI
Использование Writeln:
Интересно, что под Windows можно написать CGI-программу даже с помощью .BAT-файла!
@ECHO OFF
ECHO content-type: text/html
ECHO.
ECHO ^<HTML^>^<HEAD^>^<TITLE^>^</TITLE^>^</HEAD^>^<BODY^>
ECHO Всем привет !
ECHO ^</BODY^>^</HTML^>
Обратите внимание, что специальные символы, используемые в DOS (такие, как "<", ">", "&",...), необходимо предварять знаком "^".
Не забывайте об этом при написании CGI с .BAT файлами...
Программирование Интернет приложений в Borland Kylix. Часть I
Программирование Интернет приложений в Borland Kylix. Часть I
Создай своих демонов!
Автор: Андрей Боровский () В этой статье речь пойдет о создании интернет серверов (сетевых демонов) в 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. Объявление функции выглядит следующим образом:
functionfork: __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 создается копия процесса демона, а выполнение исходного процесса завершается:
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
...
Здесь pid - глобальная переменная типа Integer. Если при вызове функции fork произошла ошибка, функция возвращает значение -1, и приложение должно завершиться. После удачного вызова функции fork родительскому процессу возвращается pid дочернего процесса, не равный нулю. Родительский процесс завершает работу, а дочерний продолжает выполняться. После завершения родительского процесса контроль над терминалом возвращается запустившей его программе (оболочке), а новый процесс, созданный функцией fork, выполняется в фоновом режиме. Однако наш процесс все еще принадлежит той же группе, что и создавший его процесс. Для того чтобы демон стал полностью независим от запустившего его терминала, новый процесс следует поместить в новую группу, а самый простой способ сделать это - создать новую сессию. (Подробнее о сессиях и группах процессов можно прочесть в [3].) Новая сессия создается вызовом функции setsid:
pid := setsid;
if pid = -1 then // setsid failed
begin
perror( PChar('setsid: ') );
Halt( 1 );
end;
...
Далее мы закрываем стандартный поток ввода и перенаправляем потоки вывода на /dev/null (это необходимо сделать, так как некоторые функции могут использовать стандартные потоки для вывода служебной информации).
Close( Input ); // closing stdin
AssignFile( Output, '/dev/null' );
Rewrite( Output );
AssignFile( ErrOutput, '/dev/null' );
Rewrite( ErrOutput );
...
Теперь процесс выполняется в режиме демона. Сохраним pid процесса в файле dhttpd.pid в каталоге /var/run (зачем это нужно объясняется ниже). Следует отметить, что демон должен запускаться в режиме, предоставляющем полный доступ к ресурсам компьютера, т. е. в режиме root или в ходе загрузки операционной системы. Это необходимо не только для получения доступа к таким каталогам, как /var/run, но и для работы с сокетами, что является основной функцией создаваемого нами приложения.
AssignFile( F, '/var/run/dhttpd.pid' );
Rewrite( F );
pid := getpid;
WriteLn( F, pid );
CloseFile( F );
...
Здесь F - переменная типа Text.
Нам еще необходимо организовать обработку сигналов. Сигналы Linux (их не следует путать с сигналами Qt library) очень похожи на прерывания MS-DOS. Фактически сигналы основаны на программных прерываниях. Когда процессу Linux посылается сигнал, для которого установлен обработчик, выполнение процесса прерывается и вызывается процедура обработчика сигнала. По окончании выполнения обработчика основной процесс возобновляется с той точки, в которой он был прерван, если, конечно, обработчик сигнала не завершил процесс. В Linux процессу предоставлены широкие возможности по управлению обработкой большинства сигналов: Процесс может блокировать сигналы, игнорировать сигналы, назначать свои обработчики сигналов или использовать обработчики, назначенные системой по умолчанию. Характерной особенностью сигналов Linux является асинхронность. Это означает, что незаблокированный сигнал может прервать выполнение программы в любой точке. Данный факт нужно учитывать при написании обработчиков сигналов. Сигналы Linux и их обработка подробно описаны в [3].
Существует два основных подхода к обработке сигналов Linux: первый подход заключается в том, что все действия по обработке сигнала выполняются в процедуре обработчика. При втором подходе обработчик сигнала лишь изменяет значения некоторых глобальных переменных-флажков. Основной процесс периодически проверяет состояние флажков и в случае их изменения выполняет операции, связанные с соответствующим сигналом. Этот подход позволяет синхронизировать обработку сигналов с выполнением других элементов программы.
При программировании нашего демона мы пойдем по второму пути. В программе объявляется глобальная переменная SigNum типа Integer, а в качестве обработчика сигналов служит процедура TranslateSig:
procedure TranslateSig( sig : Integer ); cdecl;
begin
SigNum := sig;
end;
Функция TranslateSig просто присваевает переменной SigNum номер полученного сигнала. В создаваемом демоне мы ограничемся обработкой сигналов SIGTERM и SIGHUP. Связываем обработчик TranslateSig с этими сигналами:
signal( SIGTERM, @TranslateSig );
signal( SIGHUP, @TranslateSig );
Теперь следует задать цикл обработки сигналов. Можно просто проверять значение SigNum в бесконечном цикле, однако есть более изящный и менее ресурсоемкий способ - функция sigsuspend. В качестве единственного параметра этой функции передается маска сигналов - переменная типа __sigset_t. Функция sigsuspend приостанавливает выполнение вызвавшего ее потока до тех пор, пока не поступит один из сигналов, не включенных в маску. В этом случае, если обработчик сигнала не завершает процесс, функция sigsuspend возвращает управление. В следующем фрагменте выполняется установка маски (переменная SigSet) и организуется цикл обработки сигналов с использованием функции sigsuspend:
sigfillset( SigSet );
sigdelset( SigSet, SIGTERM );
sigdelset( SigSet, SIGHUP );
SigNum := 0;
while SigNum <> SIGTERM do
begin
sigsuspend( SigSet );
if SigNum = SIGHUP then
begin
...
pid := fork;
if pid <> 0 then Break; // old process exits
...
end;
end;
Обратите внимание на то, как обрабатывается сигнал SIGHUP. В ответ на сигнал демон создает новую копию процесса (при помощи функции fork), а старый процесс завершается. Именно ради обработки сигнала SIGHUP организован цикл while do.
Полный листинг файла dhttpd.dpr приводится в конце статьи. В программу добавлена обработка опций командной строки. Принцип обработки опций командной строки очень прост: новый процесс читает значение, записанное в файл /var/run/dhttpd.pid, с помощью функции kill посылает ранее запущенному процессу соответствующий сигнал и затем завершается.
В нашем примере не рассмотрена еще одна функция демона - ведение log-файлов. Большинство сетевых демонов записывают данные о транзакциях и о своей работе в специальные файлы. Каждое приложение ведет свой log-файл. Обычно log-файлы хранятся в директории /var/log/. Разумеется, каждое приложение может само создавать и поддерживать такие файлы, однако в Linux существует централизованный механизм ведения log-файлов - демон logd. Главное преимущество использования демона logd заключается в том, что logd скрывает детали процесса ведения log-файлов от приложения. Такие параметры, как физическое размещение файлов, задаются в процессе конфигурации демона logd и не влияют на работу приложения, записывающего логи. Например, демон logd может быть сконфигурирован таким образом, что запись log-файлов будет производиться на удаленный компьютер. Система Linux предоставляет приложениям простой интерфейс для работы с демоном logd. Основные операции выполняются при помощи трех функций: Функция openlog открывает log-файл, closelog - закрывает файл, syslog выполняет запись.
Остальное - Indy
Наша программа теперь обладает всеми атрибутами демона, но она все еще не выполняет никакой полезной работы. Программирование сетевых демонов - непростая задача. Классические демоны Unix используют дочерние процессы для параллельной обработки соединений. На практике, для ускорения работы приложения-демона, часто применяются более сложные схемы, включающие предварительное создание процессов. Подробности можно найти в [2].
В нашем распоряжении, однако, есть компоненты Indy, предоставляющие самый эффективный механизм параллельной обработки соединений - многопоточность. Для того, чтобы при помощи Indy создать Web сервер, обладающий основными функциями по работе с HTTP, нам потребуется создать объект класса TIdHTTPServer (этот класс определен в модуле IdHTTPServer) и назначить обработчик события OnCommandGet.
В создаваемом нами приложении все объекты для работы с Web определены в модуле WebServ, полный текст которого приводится в конце статьи. Константа HTTPDocsDir содержит путь к каталогу, в котором хранятся HTTP файлы. В Linux Mandrake это /var/www/html. Все операции по работе с протоколом HTTP выполняет объект WebServer класса TWebSerever. Экземпляр TWebSerever создается в начале работы демона и уничтожается при завершении процесса. Для того, чтобы наш сервер не конфликтовал со стандартным Web сервером, мы присвоим ему порт 8800. Разбирать здесь подробно работу с компонентами Indy мы не будем, так как во-первых это уже не имеет непосредственного отношения к программированию демонов, а во-вторых детали работы компонента IdHTTPServer исчерпывающе описаны в справочной системе по Indy и прилагающихся примерах.
Теперь можно проверить работу демона. Скомпилировав проект даем в режиме root команду:
#dhttpd
Командная строка тут же снова появляется на экране. Так и должно быть, ведь демон сразу переходит в фоновый режим. Для того, чтобы убедиться в том, что демон работает, откроем броузер и введем в строке адреса: http://localhost:8800/ (префикс http:// следует указывать потому, что порт 8800 не является стандартным портом протокола HTTP). В окне броузера должна появиться страница index.html из каталога, заданного в константе HTTPDocsDir. Если каталог HTTPDocsDir содержит несколько файлов и подкаталогов, можно проверить, как выполняется навигация. При этом следует учесть, что корневому каталогу Web-пространства соответствует каталог HTTPDocsDir. Если значение этой константы - /var/www/html, то URL http://localhost:8800/foo/bar.html будет соответствовать путь /var/www/html/foo/bar.html. Работа демона может быть завершена командой dhttpd -stop, а для перезапуска ранее запущенного демона служит команда dhttpd -restart.
"Вселение демона" в систему
Опции командной строки позволяют нам запускать и останавливать демон в ручном режиме, однако обычно демоны запускаются автоматически в ходе загрузки операционной системы. В таких системах, как Red Hat или Mandrake самый простой способ обеспечить автоматический запуск демона заключается в создании скрипта SysV Init. Скрипты SysV Init можно рассматривать как некий аналог файла autoexec.bat в системе MS-DOS. Скрипты - это исполнимые файлы, написанные на языке сценариев оболочки (shell script language). Для каждого демона создается свой файл скрипта, имя которого обычно совпадает с именем демона. В конце этой статьи приводится скрипт dhttpd, служащий для запуска демона dhttpd.
В Red Hat и Mandrake скрипт dhttpd следует скопировать в каталог /etc/rc.d/init.d/ (не забудьте придать скрипту статус исполнимого файла). Но это еще не все. Каталог /etc/rc.d/ содержит несколько подкаталогов rcX.d, где X - число от 1 до 6, соответствующее уровню, на котором работает система. Каждый из этих каталогов содержит символические ссылки на файлы скриптов, которые следует выполнять при запуске системы на соответствующем уровне. Вы должны создать символические ссылки на скрипт dhttpd в каталогах rcX.d, соответствующих уровням, в которых должен запускаться демон (ссылки можно разместить во всех каталогах). Имя ссылки на скрипт должно соответствовать шаблону SXXname, где XX двузначное число, указывающее очередность запуска программы, а name - любая последовательность символов, обычно соответствующая имени файла скрипта. Например, для скрипта dhttpd имя ссылки может иметь следующий вид: S95dhttpd. Сам исполнимый файл демона, который также имеет имя dhttpd, можно разместить в каталоге /usr/sbin/.
Если все сделано правильно, то при следующем запуске системы, в конце списка сообщений, сопровождающих процесс загрузки, можно будет увидеть сообщение о запуске демона dhttpd. Убедиться в том, что демон работает, можно, как и в предыдущем случае, введя в строке адреса броузера URL "http://localhost:8800/".
program dhttpd;
{$APPTYPE CONSOLE}
uses
Libc, SysUtils, WebServ;
var
F : Text;
SigSet : __sigset_t;
SigNum : Integer;
pid : Integer;
// Signal handler function
procedure TranslateSig( sig : Integer ); cdecl;
begin
SigNum := sig;
end;
begin
// Processing command line arguments
if ParamCount > 0 then
begin
if ParamCount = 1 then
begin
SigNum := 0;
if ParamStr(1) = '-stop' then SigNum := SIGTERM else
if ParamStr(1) = '-restart' then SigNum := SIGHUP;
if SigNum <> 0 then
begin
if FileExists( '/var/run/dhttpd.pid' ) then
begin
AssignFile(F, '/var/run/dhttpd.pid' );
Reset( F );
Read( F, pid );
CloseFile( F );
if kill( pid, SigNum ) = 0 then
Halt( 0 );
end;
WriteLn( 'dhttpd : cannot do ' + ParamStr( 1 ) + '. Maybe the daemon
is not running?' );
Halt( 0 );
end;
end;
WriteLn( 'Use dhttpd -stop to stop the daemon or dhttpd -restart to restart it.' );
Halt( 0 );
end;
// Daemon initialization 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
pid := setsid;
if pid = -1 then // setsid failed
begin
perror( PChar('setsid: ') );
Halt( 1 );
end;
Close( Input ); // closing stdin
AssignFile( Output, '/dev/null' );
Rewrite( Output );
AssignFile( ErrOutput, '/dev/null' );
Rewrite( ErrOutput );
// Now process runs in the daemon mode
WebServer := TWebServer.Create; // Creating server object
AssignFile( F, '/var/run/dhttpd.pid' );
Rewrite( F );
pid := getpid;
WriteLn( F, pid );
CloseFile( F );
signal( SIGTERM, @TranslateSig );
signal( SIGHUP, @TranslateSig );
sigfillset( SigSet );
sigdelset( SigSet, SIGTERM );
sigdelset( SigSet, SIGHUP );
SigNum := 0;
while SigNum <> SIGTERM do
begin
sigsuspend( SigSet );
WebServer.Free;
if SigNum = SIGHUP then // Restarting
begin
pid := fork;
if pid = -1 then Halt(1);
if pid <> 0 then Break; // old process exits
// Now we are in the new child process
WebServer := TWebServer.Create;
AssignFile( F, '/var/run/dhttpd.pid' );
Rewrite(F);
pid := getpid;
WriteLn( F, pid );
CloseFile(F);
end;
end;
end.
unit WebServ;
interface
uses
IdBaseComponent, IdComponent,
IdTCPServer, IdHTTPServer, SysUtils;
type
TWebServer = class( TObject )
IndyHTTP : TIdHTTPServer;
private
procedure HTTPCommandGet( AThread : TIdPeerThread;
RequestInfo : TIdHTTPRequestInfo; ResponseInfo : TIdHTTPResponseInfo);
public
constructor Create;
destructor Destroy; override;
end;
const
HTTPDocsDir = '/var/www/html';
var
WebServer : TWebServer;
implementation
// TWebServer methods
constructor TWebServer.Create;
begin
inherited Create;
IndyHTTP := TIDHTTPServer.Create( nil );
with IndyHTTP do
begin
ServerSoftware := 'DAEMONstration Web server. (c) 2001 Andrei Borovsky';
OnCommandGet := HTTPCommandGet;
TerminateWaitTime := 5000;
DefaultPort := 8800;
// Activate the Server
Active := True;
end;
end;
destructor TWebServer.Destroy;
begin
IndyHTTP.Free;
inherited Destroy;
end;
procedure TWebServer.HTTPCommandGet;
var
FName : String;
begin
FName := HTTPDocsDir + RequestInfo.Document;
if FName[ Length(FName) ] = '/' then FName := FName + 'index.html' else
if DirectoryExists( FName + '/' ) then
begin
// Redirecting directory without a trailing slash
ResponseInfo.Redirect( RequestInfo.Document + '/' );
Exit;
end;
if FileExists( FName ) then
begin
// Serving content
IndyHTTP.ServeFile( AThread, ResponseInfo, FName );
Exit;
end;
// Requested URL not found
ResponseInfo.ResponseNo := 404;
ResponseInfo.ResponseText := 'Requested URL not found';
ResponseInfo.ContentText := 'Error 404 - ' + ResponseInfo.ResponseText;
ResponseInfo.WriteHeader;
ResponseInfo.WriteContent;
end;
end.
Скрипт dhttpd
#!/bin/sh
#
# SysV Init script for DAEMONstration Web server (dhttpd)
#
# pidfile: /var/run/dhttpd.pid
#
# Source function library.
. /etc/rc.d/init.d/functions
case $1 in
start)
echo -n "Starting dhttpd"
daemon dhttpd
echo
touch /var/lock/subsys/dhttpd
;;
stop)
echo -n "Shutting down dhttpd"
killproc dhttpd
echo
rm -f /var/lock/subsys/dhttpd
rm -f /var/run/dhttpd.pid
;;
restart)
$0 stop
$0 start
;;
reload)
echo -n "Reloading dhttpd:"
killproc dhttpd -HUP
echo
;;
*)
echo "Usage: $(basename $0) start|stop|restart|reload"
exit 1
esac
exit 0
Литература
1. Griffin I, Nelson J (1998). Linux Network Programming, Part 1, Linux Journal, #46 February 1998
2. Griffin I, Nelson J (1998). Linux Network Programming, Part 2, Linux Journal, #47 March 1998
3. GLIBC Manual
Статья и примеры программ © 2001 Андрей Наумович Боровский.
Взято с Исходников.Ru
Программирование на основе Win32 API в Delphi (статья)
Программирование на основе Win32 API в Delphi (статья)
© Николай Мазуркин, 1999-2000
Взято с Исходников.ru
1.
2.
3.
4.
Программирование серверов на основе сокетов в Дельфи
Программирование серверов на основе сокетов в Дельфи
Данная статья посвящена созданию приложений архитектуры клиент/сервер в Borland Delphi на основе сокетов ("sockets" - гнезда). В отличие от предыдущей статьи на тему сокетов, здесь мы разберем создание серверных приложений.
Следует сразу заметить, что для сосуществования отдельных приложений клиента и сервера не обязательно иметь несколько компьютеров. Достаточно иметь лишь один, на котором Вы одновременно запустите и сервер, и клиент. При этом нужно в качестве имени компьютера, к которому надо подключиться, использовать хост-имя localhost или IP-адрес - 127.0.0.1.
Итак, начнем с теории. Если Вы убежденный практик (и в глаза не можете видеть всяких алгоритмов), то Вам следует пропустить этот раздел.
Алгоритм работы сокетного сервера
Что же позволяет делать сокетный сервер?.. По какому принципу он работает?.. Сервер, основанный на сокетном протоколе, позволяет обслуживать сразу множество клиентов. Причем, ограничение на их количество Вы можете указать сами (или вообще убрать это ограничение, как это сделано по умолчанию). Для каждого подключенного клиента сервер открывает отдельный сокет, по которому Вы можете обмениваться данными с клиентом. Также отличным решением является создание для каждого подключения отдельного процесса (Thread). Ниже следует примерная схема работы сокетного сервера в Дельфи-приложениях:
Разберем схему подробнее:
·
Определение св-в Port и ServerType
- чтобы к серверу могли нормально подключаться клиенты, нужно, чтобы порт, используемый сервером точно совпадал с портом, используемым клиентом (и наоборот). Свойство ServerType определяет тип подключения (подробнее см.ниже);·
Открытие сокета
- открытие сокета и указанного порта. Здесь выполняется автоматическое начало ожидания подсоединения клиентов (Listen);·
Подключение клиента и обмен данными с ним
- здесь подключается клиент и идет обмен данными с ним. Подробней об этом этапе можно узнать ниже в этой статье и в статье про сокеты (клиентская часть);·
Отключение клиента
- Здесь клиент отключается и закрывается его сокетное соединение с сервером;·
Закрытие сервера и сокета
- По команде администратора сервер завершает свою работу, закрывая все открытые сокетные каналы и прекращая ожидание подключений клиентов.Следует заметить, что пункты 3-4 повторяются многократно, т.е. эти пункты выполняются для каждого нового подключения клиента.
Примечание: Документации по сокетам в Дельфи на данный момент очень мало, так что, если Вы хотите максимально глубоко изучить эту тему, то советую просмотреть литературу и электронную документацию по Unix/Linux-системам - там очень хорошо описана теория работы с сокетами. Кроме того, для этих ОС есть множество примеров сокетных приложений (правда, в основном на C/C++ и Perl).
Краткое описание компонента TServerSocket
Здесь мы познакомимся с основными свойствами, методами и событиями компонента
Свойства
Socket - класс TServerWinSocket, через который Вы имеете доступ к открытым сокетным каналам. Далее мы рассмотрим это свойство более подробно, т.к. оно, собственно и есть одно из главных. Тип: TServerWinSocket;
ServerType - тип сервера. Может принимать одно из двух значений: stNonBlocking - синхронная работа с клиентскими сокетами. При таком типе сервера Вы можете работать с клиентами через события OnClientRead и OnClientWrite. stThreadBlocking - асинхронный тип. Для каждого клиентского сокетного канала создается отдельный процесс (Thread). Тип: TServerType;
ThreadCacheSize - количество клиентских процессов (Thread), которые будут кэшироваться сервером. Здесь необходимо подбирать среднее значение в зависимости от загруженности Вашего сервера. Кэширование происходит для того, чтобы не создавать каждый раз отдельный процесс и не убивать закрытый сокет, а оставить их для дальнейшего использования. Тип: Integer;
Active - показатель того, активен в данных момент сервер, или нет. Т.е., фактически, значение True указывает на то, что сервер работает и готов к приему клиентов, а False - сервер выключен. Чтобы запустить сервер, нужно просто присвоить этому свойству значение True. Тип: Boolean;
Port - номер порта для установления соединений с клиентами. Порт у сервера и у клиентов должны быть одинаковыми. Рекомендуются значения от 1025 до 65535, т.к. от 1 до 1024 - могут быть заняты системой. Тип: Integer;
Service - строка, определяющая службу (ftp, http, pop, и т.д.), порт которой будет использован. Это своеобразный справочник соответствия номеров портов различным стандартным протоколам. Тип: string;
Методы
Open - Запускает сервер. По сути, эта команда идентична присвоению значения True свойству Active;
Close - Останавливает сервер. По сути, эта команда идентична присвоению значения False свойству Active.
События
OnClientConnect - возникает, когда клиент установил сокетное соединение и ждет ответа сервера (OnAccept);
OnClientDisconnect - возникает, когда клиент отсоединился от сокетного канала;
OnClientError - возникает, когда текущая операция завершилась неудачно, т.е. произошла ошибка;
OnClientRead - возникает, когда клиент передал берверу какие-либо данные. Доступ к этим данным можно получить через пеаедаваемый параметр Socket: TCustomWinSocket;
OnClientWrite - возникает, когда сервер может отправлять данные клиенту по сокету;
OnGetSocket - в обработчике этого события Вы можете отредактировать параметр ClientSocket;
OnGetThread - в обработчике этого события Вы можете определить уникальный процесс (Thread) для каждого отдельного клиентского канала, присвоив параметру SocketThread нужную подзадачу TServerClientThread;
OnThreadStart, OnThreadEnd - возникает, когда подзадача (процесс, Thread) запускается или останавливается, соответственно;
OnAccept - возникает, когда сервер принимает клиента или отказывает ему в соединении;
OnListen - возникает, когда сервер переходит в режим ожидания подсоединения клиентов.
TServerSocket.Socket (TServerWinSocket)
Итак, как же сервер может отсылать данные клиенту? А принимать данные? В основном, если Вы работаете через события OnClientRead и OnClientWrite, то общаться с клиентом можно через параметр ClientSocket (TCustomWinSocket). Про работу с этим классом можно прочитать в статье про клиентские сокеты, т.к. отправка/посылка данных через этот класс аналогична - методы (Send/Receive)(Text,Buffer,Stream). Также и при работе с TServerSocket.Socket. Однако, т.к. здесь мы рассматриваем сервер, то следует выделить некоторые полезные свойства и методы:
·
ActiveConnections
(Integer) - количество подключенных клиентов;·
ActiveThreads
(Integеr) - количество работающих процессов;·
Connections
(array) - массив, состоящий из отдельных классов TClientWinSocket для каждого подключенного клиента. Например, такая команда:·
ServerSocket1.Socket.Connections[0].SendText('Hello!');
·отсылает первому подключенному клиенту сообщение 'Hello!'. Команды для работы с элементами этого массива - также (Send/Receive)(Text,Buffer, Stream);
·
IdleThreads
(Integer) - количество свободных процессов. Такие процессы кэшируются сервером (см. ThreadCacheSize);·
LocalAddress
, LocalHost, LocalPort - соответственно - локальный IP-адрес, хост-имя, порт;·
RemoteAddress
, RemoteHost, RemotePort - соответственно - удаленный IP-адрес, хост-имя, порт;·Методы Lock и UnLock - соответственно, блокировка и разблокировка сокета.
Практика и примеры
А теперь рассмотрим вышеприведенное на конкретном примере. Скачать уже готовые исходники можно, щелкнув здесь. Итак, рассмотрим очень неплохой пример работы с TServerSocket (этот пример - наиболее наглядное пособие для изучения этого компонента). В приведенных ниже исходниках демонстрируется протоколирование всех важных событий сервера, плюс возможность принимать и отсылать текстовые сообщения:
Пример 1. Протоколирование и изучение работы сервера, посылка/прием сообщений через сокеты.
{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}
{Полный исходник смотри здесь}
procedure TForm1.Button1Click(Sender: TObject);
begin
{Определяем порт и запускаем сервер}
ServerSocket1.Port := 1025;
{Метод Insert вставляет строку в массив в указанную позицию}
Memo2.Lines.Insert(0,'Server starting');
ServerSocket1.Open;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
{Останавливаем сервер}
ServerSocket1.Active := False;
Memo2.Lines.Insert(0,'Server stopped');
end;
procedure TForm1.ServerSocket1Listen(Sender: TObject;
Socket: TCustomWinSocket);
begin
{Здесь сервер "прослушивает" сокет на наличие клиентов}
Memo2.Lines.Insert(0,'Listening on port '+IntToStr(ServerSocket1.Port));
end;
procedure TForm1.ServerSocket1Accept(Sender: TObject;
Socket: TCustomWinSocket);
begin
{Здесь сервер принимает клиента}
Memo2.Lines.Insert(0,'Client connection accepted');
end;
procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
{Здесь клиент подсоединяется}
Memo2.Lines.Insert(0,'Client connected');
end;
procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
{Здесь клиент отсоединяется}
Memo2.Lines.Insert(0,'Client disconnected');
end;
procedure TForm1.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
{Произошла ошибка - выводим ее код}
Memo2.Lines.Insert(0,'Client error. Code = '+IntToStr(ErrorCode));
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
{От клиента получено сообщение - выводим его в Memo1}
Memo2.Lines.Insert(0,'Message received from client');
Memo1.Lines.Insert(0,'> '+Socket.ReceiveText);
end;
procedure TForm1.ServerSocket1ClientWrite(Sender: TObject;
Socket: TCustomWinSocket);
begin
{Теперь можно слать данные в сокет}
Memo2.Lines.Insert(0,'Now can write to socket');
end;
procedure TForm1.ServerSocket1GetSocket(Sender: TObject; Socket: Integer;
var ClientSocket: TServerClientWinSocket);
begin
Memo2.Lines.Insert(0,'Get socket');
end;
procedure TForm1.ServerSocket1GetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket;
var SocketThread: TServerClientThread);
begin
Memo2.Lines.Insert(0,'Get Thread');
end;
procedure TForm1.ServerSocket1ThreadEnd(Sender: TObject;
Thread: TServerClientThread);
begin
Memo2.Lines.Insert(0,'Thread end');
end;
procedure TForm1.ServerSocket1ThreadStart(Sender: TObject;
Thread: TServerClientThread);
begin
Memo2.Lines.Insert(0,'Thread start');
end;
procedure TForm1.Button3Click(Sender: TObject);
var i: Integer;
begin
{Посылаем ВСЕМ клиентам сообщение из Edit1}
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do begin
ServerSocket1.Socket.Connections[i].SendText(Edit1.Text);
end;
Memo1.Lines.Insert(0,'< '+Edit1.Text);
end;
Далее мы будем рассматривать уже не примеры, а приемы работы с TServerSocket.
Приемы работы с TServerSocket (и просто с сокетами)
Хранение уникальных данных для каждого клиента.
Наверняка, если Ваш сервер будет обслуживать множество клиентов, то Вам потребуется хранить какую-либо информацию для каждого клиента (имя, и др.), причем с привязкой этой информации к сокету данного клиента. В некоторых случаях делать все это вручную (привязка к handle сокета, массивы клиентов, и т.д.) не очень удобно. Поэтому для каждого сокета существует специальное свойство - Data. На самом деле, Data - это всего-навсего указатель. Поэтому, записывая данные клиента в это свойство будьте внимательны и следуйте правилам работы с указателями (выделение памяти, определение типа, и т.д.)! Посылка файлов через сокет.
Здесь мы рассмотрим посылку файлов через сокет (по просьбе JINX-а) :-). Итак, как же послать файл по сокету? Очень просто! Достаточно лишь открыть этот файл как файловый поток (TFileStream) и отправить его через сокет (SendStream)! Рассмотрим это на примере:
{Посылкафайла через сокет}
procedure SendFileBySocket(filename: string);
var srcfile: TFileStream;
begin
{Открываем файл filename}
srcfile := TFileStream.Create(filename,fmOpenRead);
{Посылаем его первому подключенному клиенту}
ServerSocket1.Socket.Connections[0].SendStream(srcfile);
{Закрываем файл}
srcfile.Free;
end;
Нужно заметить, что метод SendStream используется не только сервером, но и клиентом (ClientSocket1.Socket.SendStream(srcfile))
Почему несколько блоков при передаче могут обьединяться в один
Это тоже по просьбе JINX-а :-). За это ему огромное спасибо! Итак, во-первых, надо заметить, что посылаемые через сокет данные могут не только объединяться в один блок, но и разъединяться по нескольким блокам. Дело в том, что сокет - обычный поток, но в отличие, скажем, от файлового (TFileStream), он передает данные медленнее (сами понимаете - сеть, ограниченный трафик, и т.д.). Именно поэтому две команды:
ServerSocket1.Socket.Connections[0].SendText('Hello, ');
ServerSocket1.Socket.Connections[0].SendText('world!');
совершенно идентичны одной команде:
ServerSocket1.Socket.Connections[0].SendText('Hello, world!');
И именно поэтому, если Вы отправите через сокет файл, скажем, в 100 Кб, то тому, кому Вы посылали этот блок, придет несколько блоков с размерами, которые зависят от трафика и загруженности линии. Причем, размеры не обязательно будут одинаковыми. Отсюда следует, что для того, чтобы принять файл или любые другие данные большого размера, Вам следует принимать блоки данных, а затем объединять их в одно целое (и сохранять, например, в файл). Отличным решением данной задачи является тот же файловый поток - TFileStream (либо поток в памяти - TMemoryStream). Принимать частички данных из сокета можно через событие OnRead (OnClientRead), используя универсальный метод ReceiveBuf. Определить размер полученного блока можно методом ReceiveLength. Также можно воспользоваться сокетным потоком (см. статью про TClientSocket). А вот и небольшой примерчик (приблизительный):
{Прием файла через сокет}
procedure TForm1.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var l: Integer;
buf: PChar;
src: TFileStream;
begin
{Записываем в l размер полученного блока}
l := Socket.ReceiveLength;
{Заказываем память для буфера}
GetMem(buf,l+1);
{Записываем в буфер полученный блок}
Socket.ReceiveBuf(buf,l);
{Открываем временный файл для записи}
src := TFileStream.Create('myfile.tmp',fmOpenReadWrite);
{Ставим позицию в конец файла}
src.Seek(0,soFromEnd);
{Записываем буфер в файл}
src.WriteBuffer(buf,l);
{Закрываем файл}
src.Free;
{Освобождаем память}
FreeMem(buf);
end;
Как следить за сокетом
Это вопрос сложный и требует долгого рассмотрения. Пока лишь замечу, что созданный Вашей программой сокет Вы можете промониторить всегда :-). Сокеты (как и большинство объектов в Windows) имеют свой дескриптор (handle), записанный в свойстве Handle. Так вот, узнав этот дескриптор Вы свободно сможете управлять любым сокетом (даже созданным чужой программой)! Однако, скорее всего, чтобы следить за чужим сокетом, Вам придется использовать исключительно функции WinAPI Sockets.
Эпилог
В этой статье отображены основные приемы работы с компонентом TServerSocket в Дельфи и несколько общих приемов для обмена данными по сокетам. Если у Вас есть вопросы - скидывайте их мне на E-mail: snick@mailru.com, а еще лучше - пишите в конференции этого сайта (Delphi. Общие вопросы), чтобы и другие пользователи смогли увидеть Ваш вопрос и попытаться на него ответить! Карих Николай (Nitro). Московская область, г.Жуковский
Взято с Исходников.ru
Программирование Sound Blaster
Программирование Sound Blaster
Статья взята с " target=_blankhttp://www.programmist.info[/i]
Программирование Sound Blaster
Sound Blaster воспроизводит как синтезированный звук так и оцифровые звуки.
В этом файле будет расмотрено программирование воспроизведения цифровых
выборок через Sound Blaster DSP.
+-------------------------------------+-------------------------------------
| Порты ввода/вывода SoundBlaster DSP |
+=====================================+
Чип DSP ( Цифровой Звуковой Процессор ) программируется через пять портов,
которые определяются через базовый адрес Sound Blaster:
2x6h - DSP Сброс
2xAh - DSP Чтение
2xCh - DSP Запись (команды/данные) ,
состояние буфера записи DSP( Бит 7 )
2xEh - Состояние буфер чтения DSP ( Бит 7 ),
подтверждение прерывания DSP
Пятый порт только для Sound Blaster 16
2xFh - подтверждение прерывания DSP с 16 битами
Где x = 1 для базового адреса 210h.
x = 2 для базового адреса 220h.
.
.
x = 6 для базового адреса 260h.
+-----------+----------------------------------------------------------------
| Сброс DSP |
+===========+
Необходимо сбросить DSP прежде, чем начать работу с ним. Сброс осуществляется
по следующему алгоритму:
1) Запишите 1 в порт сброса (2x6)
2) Ждите 3 микросекунды
3) Запишите 0 в порт сброса (2x6)
4) Читайте порт состояния буфера чтения (2xE) пока бит 7 = 1
5) Опрашивайте порт данных чтения (2xA) пока вы не получите AAh.
Для сброса DSP требуется около 100 мкс. Если после этого вы не получили
AAh. Значит, либо нет звуковой платы, или задан был неверный базовый
адрес.
Пример:
#define MAX_BASE_SB 5
int bases[MAX_BASE_SB]={ 0x220, 0x230, 0x240, 0x250, 0x260 };
int baseAddrSB=0x220;
// Прочитать
unsigned char pascal ReadSB
(void)
{
unsigned int value;
while (!(inp((baseAddrSB+0xE)) & 0x80));
value = inp((baseAddrSB+0xA));
return value;
}
// Проверить наличие
char pascal CheckSB
( void )
{
int i, j;
for ( j=0; j 23 KHz. Затем младший
байт длины, потом старший.
WriteSB(DMA_8_BIT_DAC);
WriteSB(lo(len));
WriteSB(hi(len));
24h - Включение записи с ADC 8 Бит 4KHz - > 23 KHz
74h - Включение вывода на DAC 4 Бит ADPCM 4KHz - > 12 KHz
75h - Включение вывода на DAC 4 Бит ADPCM с 4KHz - > 12 KHz с байтом ссылки
76h - Включение вывода на DAC 2.6 Бит ADPCM 4KHz - > 13 KHz
77h - Включение вывода на DAC 2.6 Бит ADPCM с 4KHz - > 13 KHz с байтом ссылки
16h - Включение вывода на DAC 2 Бит ADPCM 4KHz - > 11 KHz
17h - Включение вывода на DAC 2 Бит ADPCM с 4KHz - > 11 KHz с байтом ссылки
ADPCM ( Адаптивная Импульсно-кодовая Модуляция) - это звуковая методика
сжатия, где различие между последовательными выборками сохраняется скорее
чем их фактические значения. В режимах с байтами ссылки, первый байт -
фактическое начальное значение. Наличие режимов с и без байтов ссылки значит
что вы можете выводить последовательные блоки без наличия байта ссылки.
Bxh - программмирование режима DMA с 16 битным цифровым звуком.
( Только для SB16 )
Командная последовательность:
Команда, Режим, Lo(Length-1), Hi(Length-1):
Первый байт команды состоит:
D7 D6 D5 D4 D3 D2 D1 D0
--+--+--+--+---+----+-----+--
1 0 1 1 A/D A/I FIFO 0
---------------+----+-----+--
0=D/A 0=SC 0=off
1=A/D 1=AI 1=on
Общие команды:
B8 - одиночный цикл с 16-битной записи звука
B0 - одиночного цикла с 16-битным воспроизведением
BE - автоинициализируемая 16-битная запись
B6 - автоинициализируемое 16-битной воспроизведение
Режим:
D7 D6 D5 D4 D3 D2 D1 D0
---+--+-------+-----+--+--+--+--
0 0 Стерео Знак 0 0 0 0
0-Моно 0-без
1-Стерео 1-со знаком
Cxh - программирование режим DMA с 8-битным цифровым звуком.
( Только для SB16 )
Те же самые команды, что для 16-бит.
C8 - одиночный цикл с 8-битной записи звука
C0 - одиночного цикла с 8-битным воспроизведением
CE - автоинициализируемая 8-битная запись
C6 - автоинициализируемое 8-битной воспроизведение
FIFO используется чтобы удалять несогласованности в тот период выборки,
когда звуковая плата не способна получить DMA, когда это требуется.
Без FIFO плата делает попытку захвата DMA в точно тот момент, когда
требуется выборка. Если другое устройство с более высоким приоритетом
обращается к DMA, звуковая плата ожидает и скорость выборки может
уменьшаться. FIFO позволяет во время выборки с DMA быть более гибким DSP
без потери звукового качества. FIFO очищается всякий раз, когда команда
посылается DSP. В режиме одиночного цикла, DSP постоянно перепрограммируется.
С FIFO DSP может еще содержать данные, который не были выданы, когда
команда очистила DAC. Чтобы избежать этого, FIFO должен быть переключен
в режим с одиночным циклом. Затем, снова переведен в автоинициализируемый
режим, когда DSP не перепрограммируется.
1Ch - Включение вывода на DAC 8 Бит 4KHz - > 23 KHz с автоинциализацией
90h - Включение вывода на DAC 8 бит 4kHz - > 44 KHz с автоинициализацией
48h - Установить длину блока на пересылку перед посылкой 91h, 99h
сначала младший байт затем старший длину.
91h - Включение вывода на DAC 8 бит 4kHz - > 44 KHz стерео
99h - Включение записи с ADC 8 бит 4kHz - > 44 KHz стерео
WriteSB(SET_LEN_DMA_8_BIT);
WriteSB(lo(len));
WriteSB(hi(len));
WriteSB(DMA_8_BIT_DAC_HI);
D0h - остановить 8-битный DMA
D4h - возобновить 8-битный DMA
D5h - остановить 16-битный DMA
D6h - возобновить 16-битный DMA
Эти команды пригодны как и для автоинциализированного режима,
так и для одиночных циклов.
D9h - Выход из авто инициализируемого режима DMA с 16 битами
после окончания текущего блока.
DAh - Выход из авто инициализируемого режима DMA с 8 битами
после окончания текущего блока.
E1h - Получить номер версии DSP. После посылки этой команды, прочитайте
из DSP два байта. Первый байт - главный номер версии и второй
байт - малый номер версии. Версия 4.00 - это SB16.
Версия | Стерео | Частота | FIFO | 16 бит
--------+--------+----------+------+--------
< 2.00 | - | до 21379 | - | -
>= 2.00 | - | до 21379 | + | -
>= 2.01 | - | до 43478 | + | -
>= 3.00 | + | до 43478 | + | -
>= 3.01 | + | до 43478 | + | +
Пример определения версии:
int pascal VersionSB
( void )
{
char ch, ch1;
WriteSB(0xE1);
ch=ReadSB();
ch1=ReadSB();
verSB=ch<<8 | ch1;
if ( verSB>=0x200 )
Fifo=1;
if ( verSB>=0x201 )
MaxFrequency=1;
if ( verSB>=0x300 )
Stereo=1;
if ( verSB>=0x301 )
SixteenBit=1;
return verSB;
}
+----------------------+----------------------------------------------------
| Программирование DMA |
+======================+
Контроллер DMA (Прямого Доступа В память) управляет пересылками данных
между устройствами ввода/вывода и памятью без использования центрального
процессора. IBM совместимая ЭВМ имеет два контроллера DMA один для
пересылок с 8 битами и другой для пересылок с 16 битами. Контроллер DMA,
вместе с внешним регистром страницы, способен на перемещение блоков по 64 КБ.
Ниже приведена информация по программированию DMA.
Адреса портов для адреса DMA и регистров счета.
Контроллер | Адрес | Функция
---------------+---------+-----------------
DMA 1 | 00 | Канал 0 адреса
c 8 битами | 01 | Канал 0 счета
Подчиненный | 02 | Канал 1 адрес
| 03 | Канал 1 счета
| 04 | Канал 2 адреса
| 05 | Канал 2 счета
| 06 | Канал 3 адреса
| 07 | Канал 3 счета
--------------+---------+------------------
DMA 2 | C0 | Канал 4 адреса
с 16 битами | C2 | Канал 4 счета
Ведущий | C4 | Канал 5 адреса
| C6 | Канал 5 счета
| C8 | Канал 6 адреса
| CA | Канал 6 счета
| CC | Канал 7 адреса
| CE | Канал 7 счета
Адреса портов для регистров управления
Адрес | Операция| Функция
DMAC1 DMAC2 | |
------------+---------+-----------------------------------
0A D4 | Запись | регистр маски
0B D6 | Запись | регистр режима
0C D8 | Запись | регистр сброс байта flip-flop
Адреса портов для младших регистров страницы
Адрес | Функция
--------+-----------------------------------
81 | 2 Канал DMA с 8 битами
82 | 3 Канал DMA с 8 битами
83 | 1 Канал DMA с 8 битами
87 | 0 Канал DMA с 8 битами
89 | 6 Канал DMA с 16 битами
8A | 7 Канал DMA с 16 битами
8B | 5 Канал DMA с 16 битами
Бита регистра режима
БИТ | Функция
---------+----------------------------------
Биты 7:6 | Биты выбора Режима
00 | Выбранный Режим запроса
01 | Одиночный выбранный режим
10 | Выбранный блочный режим
11 | Каскадный выбранный режим
---------+----------------------------------
Бит 5 | Бит приращения / декремента Адреса
1 | Выбранный Декремент адреса
0 | Выбранное Приращение адреса
---------+----------------------------------
Бит 4 | Авто инициализация
1 | Автоинициализация включена
0 | Одиночный
---------+----------------------------------
Биты 3:2 | Биты Пересылки
00 | Проверите пересылку
01 | Запишите пересылку ( К памяти )
10 | Читайте пересылку ( Из памяти )
11 | Запрещенный
** | Игнорируется если биты 7:6 = 11
---------+----------------------------------
Биты 1:0 | Биты выбора Канала
00 | Выберите канал 0 (4)
01 | Выберите канал 1 (5)
10 | Выберите канал 2 (6)
11 | Выберите канал 3 (7)
Биты маски записи
БИТ | Функция
----------+-----------------------------------
Биты 7:3 | Неиспользуемый ( Набор к 0 )
|
Бит 2 | Установить/сбросить бит маски
1 | Установить бит маски ( Отключите канал )
0 | Сбросить бит маски ( Доступен канал )
----------+------------------------------------
Биты 1:0 | Биты выбора Канала
00 | канал 0 (4)
01 | канал 1 (5)
10 | канал 2 (6)
11 | канал 3 (7)
DMAC2 используется для работы с 16 битами и DMAC1 используется для
работы с 8 битами. Вот пример программирования DMA:
1) Вычислите абсолютный линейный адрес вашего буфера
LinearAddr = MK_SEG( Buf ) * 16L + MK_OFF ( Buf );
2) Отключите канал DMA звуковой платы установкой бита маски
outp(MaskPort, 1 + ( DMAChannel % 4 ));
3) Очистите указатель байта flip-flop
outp(ClrPort, DMAChannel );
4) Запишите режим DMA для пересылки
Биты выбора режима должны устанавливаться в 00h для режима запроса.
Адрес бита +/- должен устанавливаться в 0 для приращения адреса.
Бит автоинициализации должен устанавливаться соответственно.
Биты пересылки должны устанавливаться в 10h для воспроизведения и
01h для записи. Выбор канала должен устанавливаться так же как и на
канал DMA звуковой платы.
outp(ModePort, Mode + ( DMAChannel % 4 ));
Некоторые часто используемые режимы:
48h + Канал - одиночный цикл воспроизведение
58h + Канал - автоинициализируемое воспроизведение
44h + Канал - запись одиночного цикла
54h + Канал - автоинициализируемая запись
5) Запишите смещение буфера, младший байт затем старший байт. Для
шестнадцати разрядных данных, смещение должно быть в словах от начала
128k-байтной страницы, для 8-битных от 64K. Самый простой метод для
вычисления смещения с 16 битами - это разделить линейный адрес на
два перед вычислением смещения.
#define lo(value) (unsigned char)((value) & 0x00FF)
#define hi(value) (unsigned char)((value) >> 8)
if ( SixteenBit==1 )
BufOffset= ( LinearAddr / 2 ) % 65536;
else BufOffset= LinearAddr % 65536;
outp(BaseAddrPort, lo(BufOffset));
outp(BaseAddrPort, hi(BufOffset));
6) Запишите длину пересылки в соответствующий порт счета, младший
байт затем старший байт. Для пересылки с 8 битами, запишите
длину в байтах минус единица. Для пересылки с 16 битами, запишите
номер длину в словах минус единица.
if ( SixteenBit==1 )
TransferLength/=2;
outp(CountPort, lo(TransferLength-1));
outp(CountPort, hi(TransferLength-1));
7) Запишите страницу буфера в регистр страницы DMA.
outp(PagePort, ( LinearAddr / 65536));
8) Включите DMA звуковой платы очистив соответствующий бит маски
outp(MaskPort, DMAChannel % 4);
Пример :
int MaskPort, ClrPort, ModePort, ModeDMA, CountPort, PagePort,
BaseAddrPort;
int pageports[4]={ 0x87, 0x83, 0x81, 0x82 };
MaskPort=0x0A; ClrPort=0xC; ModePort=0xB;
ModeDMA=0x48+DMAChannel;
CountPort=1+DMAChannel*2;
BaseAddrPort=DMAChannel*2;
PagePort=pageports[DMAChannel];
outportb(MaskPort, 4 + DMAChannel);
outportb(ClrPort, DMAChannel );
outportb(ModePort, ModeDMA );
outportb(BaseAddrPort,lo(aligned_physical));
outportb(BaseAddrPort,hi(aligned_physical));
outportb(PagePort,(unsigned char)((aligned_physical>>16)&0xFF));
outportb(CountPort,lo(len-1));
outportb(CountPort,hi(len-1));
outportb(MaskPort, DMAChannel );
+---------------------------+------------------------------------------------
| Установка частоты выборки |
+===========================+
Для версии Sound Blaster ниже 4.00 установка частоты выборки выполняется
посылкой DSP команды 40h. При этом частота преобразуется к константе времени
по формуле:
4KHz - > 23 KHz:
Time Constant = 256 - (1,000,000 / sampling rate)
= 256 - (1,000,000 / 8,000 )
= 131
4KHz - > 44 KHz:
Time Constant = (MSByte of) 65536 - (256,000,000 / sampling rate)
= (MSByte of) 65536 - (256,000,000 / 44,100)
= (MSByte of) 59731
= (MSByte of) 0E953h
= 0E9h
void pascal RateSB
( unsigned int rate )
{
unsigned char tc;
if ( MaxFrequency==0 )
{
if ( rate<5000 ) rate=5000;
if ( rate>22528 ) rate=22528;
tc = (unsigned char)(256 - (1000000/rate));
}
else
{
if ( rate<5000 ) rate=5000;
if ( rate>45056 ) rate=45056;
tc = (unsigned char)(hi((unsigned int)(65536-(256000000L/rate))));
}
WriteSB(TIME_CONSTANT);
WriteSB(tc);
}
В отличие от этого SB16 программируется фактической частотой выборки.
Команда 41h используется для воспроизведения, а 42h используется для записи.
if ( Play==1 )
WriteSB ( 0x41 );
else WriteSB ( 0x42 );
WriteSB ( hi( frequency ) );
WriteSB ( lo( frequency ) );
+---------------------------------------+------------------------------------
| Алгоритм цифрового ввода/вывода звука |
+=======================================+
Чтобы записывать или воспроизводить звук, вы должны использовать следующую
последовательность:
1) Распределите буфер который не пересекает границу 64 Kb
2) Установите программу обработки прерывания.
3) Запрограммируйте контроллер DMA для фоновой пересылки
4) Установите частоту выборки
5) Запишите команду I/O в DSP
6) Запишите режим пересылки I/O в DSP
7) Запишите размер блока в DSP ( Младший байт/Старший байт )
После этого сразу начнется запись или воспроизведение звука.
Выделение памяти под буфер DMA:
data=(char far *)farmalloc(131000L);
if ( data==NULL )
{
printf("Нет места под буфер DMA\n");
return 0;
}
physical=((unsigned long)FP_OFF(data))+(((unsigned long)FP_SEG(data))<<4);
aligned_physical=physical+0x0FFFFL;
aligned_physical&=0xF0000L;
aligned=MK_FP((unsigned )((aligned_physical >> 4) & 0xFFFF),0);
Ниже приведены примеры последовательностей для программирования SB
с помощью DMA.
Нормальная частота, воспроизведение:
1) Записать D1h в 2xCh
2) Установить обработчик прерывания
3) Записать 40h в 2xCh
4) Записать константы времени в 2xCh
5) Запрограммировать DMA
6) Записать 14h в 2xCh
7) Записать длину выборки
8) Обслуживать прерывания, до окончания выборки
9) Восстановить старый обработчик
10) Записать D3h в 2xCh
При этом можно записывать любые команды в DSP, пока идет воспроизведение.
Повышенная частота, воспроизведение:
1) Записать D1h в 2xCh
2) Установить обработчик прерывания
3) Записать 40h в 2xCh
4) Записать константы времени в 2xCh
5) Запрограммировать DMA
6) Записать 48h в 2xCh
7) Записать длину выборки
8) Записать 91h в 2xCh
9) Обслуживать прерывания, до окончания выборки
10) Восстановить старый обработчик
11) Записать D3h в 2xCh
Нормальная частота, запись звука:
1) Установить обработчик прерывания
2) Записать 40h в 2xCh
3) Записать константы времени в 2xCh
4) Запрограммировать DMA
5) Записать 24h в 2xCh
6) Записать длину выборки
7) Обслуживать прерывания, до окончания выборки
8) Восстановить старый обработчик
При этом можно посылать любые команды в DSP, пока идет запись.
Повышенная частота, запись:
1) Установить обработчик прерывания
2) Записать 40h в 2xCh
3) Записать константы времени в 2xCh
4) Запрограммировать DMA
5) Записать 48h в 2xCh
6) Записать длину выборки
7) Записать 99h в 2xCh
8) Обслуживать прерывания, до окончания выборки
9) Восстановить старый обработчик
+------------------------------------+--------------------------------------
| Конец цифрового ввода/вывода звука |
+====================================+
Когда пересылка закончена генерируется прерывание. Фактический номер
прерывания зависит от установки IRQ на плате Sound Blaster:
IRQ | Прерывание
-----+------------
2 | 0Ah
3 | 0Bh
5 | 0Dh
7 | 0Fh
Для обслуживания прерывания необходимо выполнить:
1) подтвердите прием прерывания от DSP прочитав порт (2xEh) один раз для
8-битного звука, или порт 2xF для 16-битного звука.
2) Вывод следующего буфера, если есть.
3) Выведите значение 20h ( EOI ) в порт контроллера прерывания 20h,
а если IRQ8-15(прерывания 70h-77h), то записать 20h в A0h.
Установка прерывания :
DMA_complete = 0;
disable();
OldIRQ = getvect(0x08 + SbIRQ);
setvect(0x08 + SbIRQ,SBHandler);
enable();
Обработчик прерывания :
static void far interrupt SBHandler( void )
{
enable();
DMA_complete = 1;
// подтведить
inportb(baseAddrSB+0xE);
outportb(0x20,0x20);
}
Инициализация обработчика :
DMA_complete = 0;
im = inportb(0x21);
tm = ~(1 << SbIRQ);
outportb(0x21,im & tm);
enable();
Сброс обработчика :
disable();
setvect(0x08 + SbIRQ,OldIRQ);
i = inportb(0x21);
outportb(0x21, i | (1 << SbIRQ));
enable();
Воспроизведение файла выборки:
f = fopen(argv[1],"rb");
raw = ( char far * ) farmalloc(32000L);
if ( f == 0 raw==0 )
{
printf("Не могу открыть файл выборки - %s\n",argv[1]);
printf("Нет памяти\n",argv[1]);
ResetSB();
return;
}
printf("Воспроизведение выборки ...\n");
WriteSB(ON_SOUND_SB);
RateSB(22222);
len=fread(raw,1,32000,f);
while ( 1 )
{
if ( len==0 ) break;
PlaySB(raw,len);
len=fread(raw,1,32000,f);
while ( StatePlaySB()==0 )
if ( kbhit() ) { getch(); goto Fin; }
}
Fin:
if ( f!=0 ) fclose(f);
if ( raw!=0 ) farfree(raw);
ResetSB();
+-------------+-------------------------------------------------------------
| Стерео звук |
+=============+
При воспроизведении стерео звуков необходимо посылать 2 байта DSP, первый
для левого канала, второй для правого. Необходимо так же указать SB,
что вы воспроизводите стерео звук, через регистры миксера.
+----------------------+----------------------------------------------------
| Миксер Sound Blaster |
+======================+
Ниже приведена информация для SbPro.
Порт 2x4h - индексный порт миксера, 2x5h - порт данных (чтения/записи).
void pascal WriteMixerSB
( char index, char val )
{
outportb(baseAddrSB+4,index);
outportb(baseAddrSB+5,val);
}
char pascal ReadMixerSB
( char index )
{
outportb(baseAddrSB+4,index);
return inportb(baseAddrSB+5);
}
Регистр Сброса Данных используется для инициализации миксера. Установите
этот регистр в 0 перед изменением любого из других регистров миксера.
void pascal ResetMixerSB
( void )
{
WriteMixerSB(0,0); // RESET
}
Регистр записи определяет источник звука и тип фильтра.
Индекс = 0Ch
7 6 5 4 3 2 1 0
--------+-------+---+---+----
+---+---+ +-+-+
+---+ |
| |
В Фильтре ADC Источник
000 - Низкие 00 - Микрофон 1
001 - Высокие 01 - CD
010 - Нет Фильтра 10 - Микрофон 2
11 - Линейный вход
#define SOURCE_MIC1 0
#define SOURCE_CD 1
#define SOURCE_MIC2 2
#define SOURCE_LINE 3
void pascal InputMixerSB
( char sou, char filtr )
{
char val;
val=(sou<<1)&0x6;
val|=(filtr<<3)&0x38;
WriteMixerSB(0xC,val);
}
Регистр воспроизведения служит для установки фильтра и стерео звука.
Индекс = 0Eh
7 6 5 4 3 2 1 0
--------+---------------+----
| |
| |
0 - Использовать фильтр 0 - моно
1 - Без фильтра 1 - Stereo
#define MONO 0
#define STEREO 1
#define USE_FILTER 0
#define BYPASS_FILTER 1
void pascal OutputMixerSB
( char st, char filtr )
{
char val;
val=(st==1)?2:0;
val|=(filtr==1)?0x20:0;
WriteMixerSB(0xE,val);
}
Регистр общей громкости:
Индекс = 22h
7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право
void pascal MasterVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x22,val);
}
Регистр громкости DSP:
Индекс = 04h
7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право
void pascal VoiceVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x04,val);
}
Регистр громкости FM синтезатора:
Индекс= 26h
7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право
void pascal FMVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x26,val);
}
Регистр громкости CD:
Индекс = 28h
7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право
void pascal CDVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x28,val);
}
Регистр громкости линейного входа:
Индекс = 2Eh
7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право
void pascal LineVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x2E,val);
}
Регистр громкости микрофона:
Индекс = 0Ah
7 6 5 4 3 2 1 0
--------------------+-------+
+---+---+
|
Громкость микрофона.
void pascal MicVolumeSB
( char vol )
{
char val;
val=vol&0x7;
WriteMixerSB(0xA,val);
}
+------------+--------------------------------------------------------------
| Примечание:|
+============+
Данный документ составлен Анисимовым С.Ю. 08/1995. г. К-Чепецк,
Кировской обл. Россия. v1.( и последняя )
Данными для составления этого документа послужила информация
из различных источников. Поэтому автор не несет ответственность
за неверную информацию, и за повреждения техники и тел при
использовании этого документа.
С наилучшими пожеланиями, для всех любителей программировать Sound Blaster !
Vale !
Взято с Vingrad.ru
Программно нажимаем Print Screen
Программно нажимаем Print Screen
Автор:
Simon CarterСовместимость: Delphi 3.x (или выше)
Приведённая здесь функция делает копию изображения экрана и сохраняет её в буфере обмена (Clipboard). Так же необходимо включить в Ваш проект файл ClipBrd.pas.
procedure SendScreenImageToClipboard;
var
bmp: TBitmap;
begin
bmp := TBitmap.Create;
try
bmp.Width := Screen.Width;
bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
GetDC(GetDesktopWindow), 0, 0, SRCCopy);
Clipboard.Assign(bmp);
finally
bmp.Free;
end;
end;
Следующая функция скопирует изображение экрана в в bitmap. Переменная bitmap *должна* быть инициализирована до вызова этой функции.
procedure GetScreenImage(bmp: TBitmap);
begin
bmp.Width := Screen.Width;
bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
GetDC(GetDesktopWindow), 0, 0, SRCCopy);
end;
Взято с Исходников.ru
