Как можно получить звук с помощью MediaPlayer?
пример взят из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..."
procedure TForm1.btRecordClick(Sender: TObject);
begin
with Media do
begin
{ Set FileName to the test.wav file to }
{ get the recording parameters. }
FileName := 'd:\test.wav';
{ Open the device. }
Open;
{ Start recording. }
Wait := False;
StartRecording;
end;
end;
procedure TForm1.btStopClick(Sender: TObject);
begin
with Media do
begin
{ Stop recording. }
Stop;
{ Change the filename to the new file we want to write. }
FileName := 'd:\new.wav';
{ Save and close
the file. }
Save;
Close;
end;
end;
Взято с Vingrad.ru
Как можно работать с DDE?
Как можно работать с DDE?
Как можно работать с DDE под Delphi, используя вызовы API
Кстати, достаточно легко: следующий пример демонстрирует как можно научить общаться клиентскую программу с программой-сервером. Обе программы полностью созданы на Delphi. В итоге мы имеет 2 проекта, 3 формы и 3 модуля. Для работы с DDE-запросами данный пример использует методы DDE ML API.
Сервер должен начать свою работу перед тем, как клиент будет загружен. Данный пример демонстрирует 3 способа взаимодействия между клиентом и сервером:
Клиент может "пропихивать" (POKE) данные на сервер.
Сервер может автоматически передавать данные клиенту, после чего клиент обновляет свой вид на основе результатов, полученных от сервера.
Данные сервера изменяются, после чего клиент делает запрос серверу для получения новых данных и обновляет свой вид.
Как работает программа.
Ниже приведены 8 файлов, сконкатенированных в единое целое. Каждый файл имеет следующую структуру:
{ *** НАЧАЛО КОДА FILENAME.EXT *** } КОД { *** КОНЕЦ КОДА FILENAME.EXT *** },
поэтому вам остается всего-лишь взять код, расположенный между маркерами { *** }, скопировать в файл с соответствующим именем, и собрать оба проекта в среде Delphi
{*** НАЧАЛО КОДА DDEMLCLI.DPR *** }
program Ddemlcli;
uses
Forms,
Ddemlclu in 'DDEMLCLU.PAS' {Form1};
{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
{ *** КОНЕЦ КОДА DDEMLCLI.DPR *** }
{ *** НАЧАЛО КОДА DDEMLCLU.DFM *** }
object Form1: TForm1
Left = 197
Top = 95
Width = 413
Height = 287
HorzScrollBar.Visible = False
VertScrollBar.Visible = False
Caption = 'Демонстрация DDEML, Клиентское приложение'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object PaintBox1: TPaintBox
Left = 0
Top = 0
Width = 405
Height = 241
Align = alClient
Color = clWhite
ParentColor = False
OnPaint = PaintBox1Paint
end
object MainMenu1: TMainMenu
Top = 208
object File1: TMenuItem
Caption = '&Файл'
object exit1: TMenuItem
Caption = 'В&ыход'
OnClick = exit1Click
end
end
object DDE1: TMenuItem
Caption = '&DDE'
object RequestUpdate1: TMenuItem
Caption = '&Запрос на обновление'
OnClick = RequestUpdate1Click
end
object AdviseofChanges1: TMenuItem
Caption = '&Сообщение об изменениях'
OnClick = AdviseofChanges1Click
end
object N1: TMenuItem
Caption = '-'
end
object PokeSomeData: TMenuItem
Caption = '&Пропихивание данных'
OnClick = PokeSomeDataClick
end
end
end
end
{ *** КОНЕЦ КОДА DDEMLCLU.DFM *** }
{ *** НАЧАЛО КОДА DDEMLCLU.PAS *** }
{***************************************************}
{ }
{ Delphi 1.0 DDEML Демонстрационная программа }
{ Copyright (c) 1996 by Borland International }
{ }
{***************************************************}
{ Это демонстрационное приложение, демонстрирующее использование
DDEML API в клиентском приложении. Оно использует серверное
приложение DataEntry, которое является частью данной демонстрации,
и служит для ввода данных и отображения их на графической панели.
Сначала вы должны запустить приложение-сервер (в DDEMLSRV.PAS),
а затем стартовать клиента. Если сервер не запущен, клиент при
попытке соединения потерпит неудачу.
Интерфейс сервера определен списком имен (Service, Topic и Items)
в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер
делает Items доступными в формате cf_Text; они преобразовываются
и хранятся локально как целые. }
unit Ddemlclu;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, VBXCtrl, ExtCtrls, DDEML, Menus, StdCtrls;
const
NumValues = 3;
type
{ Структура данных, представленная в примере }
TDataSample = array[1..NumValues] of Integer;
TDataString = array[0..20] of Char; { Размер элемента как текста }
{ Главная форма }
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
exit1: TMenuItem;
DDE1: TMenuItem;
RequestUpdate1: TMenuItem;
AdviseofChanges1: TMenuItem;
PokeSomeData: TMenuItem;
N1: TMenuItem;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure RequestUpdate1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure AdviseofChanges1Click(Sender: TObject);
procedure PokeSomeDataClick(Sender: TObject);
procedure Request(HConversation: HConv);
procedure exit1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
{ Private declarations }
public
Inst: Longint;
CallBackPtr: ^TCallback;
ServiceHSz: HSz;
TopicHSz: HSz;
ItemHSz: array[1..NumValues] of HSz;
ConvHdl: HConv;
DataSample: TDataSample;
end;
var
Form1: TForm1;
implementation
const
DataEntryName: PChar = 'DataEntry';
DataTopicName: PChar = 'SampledData';
DataItemNames: array[1..NumValues] of pChar = ('DataItem1',
'DataItem2',
'DataItem3');
{$R *.DFM}
{ Локальная функция: Процедура обратного вызова для DDEML }
function CallbackProc(CallType, Fmt: Word; Conv: HConv; hsz1, hsz2: HSZ;
Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
begin
CallbackProc := 0; { В противном случае смотрите доказательство }
case CallType of
xtyp_Register:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_Unregister:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_xAct_Complete:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_Request, Xtyp_AdvData:
begin
Form1.Request(Conv);
CallbackProc := dde_FAck;
end;
xtyp_Disconnect:
begin
ShowMessage('Соединение разорвано!');
Form1.Close;
end;
end;
end;
{ Посылка DDE запроса для получения cf_Text данных с сервера.
Запрашиваем данные для всех полей DataSample, и обновляем
окно для их отображения. Данные с сервера получаем синхронно,
используя DdeClientTransaction.}
procedure TForm1.Request(HConversation: HConv);
var
hDdeTemp: HDDEData;
DataStr: TDataString;
Err, I: Integer;
begin
if HConversation <> 0 then
begin
for I := Low(ItemHSz) to High(ItemHSz) do
begin
hDdeTemp := DdeClientTransaction(nil, 0, HConversation, ItemHSz[I],
cf_Text, xtyp_Request, 0, nil);
if hDdeTemp <> 0 then
begin
DdeGetData(hDdeTemp, @DataStr, SizeOf(DataStr), 0);
Val(DataStr, DataSample[I], Err);
end; { if }
end; { for }
Paintbox1.Refresh; { Обновляем экран }
end; { if }
end;
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
{ Создаем экземпляр окна DDE-клиента. Создаем окно, используя
унаследованный конструктор, инициализируем экземпляр данных.}
begin
Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
CallBackPtr := nil; { MakeProcInstance вызывается из SetupWindow }
ConvHdl := 0;
ServiceHSz := 0;
TopicHSz := 0;
for I := Low(DataSample) to High(DataSample) do
begin
ItemHSz[I] := 0;
DataSample[I] := 0;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
{ Уничтожаем экземпляр клиентского окна. Освобождаем дескрипторы
DDE строк, и освобождаем экземпляр функции обратного вызова,
если она существует. Также, для завершения диалога, вызовите
DdeUninitialize. Затем, для завершения работы, вызовите
разрушителя предка. }
var
I: Integer;
begin
if ServiceHSz <> 0 then
DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then
DdeFreeStringHandle(Inst, TopicHSz);
for I := Low(ItemHSz) to High(ItemHSz) do
if ItemHSz[I] <> 0 then
DdeFreeStringHandle(Inst, ItemHSz[I]);
if Inst <> 0 then
DdeUninitialize(Inst); { Игнорируем возвращаемое значение }
if CallBackPtr <> nil then
FreeProcInstance(CallBackPtr);
end;
procedure TForm1.RequestUpdate1Click(Sender: TObject);
begin
{ Генерируем запрос DDE в ответ на выбор пункта меню DDE | Request.}
Request(ConvHdl);
end;
procedure TForm1.FormShow(Sender: TObject);
{ Завершаем инициализацию окна сервера DDE. Выполняем те действия,
которые требует правильное окно. Инициализируем использование DDEML. }
var
I: Integer;
InitOK: Boolean;
begin
CallBackPtr := MakeProcInstance(@CallBackProc, HInstance);
{ Инициализируем DDE и устанавливаем функцию обратного вызова.
Если сервер отсутствует, вызов терпит неудачу. }
if CallBackPtr <> nil then
begin
if DdeInitialize(Inst, TCallback(CallBackPtr), AppCmd_ClientOnly,
0) = dmlErr_No_Error then
begin
ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
InitOK := True;
{ for I := Low(DataItemNames) to High(DataItemNames) do begin }
for I := 1 to NumValues do
begin
ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
cp_WinAnsi);
InitOK := InitOK and (ItemHSz[I] <> 0);
end;
if (ServiceHSz <> 0) and (TopicHSz <> 0) and InitOK then
begin
ConvHdl := DdeConnect(Inst, ServiceHSz, TopicHSz, nil);
if ConvHdl = 0 then
begin
ShowMessage('Не могу инициализировать диалог!');
Close;
end
end
else
begin
ShowMessage('Не могу создать строки!');
Close;
end
end
else
begin
ShowMessage('Не могу осуществить инициализацию!');
Close;
end;
end;
end;
procedure TForm1.AdviseofChanges1Click(Sender: TObject);
{ Переключаемся на режим DDE Advise с помощью пункта меню DDE |
Advise (уведомление). При выборе этого пункта меню все три
элемента переключаются на уведомление. }
var
I: Integer;
TransType: Word;
TempResult: Longint;
begin
with TMenuITem(Sender) do
begin
Checked := not Checked;
if Checked then
TransType := (xtyp_AdvStart or xtypf_AckReq)
else
TransType := xtyp_AdvStop;
end; { with }
for I := Low(ItemHSz) to High(ItemHSz) do
if DdeClientTransaction(nil, 0, ConvHdl, ItemHSz[I], cf_Text,
TransType, 1000, @TempResult) = 0 then
ShowMessage('Не могу выполнить транзакцию-уведомление');
if TransType and xtyp_AdvStart <> 0 then
Request(ConvHdl);
end;
procedure TForm1.PokeSomeDataClick(Sender: TObject);
{ Генерируем DDE-Poke транзакцию в ответ на выбор пункта
меню DDE | Poke. Запрашиваем значение у пользователя,
которое будем "проталкивать" в DataItem1 в качестве
иллюстрации Poke-функции.}
var
DataStr: pChar;
S: string;
begin
S := '0';
if InputQuery('PokeData', 'Задайте проталкиваемую (Poke) величину', S) then
begin
S := S + #0;
DataStr := @S[1];
DdeClientTransaction(DataStr, StrLen(DataStr) + 1, ConvHdl,
ItemHSz[1], cf_Text, xtyp_Poke, 1000, nil);
Request(ConvHdl);
end;
end;
procedure TForm1.exit1Click(Sender: TObject);
begin
close;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
{ После запроса обновляем окно. Рисуем график объема текущих продаж.}
const
LMarg = 30; { Левое поле графика }
var
I,
Norm: Integer;
Wd: Integer;
Step: Integer;
ARect: TRect;
begin
Norm := 0;
for I := Low(DataSample) to High(DataSample) do
begin
if abs(DataSample[I]) > Norm then
Norm := abs(DataSample[I]);
end; { for }
if Norm = 0 then
Norm := 1; { В случае если у нас все нули }
with TPaintBox(Sender).Canvas do
begin
{ Рисуем задний фон }
Brush.color := clWhite;
FillRect(ClipRect);
{ Рисуем ось }
MoveTo(0, ClipRect.Bottom div 2);
LineTo(ClipRect.Right, ClipRect.Bottom div 2);
MoveTo(LMarg, 0);
LineTo(LMarg, ClipRect.Bottom);
{ Печатаем текст левого поля }
TextOut(0, 0, IntToStr(Norm));
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom + Font.Height, IntToStr(-Norm));
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom div 2, '0');
{ Печатаем текст оси X }
{ Теперь рисуем бары на основе нормализованного значения.
Вычисляем ширину баров (чтобы они все вместились в окне)
и ширину пробела между ними, который приблизительно равен
20% от их ширины. }
{ SelectObject(PaintDC, CreateSolidBrush(RGB(255, 0, 0)));
SetBkMode(PaintDC, Transparent);
}
ARect := ClipRect;
Wd := (ARect.Right - LMarg) div NumValues;
Step := Wd div 5;
Wd := Wd - Step;
with ARect do
begin
Left := LMarg + (Step div 2);
Top := ClipRect.Bottom div 2;
end; { with }
{ Выводим бары и текст для оси X }
for i := Low(DataSample) to High(DataSample) do
begin
with ARect do
begin
Right := Left + Wd;
Bottom := Top - Round((Top - 5) * (DataSample[I] / Norm));
end; { with }
{ Заполняем бар }
Brush.color := clFuchsia;
FillRect(ARect);
{ Выводим текст для горизонтальной оси }
Brush.color := clWhite;
TextOut(ARect.Left, ClipRect.Bottom div 2 - Font.Height,
StrPas(DataItemNames[i]));
with ARect do
Left := Left + Wd + Step;
end; { for }
end; { with }
end;
end. { *** КОНЕЦ КОДА DDEMLCLU.PAS *** }
{ *** НАЧАЛО КОДА DDEMLSVR.DPR *** }
program Ddemlsvr;
uses
Forms,
Ddesvru in 'DDESVRU.PAS' {Form1},
Ddedlg in '\DELPHI\BIN\DDEDLG.PAS' {DataEntry};
{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TDataEntry, DataEntry);
Application.Run;
end.
{ *** КОНЕЦ КОДА DDEMLSVR.DPR *** }
{ *** НАЧАЛО КОДА DDESVRU.DFM *** }
object Form1: TForm1
Left = 712
Top = 98
Width = 307
Height = 162
Caption = 'Демонстрация DDEML, Серверное приложение'
Color = clWhite
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object Label1: TLabel
Left = 0
Top = 0
Width = 99
Height = 16
Caption = 'Текущие значения:'
end
object Label2: TLabel
Left = 16
Top = 24
Width = 74
Height = 16
Caption = 'Data Item1:'
end
object Label3: TLabel
Left = 16
Top = 40
Width = 74
Height = 16
Caption = 'Data Item2:'
end
object Label4: TLabel
Left = 16
Top = 56
Width = 74
Height = 16
Caption = 'Data Item3:'
end
object Label5: TLabel
Left = 0
Top = 88
Width = 265
Height = 16
Caption = 'Выбор данных | Ввод данных для изменения значений.'
end
object Label6: TLabel
Left = 96
Top = 24
Width = 8
Height = 16
Caption = '0'
end
object Label7: TLabel
Left = 96
Top = 40
Width = 8
Height = 16
Caption = '0'
end
object Label8: TLabel
Left = 96
Top = 56
Width = 8
Height = 16
Caption = '0'
end
object MainMenu1: TMainMenu
Left = 352
Top = 24
object File1: TMenuItem
Caption = '&Файл'
object Exit1: TMenuItem
Caption = '&Выход'
OnClick = Exit1Click
end
end
object Data1: TMenuItem
Caption = '&Данные'
object EnterData1: TMenuItem
Caption = '&Ввод данных'
OnClick = EnterData1Click
end
object Clear1: TMenuItem
Caption = '&Очистить'
OnClick = Clear1Click
end
end
end
end
{ *** КОНЕЦ КОДА DDESVRU.DFM *** }
{ *** НАЧАЛО КОДА DDESVRU.PAS *** }
{***************************************************}
{ }
{ Delphi 1.0 DDEML Демонстрационная программа }
{ Copyright (c) 1996 by Borland International }
{ }
{***************************************************}
{ Данный демонстрационный пример использует библиотеку DDEML
на стороне сервера кооперативного приложения. Данный сервер
является простым приложением для ввода данных и позволяет
оператору осуществлять ввод трех элементов данных, которые
становятся доступными через DDE "заинтересованным" клиентам.
Данный сервер предоставляет свои услуги (сервисы) для данных
со следующими именами:
Service: 'DataEntry'
Topic : 'SampledData'
Items : 'DataItem1', 'DataItem2', 'DataItem3'
В-принципе, в качестве сервисов могли бы быть определены
и другие темы. Полезными темами, на наш взгляд, могут быть
исторические даты, информация о сэмплах и пр..
Вы должны запустить этот сервер ПЕРЕД тем как запустите
клиента (DDEMLCLI.PAS), в противном случае клиент не
сможет установить связь.
Интерфейс для этого сервера определен как список имен
(Service, Topic и Items) в отдельном модуле с именем
DataEntry (DATAENTR.TPU). Сервер делает Items доступными
в формате cf_Text; они преобразовываются и хранятся у
клиента локально как целые. }
unit Ddesvru;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Menus,
DDEML, { DDE APi }
ShellApi;
const
NumValues = 3;
DataItemNames: array[1..NumValues] of PChar = ('DataItem1',
'DataItem2',
'DataItem3');
type
TDataString = array[0..20] of Char; { Размер элемента как текста }
TDataSample = array[1..NumValues] of Integer;
{type
{ Структура данных, составляющих образец }
{ TDataSample = array [1..NumValues] of Integer;
{ TDataString = array [0..20] of Char; { Размер элемента как текста }
const
DataEntryName: PChar = 'DataEntry';
DataTopicName: PChar = 'SampledData';
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
Data1: TMenuItem;
EnterData1: TMenuItem;
Clear1: TMenuItem;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
procedure Exit1Click(Sender: TObject);
function MatchTopicAndService(Topic, Service: HSz): Boolean;
function MatchTopicAndItem(Topic, Item: HSz): Integer;
function WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
function AcceptPoke(Item: HSz; ClipFmt: Word;
Data: HDDEData): Boolean;
function DataRequested(TransType: Word; ItemNum: Integer;
ClipFmt: Word): HDDEData;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure EnterData1Click(Sender: TObject);
procedure Clear1Click(Sender: TObject);
private
Inst: Longint;
CallBack: TCallback;
ServiceHSz: HSz;
TopicHSz: HSz;
ItemHSz: array[1..NumValues] of HSz;
ConvHdl: HConv;
Advising: array[1..NumValues] of Boolean;
DataSample: TDataSample;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses DDEDlg; { Форма DataEntry }
{$R *.DFM}
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
{ Глобальная инициализация }
const
DemoTitle: PChar = 'DDEML демо, серверное приложение';
MaxAdvisories = 100;
NumAdvLoops: Integer = 0;
{ Локальная функция: Процедура обратного вызова для DDEML }
{ Данная функция обратного вызова реагирует на все транзакции,
генерируемые DDEML. Объект "target Window" (окно-цель)
берется из глобально хранимых, и для реагирования на данную
транзакцию, тип которой указан в параметре CallType,
используются подходящие методы этих объектов.}
function CallbackProc(CallType, Fmt: Word; Conv: HConv; HSz1, HSz2: HSZ;
Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
var
ItemNum: Integer;
begin
CallbackProc := 0; { В противном случае смотрите доказательство }
case CallType of
xtyp_WildConnect:
CallbackProc := Form1.WildConnect(HSz1, HSz2, Fmt);
xtyp_Connect:
if Conv = 0 then
begin
if Form1.MatchTopicAndService(HSz1, HSz2) then
CallbackProc := 1; { Связь! }
end;
{ После подтверждения установки соединения записываем
дескриптор связи как родительское окно.}
xtyp_Connect_Confirm:
Form1.ConvHdl := Conv;
{ Клиент запрашивает данные, делает прямой запрос или
отвечает на уведомление. Возвращаем текущее состояние данных.}
xtyp_AdvReq, xtyp_Request:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then
CallbackProc := Form1.DataRequested(CallType, ItemNum, Fmt);
end;
{ Отвечаем на Poke-запрос ... данная демонстрация допускает
только Pokes для DataItem1. Для подтверждения получения
запроса возвращаем dde_FAck, в противном случае 0.}
xtyp_Poke:
begin
if Form1.AcceptPoke(HSz2, Fmt, Data) then
CallbackProc := dde_FAck;
end;
{ Клиент сделал запрос для старта цикла-уведомления.
Имейте в виду, что мы организуем "горячий" цикл.
Устанавливаем флаг Advising для указания открытого
цикла, который будет проверять данные на предмет
их изменения.}
xtyp_AdvStart:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then
begin
if NumAdvLoops < MaxAdvisories then
begin { Произвольное число }
Inc(NumAdvLoops);
Form1.Advising[ItemNum] := True;
CallbackProc := 1;
end;
end;
end;
{ Клиент сделал запрос на прерывание цикла-уведомления.}
xtyp_AdvStop:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then
begin
if NumAdvLoops > 0 then
begin
Dec(NumAdvLoops);
if NumAdvLoops = 0 then
Form1.Advising[ItemNum] := False;
CallbackProc := 1;
end;
end;
end;
end; { Case CallType }
end;
{ Возращает True, если данные Topic и Service поддерживаются
этим приложением. В противном случае возвращается False.}
function TForm1.MatchTopicAndService(Topic, Service: HSz): Boolean;
begin
Result := False;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
if DdeCmpStringHandles(ServiceHSz, Service) = 0 then
Result := True;
end;
{ Определяем, один ли Topic и Item поддерживается этим
приложением. Возвращаем номер заданного элемента (Item Number)
(в пределах 1..NumValues), если он обнаружен, и ноль в
противном случае.}
function TForm1.MatchTopicAndItem(Topic, Item: HSz): Integer;
var
I: Integer;
begin
Result := 0;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
for I := 1 to NumValues do
if DdeCmpStringHandles(ItemHSz[I], Item) = 0 then
Result := I;
end;
{ Отвечаем на запрос wildcard-соединения (дословно -
дикая карта, шаблон). Такие запросы возникают всякий раз,
когда клиент пытается подключиться к серверу с сервисом
или именем топика, установленного в 0. Если сервер
обнаруживает использование такого рода шаблона, он
возвращает дескриптор массива THSZPair, содержащего
найденные по шаблону Service и Topic.}
function TForm1.WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
var
TempPairs: array[0..1] of THSZPair;
Matched: Boolean;
begin
TempPairs[0].hszSvc := ServiceHSz;
TempPairs[0].hszTopic := TopicHSz;
TempPairs[1].hszSvc := 0; { 0-завершает список }
TempPairs[1].hszTopic := 0;
Matched := False;
if (Topic = 0) and (Service = 0) then
Matched := True { Шаблон обработан, элементов не найдено }
else if (Topic = 0) and (DdeCmpStringHandles(Service, ServiceHSz) = 0) then
Matched := True
else if (DdeCmpStringHandles(Topic, TopicHSz) = 0) and (Service = 0) then
Matched := True;
if Matched then
WildConnect := DdeCreateDataHandle(Inst, @TempPairs, SizeOf(TempPairs),
0, 0, ClipFmt, 0)
else
WildConnect := 0;
end;
{ Принимаем и проталкиваем данные по просьбе клиента.
Для демонстрации этого способа используем только
значение DataItem1, изменяемое Poke.}
function TForm1.AcceptPoke(Item: HSz; ClipFmt: Word;
Data: HDDEData): Boolean;
var
DataStr: TDataString;
Err: Integer;
TempSample: Integer;
begin
if (DdeCmpStringHandles(Item, ItemHSz[1]) = 0) and
(ClipFmt = cf_Text) then
begin
DdeGetData(Data, @DataStr, SizeOf(DataStr), 0);
Val(DataStr, TempSample, Err);
if IntToStr(TempSample) <> Label6.Caption then
begin
Label6.Caption := IntToStr(TempSample);
DataSample[1] := TempSample;
if Advising[1] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[1]);
end;
AcceptPoke := True;
end
else
AcceptPoke := False;
end;
{ Возвращаем данные, запрашиваемые значениями TransType
и ClipFmt. Такое может произойти в ответ на просьбу
xtyp_Request или xtyp_AdvReq. Параметр ItemNum указывает
на поддерживаемый (в диапазоне 1..NumValues) и требуемый
элемент (обратите внимание на то, что данный метод
подразумевает, что вызывающий оператор уже установил
достоверность и ID требуемого пункта с помощью
MatchTopicAndItem). Соответствующие данные из переменной
экземпляра DataSample преобразуются в текст и возвращаются
клиенту.}
function TForm1.DataRequested(TransType: Word; ItemNum: Integer;
ClipFmt: Word): HDDEData;
var
ItemStr: TDataString; { Определено в DataEntry.TPU }
begin
if ClipFmt = cf_Text then
begin
Str(DataSample[ItemNum], ItemStr);
DataRequested := DdeCreateDataHandle(Inst, @ItemStr,
StrLen(ItemStr) + 1, 0, ItemHSz[ItemNum], ClipFmt, 0);
end
else
DataRequested := 0;
end;
{ Создаем экземпляр окна DDE сервера. Вызываем унаследованный
конструктор, затем устанавливаем эти объекты родителями
экземпляров данных. }
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
@CallBack := nil; { MakeProcInstance вызывается из SetupWindow }
for I := 1 to NumValues do
begin
DataSample[I] := 0;
Advising[I] := False;
end; { for }
end;
{ Разрушаем экземпляр окна DDE сервера. Проверяем, был ли
создан экземпляр процедуры обратного вызова, если он существует.
Также, для завершения диалога, вызовите DdeUninitialize.
Затем, для завершения работы, вызовите разрушителя предка.}
procedure TForm1.FormDestroy(Sender: TObject);
var
I: Integer;
begin
if ServiceHSz <> 0 then
DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then
DdeFreeStringHandle(Inst, TopicHSz);
for I := 1 to NumValues do
if ItemHSz[I] <> 0 then
DdeFreeStringHandle(Inst, ItemHSz[I]);
if Inst <> 0 then
DdeUninitialize(Inst); { Игнорируем возвращаемое значение }
if @CallBack <> nil then
FreeProcInstance(@CallBack);
end;
procedure TForm1.FormShow(Sender: TObject);
var
I: Integer;
{ Завершаем инициализацию окна DDE сервера. Процедура инициализации
использует DDEML для регистрации сервисов, предусмотренных данным
приложением. Помните о том, что реальные имена, использованные в
регистрах, определены в отдельном модуле (DataEntry), поэтому они
могут быть использованы и клиентом. }
begin
@CallBack := MakeProcInstance(@CallBackProc, HInstance);
if DdeInitialize(Inst, CallBack, 0, 0) = dmlErr_No_Error then
begin
ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
for I := 1 to NumValues do
ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
cp_WinAnsi);
if DdeNameService(Inst, ServiceHSz, 0, dns_Register) = 0 then
ShowMessage('Ошибка в процессе регистрации.');
end;
end;
procedure TForm1.EnterData1Click(Sender: TObject);
{ Активизируем диалог ввода данных и обновляем
хранимые данные по окончании ввода.}
var
I: Integer;
begin
if DataEntry.ShowModal = mrOk then
begin
with DataEntry do
begin
Label6.Caption := S1;
Label7.Caption := S2;
Label8.Caption := S3;
DataSample[1] := StrToInt(S1);
DataSample[2] := StrToInt(S2);
DataSample[3] := StrToInt(S3);
end; { with }
for I := 1 to NumValues do
if Advising[I] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end; { if }
end;
procedure TForm1.Clear1Click(Sender: TObject);
{ Очищаем текущую дату. }
var
I: Integer;
begin
for I := 1 to NumValues do
begin
DataSample[I] := 0;
if Advising[I] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end;
Label6.Caption := '0';
Label7.Caption := '0';
Label8.Caption := '0';
end;
end.
{ *** КОНЕЦ КОДА DDESVRU.PAS *** }
{ *** НАЧАЛО КОДА DDEDLG.DFM *** }
object DataEntry: TDataEntry
Left = 488
Top = 132
ActiveControl = OKBtn
BorderStyle = bsDialog
Caption = 'Ввод данных'
ClientHeight = 264
ClientWidth = 199
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
PixelsPerInch = 96
Position = poScreenCenter
OnShow = FormShow
TextHeight = 13
object Bevel1: TBevel
Left = 8
Top = 8
Width = 177
Height = 201
Shape = bsFrame
IsControl = True
end
object OKBtn: TBitBtn
Left = 16
Top = 216
Width = 69
Height = 39
Caption = '&OK'
ModalResult = 1
TabOrder = 3
OnClick = OKBtnClick
Glyph.Data = {
BE060000424DBE06000000000000360400002800000024000000120000000100
0800000000008802000000000000000000000000000000000000000000000000
80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
A600000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000F0FBFF00A4A0A000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00030303030303
0303030303030303030303030303030303030303030303030303030303030303
03030303030303030303030303030303030303030303FF030303030303030303
03030303030303040403030303030303030303030303030303F8F8FF03030303
03030303030303030303040202040303030303030303030303030303F80303F8
FF030303030303030303030303040202020204030303030303030303030303F8
03030303F8FF0303030303030303030304020202020202040303030303030303
0303F8030303030303F8FF030303030303030304020202FA0202020204030303
0303030303F8FF0303F8FF030303F8FF03030303030303020202FA03FA020202
040303030303030303F8FF03F803F8FF0303F8FF03030303030303FA02FA0303
03FA0202020403030303030303F8FFF8030303F8FF0303F8FF03030303030303
FA0303030303FA0202020403030303030303F80303030303F8FF0303F8FF0303
0303030303030303030303FA0202020403030303030303030303030303F8FF03
03F8FF03030303030303030303030303FA020202040303030303030303030303
0303F8FF0303F8FF03030303030303030303030303FA02020204030303030303
03030303030303F8FF0303F8FF03030303030303030303030303FA0202020403
030303030303030303030303F8FF0303F8FF03030303030303030303030303FA
0202040303030303030303030303030303F8FF03F8FF03030303030303030303
03030303FA0202030303030303030303030303030303F8FFF803030303030303
030303030303030303FA0303030303030303030303030303030303F803030303
0303030303030303030303030303030303030303030303030303030303030303
0303}
Margin = 2
NumGlyphs = 2
Spacing = -1
IsControl = True
end
object CancelBtn: TBitBtn
Left = 108
Top = 216
Width = 69
Height = 39
Caption = '&Отмена'
TabOrder = 4
Kind = bkCancel
Margin = 2
Spacing = -1
IsControl = True
end
object Panel2: TPanel
Left = 16
Top = 88
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 1
object Label1: TLabel
Left = 24
Top = 8
Width = 5
Height = 13
end
object Label2: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 2:'
end
object Edit2: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel1: TPanel
Left = 16
Top = 16
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 0
object Label4: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 1:'
end
object Edit1: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel3: TPanel
Left = 16
Top = 144
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 2
object Label6: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 3:'
end
object Edit3: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
end
{ *** КОНЕЦ КОДА DDEDLG.DFM *** }
{ *** НАЧАЛО КОДА DDEDLG.PAS *** }
{***************************************************}
{ }
{ Delphi 1.0 DDEML Демонстрационная программа }
{ Copyright (c) 1996 by Borland International }
{ }
{***************************************************}
{ Данный модуль определяет интерфейс сервера DataEntry DDE
(DDEMLSRV.PAS). Здесь определены имена Service, Topic,
и Item, поддерживаемые сервером, и также определена
структура данных, которая может использоваться
клиентом для локального хранения "показательных" данных.
Сервер Data Entry Server делает свои "показательные"
данные доступными в текстовом виде (cf_Text)
сформированными в виде трех различных топика (Topics).
Клиент может их преобразовывать в целое для
использования со структурой данных, которая здесь определена.
}
unit Ddedlg;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
StdCtrls, Mask, ExtCtrls;
type
TDataEntry = class(TForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
Bevel1: TBevel;
Panel2: TPanel;
Label1: TLabel;
Label2: TLabel;
Panel1: TPanel;
Label4: TLabel;
Panel3: TPanel;
Label6: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
procedure OKBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
S1, S2, S3: string;
{ Public declarations }
end;
var
DataEntry: TDataEntry;
implementation
{$R *.DFM}
procedure TDataEntry.OKBtnClick(Sender: TObject);
begin
S1 := Edit1.Text;
S2 := Edit2.Text;
S3 := Edit3.Text;
end;
procedure TDataEntry.FormShow(Sender: TObject);
begin
Edit1.Text := '0';
Edit2.Text := '0';
Edit3.Text := '0';
Edit1.SetFocus;
end;
end.
{ *** КОНЕЦ КОДА DDEDLG.PAS *** }
Взято с
Как можно работать с объектами не заботясь об их разрушении?
Как можно работать с объектами не заботясь об их разрушении?
Вначале сделаем интерфейс для нашего объекта:
type
IAutoClean = interface
['{61D9CBA6-B1CE-4297-9319-66CC86CE6922}']
end;
TAutoClean = class(TInterfacedObject, IAutoClean)
private
FObj: TObject;
public
constructor Create(AObj: TObject);
destructor Destroy; override;
end;
implementation
constructor TAutoClean.Create(AObj: TObject);
begin
FObj := AObj;
end;
destructor TAutoClean.Destroy;
begin
FreeAndNil(FObj);
inherited;
end;
А теперь будем использовать его вместо объекта:
procedure TForm1.Button1Click(Sender: TObject);
var
a: IAutoClean;
//must declare as local variable, so when this procedure finished, it's out of scope
o: TOpenDialog; //any component
begin
o := TOpenDialog.Create(self);
a := TAutoClean.Create(o);
if o.Execute then
ShowMessage(o.FileName);
end;
Взято с
Delphi Knowledge BaseКак можно разорвать соединение с интернетом?
Как можно разорвать соединение с интернетом?
LONG lineDrop(
HCALL hCall,
LPCSTR lpsUserUserInfo,
DWORD dwSize
);
Автор ответа: Baa
Взято с Vingrad.ru
Как можно создать OCX-компонент?
Как можно создать OCX-компонент?
Для Delphi 6:
1. Пишеш обычный VCL-компонент и добавляеш его в палитру компонентов.
2. File->New->Other->ActiveX->ActiveX Control
3. VCL Class Name = твой VCL-компонент
Автор Cully
Взято с Vingrad.ru
Как можно узнать количество цветов текущего режима
Как можно узнать количество цветов текущего режима
GetDeviceCaps(Form1.Canvas.Handle,BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES)
Для получения общего количества битов, используемых для получения цвета используются следующие значения.
1 = 2 colors bpp
4 = 16 colors bpp
8 = 256 colors bpp
15 = 32768 colors (возвращает 16 на большинстве драйверов) bpp
16 = 65535 colors bpp
24 = 16,777,216 colors bpp
32 = 16,777,216 colors (то же, что и 24) bpp
Вы можете использовать:
NumberOfColors := (1 shl
(GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES));
для подсчета общего количества используемых цветов.
Взято из
Как можно включить/выключить звук в системе?
Как можно включить/выключить звук в системе?
WaveOutSetVolume()
Взято с Vingrad.ru
Как на Oracle поменять compatible
Как на Oracle поменять compatible
Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?
Ставить в initmybase.ora
compatible= "7.3.2.3"
и после старта с новым параметром сделать
ALTER DATABASE RESET COMPABILITY;
И рестартовать базу.
Взято из
Как начертить hexagon?
Как начертить hexagon?
procedurePlotPolygon(const Canvas: TCanvas; const N: Integer; const R: Single;
const XC: Integer; const YC: Integer);
type
TPolygon = array of TPoint;
var
Polygon: TPolygon;
I: Integer;
C: Extended;
S: Extended;
A: Single;
begin
SetLength(Polygon, N);
A := 2 * Pi / N;
for I := 0 to (N - 1) do
begin
SinCos(I * A, S, C);
Polygon[I].X := XC + Round(R * C);
Polygon[I].Y := YC + Round(R * S);
end;
Canvas.Polygon(Polygon);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
W: Single;
H: Single;
X: Integer;
Y: Integer;
const
N = 6;
R = 10;
begin
W := 1.5 * R;
H := R * Sqrt(3);
for X := 0 to Round(ClientWidth / W) do
for Y := 0 to Round(ClientHeight / H) do
if Odd(X) then
PlotPolygon(Canvas, N, R, Round(X * W), Round((Y + 0.5) * H))
else
PlotPolygon(Canvas, N, R, Round(X * W), Round(Y * H));
end;
unit HexGrid;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, Math;
type
TOrientation = (hxVertical, hxhorizontal);
THexGrid = class(TCustomPanel)
private
FOrientation: TOrientation;
FHexSize: Integer;
FPoints: array[0..5] of TPoint;
FDisplayCaption: Boolean;
procedure ChangedDimensions;
procedure SetOrientation(Value: TOrientation);
procedure SetHexSize(const Value: Integer);
procedure DrawVerticalGrid;
procedure DrawhorizontalGrid;
procedure SetDisplayCaption(Value: Boolean);
protected
public
constructor Create(AOwner: TComponent); override;
procedure Paint; override;
property Orientation: TOrientation read FOrientation write SetOrientation;
published
property Align;
property Alignment;
property Anchors;
property AutoSize;
property BevelInner;
property BevelOuter;
property BevelWidth;
property BiDiMode;
property BorderWidth;
property BorderStyle;
property Caption;
property Color;
property Constraints;
property Ctl3D;
property UseDockManager default True;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FullRepaint;
property Font;
property Locked;
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
property Left;
property Top;
property Width;
property Height;
property Cursor;
property Hint;
property HelpType;
property HelpKeyword;
property HelpContext;
property HexSize: Integer read FHexSize write SetHexSize;
property DisplayCaption: Boolean read FDisplayCaption write SetDisplayCaption;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [THexGrid]);
end;
procedure THexGrid.ChangedDimensions;
var
I: Integer;
begin
for I := 0 to High(FPoints) do
begin
FPoints[I].X := 0;
FPoints[I].Y := 0;
end;
if Orientation = hxhorizontal then
begin
FPoints[0].X := Hexsize div 4;
FPoints[1].X := HexSize - (Hexsize div 4);
FPoints[2].X := HexSize;
FPoints[2].Y := HexSize div 2;
FPoints[3].X := HexSize - (Hexsize div 4);
FPoints[3].Y := HexSize;
FPoints[4].X := HexSize div 4;
FPoints[4].Y := HexSize;
FPoints[5].Y := HexSize div 2;
end;
if Orientation = hxVertical then
begin
FPoints[0].X := HexSize div 2;
FPoints[1].X := HexSize;
FPoints[1].Y := HexSize div 4;
FPoints[2].X := HexSize;
FPoints[2].Y := HexSize - (Hexsize div 4);
FPoints[3].X := HexSize div 2;
FPoints[3].Y := HexSize;
FPoints[4].Y := HexSize - (Hexsize div 4);
FPoints[5].Y := HexSize div 4;
end;
end;
procedure THexGrid.SetOrientation(Value: TOrientation);
begin
if FOrientation <> Value then
begin
FOrientation := Value;
ChangedDimensions;
invalidate;
end;
end;
procedure THexGrid.SetHexSize(const Value: Integer);
begin
if FHexSize <> Value then
begin
FHexSize := Value;
ChangedDimensions;
invalidate;
end;
end;
constructor THexGrid.Create(AOwner: TComponent);
begin
inherited;
FOrientation := hxVertical;
FHexSize := 64;
ChangedDimensions;
Width := 128;
Height := 128;
end;
procedure THexGrid.Paint;
begin
inherited;
if Orientation = hxhorizontal then
DrawhorizontalGrid
else
DrawVerticalGrid;
end;
procedure THexGrid.DrawhorizontalGrid;
var
I: Integer;
X, Y, Offset: Integer;
FHex: array[0..5] of TPoint;
begin
X := 0;
Y := 0;
Offset := 0;
while X + HexSize < Width do
begin
Y := 0;
while Y + HexSize < Height do
begin
with Self.Canvas do
begin
for I := 0 to High(FPoints) do
begin
FHex[I].X := X + FPoints[I].X;
FHex[I].Y := Y + FPoints[I].Y + Offset;
end;
Polygon(FHex);
end;
Y := Y + HexSize;
end;
if Offset = 0 then
Offset := (0 - (HexSize div 2))
else
Offset := 0;
X := X + (HexSize - (HexSize div 4));
end;
end;
procedure THexGrid.DrawVerticalGrid;
var
I: Integer;
X, Y, Offset: Integer;
FHex: array[0..5] of TPoint;
begin
X := 0;
Y := 0;
Offset := 0;
while Y + HexSize < Height do
begin
X := 0;
while X + HexSize < Width do
begin
with Self.Canvas do
begin
for I := 0 to High(FPoints) do
begin
FHex[I].X := X + FPoints[I].X + Offset;
FHex[I].Y := Y + FPoints[I].Y;
end;
Polygon(FHex);
end;
X := X + HexSize;
end;
if Offset = 0 then
Offset := (0 - (HexSize div 2))
else
Offset := 0;
Y := Y + (HexSize - (HexSize div 4));
end;
end;
procedure THexGrid.SetDisplayCaption(Value: Boolean);
begin
end;
end.
Взято с
Delphi Knowledge BaseКак начертить круг?
Как начертить круг?
{... }
implementation
{$R *.DFM}
uses
Math;
procedure DrawCircle(CenterX, CenterY, Radius: Integer; Canvas: TCanvas; Color:
TColor);
procedure PlotCircle(x, y, x1, y1: Integer);
begin
Canvas.Pixels[x + x1, y + y1] := Color;
Canvas.Pixels[x - x1, y + y1] := Color;
Canvas.Pixels[x + x1, y - y1] := Color;
Canvas.Pixels[x - x1, y - y1] := Color;
Canvas.Pixels[x + y1, y + x1] := Color;
Canvas.Pixels[x - y1, y + x1] := Color;
Canvas.Pixels[x + y1, y - x1] := Color;
Canvas.Pixels[x - y1, y - x1] := Color;
end;
var
x, y, r: Integer;
x1, y1, p: Integer;
begin
x := CenterX;
y := CenterY;
r := Radius;
x1 := 0;
y1 := r;
p := 3 - 2 * r;
while (x1 < y1) do
begin
plotcircle(x, y, x1, y1);
if (p < 0) then
p := p + 4 * x1 + 6
else
begin
p := p + 4 * (x1 - y1) + 10;
y1 := y1 - 1;
end;
x1 := x1 + 1;
end;
if (x1 = y1) then
plotcircle(x, y, x1, y1);
end;
Used like this:
procedure TForm1.Button1Click(Sender: TObject);
begin
DrawCircle(ClientWidth div 2, ClientHeight div 2, Min(ClientWidth div 2,
ClientHeight div 2), Canvas, clBlack);
{Add Math to the uses clause for the Min function}
end;
Взято с
Delphi Knowledge BaseКак найти директорию TEMP в Windows?
Как найти директорию TEMP в Windows?
function c_GetTempPath: String;
var
Buffer: array[0..1023] of Char;
begin
SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer));
end;
этот код так же можно использовать для:
GetCurrentDirectory
GetSystemDirectory
GetWindowsDirectory
Взято с Исходников.ru
Как найти компонент по имени?
Как найти компонент по имени?
Обратится к компоненту по имени можно например так, если стоит 10 CheckBox - от CheckBox1 до CheckBox10 то
For i:=1 to 10 do
(FindComponent(Format('CheckBox%d',[i])) as TCheckBox).checked:=true;
Автор Vit
Взято с Vingrad.ru
Как найти контрастный цвет к данному?
Как найти контрастный цвет к данному?
functionFindContrastingColor(Color: TColor): TColor;
var
R, G, B: Byte;
begin
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
if (R < 128) then
R := 255
else
R := 0;
if (G < 128) then
G := 255
else
G := 0;
if (B < 128) then
B := 255
else
B := 0;
Result := RGB(R, G, B);
end;
Взято с
Delphi Knowledge BaseКак найти наибольший общий делитель?
Как найти наибольший общий делитель?
{
The greatest common factor, or GCF, is the greatest factor
that divides two numbers.
}
uses
math;
// Find the greatest common factor of two integers
function TForm1.GCF(A, B: Integer): Integer;
var
Lfactor: Integer;
begin
// Return -1 if either value is zero or negative
if (A < 1) or (B < 1) then
begin
Result := -1;
Exit;
end;
// if A = B then this is the GCF
if A = B then
begin
Result := A;
Exit;
end;
Result := 1;
for Lfactor := trunc(max(A, B) / 2) downto 2 do
begin
if (frac(A / Lfactor) = 0) and (frac(B / Lfactor) = 0) then
begin
Result := Lfactor;
Exit; // GCF has been found. No need to continue
end;
end;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
var
Res: Integer;
begin
Res := GCF(120, 30);
ShowMessage(Inttostr(Res));
end;
{******************}
// Find the greatest common factor of an array of integers
function TForm1.GCFarray(A: array of Integer): Integer;
var
Llength, Lindex, Lfactor: Integer;
begin
Llength := Length(A);
// Return -1 if any value is zero or negative
for Lindex := 0 to Llength - 1 do
begin
if A[Lindex] < 1 then
begin
Result := -1;
Exit;
end;
end;
// if all elements are equal then this is the GCF
Lindex := 1;
while (Lindex < Llength) and (A[Lindex] = A[0]) do Inc(Lindex);
if Lindex = Llength then
begin
Result := A[0];
Exit;
end;
Result := 1;
for Lfactor := trunc(ArrayMax(A) / 2) downto 2 do
begin
Lindex := 0;
while (Lindex < Llength) and
(frac(A[Lindex] / Lfactor) = 0) do Inc(Lindex);
if Lindex = Llength then
begin
Result := Lfactor;
Exit; // GCF has been found. No need to continue
end;
end;
end;
// find the maximum value in an array of integers
function TForm1.ArrayMax(Aarray: array of Integer): Integer;
var
Lpos: Integer;
begin
Result := 0;
for Lpos := 0 to Length(Aarray) - 1 do
if Aarray[Lpos] > Result then
Result := Aarray[Lpos];
end;
Взято с сайта
Как найти окно по неполному названию?
Как найти окно по неполному названию?
Код не мой, взят где-то из интернета, авторство не помню, я его работоспособность проверял, но почему-то работает не в 100% случаев, копать дальше не было времени, но может кому пригодится и в таком варианте.
type
PFindWindowStruct = ^TFindWindowStruct;
TFindWindowStruct = record
Caption: string;
ClassName: string;
WindowHandle: THandle;
end;
function EnumWindowsProc(hWindow: hWnd; lParam: LongInt): Bool; stdcall;
var
lpBuffer: PChar;
WindowCaptionFound: bool;
ClassNameFound: bool;
begin
GetMem(lpBuffer, 255);
Result := True;
WindowCaptionFound := False;
ClassNameFound := False;
try
if GetWindowText(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0 then WindowCaptionFound := true;
if PFindWindowStruct(lParam).ClassName = '' then
ClassNameFound := True
else if GetClassName(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then ClassNameFound := True;
if (WindowCaptionFound and ClassNameFound) then
begin
PFindWindowStruct(lParam).WindowHandle := hWindow;
Result := False;
end;
finally
FreeMem(lpBuffer, sizeof(lpBuffer^));
end;
end;
function FindAWindow(Caption: string; ClassName: string): THandle;
var WindowInfo: TFindWindowStruct;
begin
WindowInfo.Caption := Caption;
WindowInfo.ClassName := ClassName;
WindowInfo.WindowHandle := 0;
EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo));
FindAWindow := WindowInfo.WindowHandle;
end;
procedure TForm1.Button1Click(Sender: TObject);
var TheWindowHandle: THandle;
begin
TheWindowHandle := FindAWindow('Opera', '');
if TheWindowHandle <> 0 then
begin
Showwindow(TheWindowHandle, sw_restore);
BringWindowToTop(TheWindowHandle);
end
else
ShowMessage('Window Not Found!');
end;
Автор ответа: Vit
Взято с Vingrad.ru
function TForm1.Find(s: string): hWnd;
var Wnd: hWnd;
buff: array[0..127] of Char;
begin
Find := 0;
Wnd := GetWindow(Handle, gw_HWndFirst);
while Wnd <> 0 do
begin
if (Wnd <> Application.Handle) and
IsWindowVisible(Wnd) and
(GetWindow(Wnd, gw_Owner) = 0) and
(GetWindowText(Wnd, buff, sizeof(buff)) <> 0) then
begin
GetWindowText(Wnd, buff, sizeof(buff));
if pos(s, StrPas(buff)) > 0 then
begin
Find := Wnd;
Break;
end;
end;
Wnd := GetWindow(Wnd, gw_hWndNext);
end;
end;
Автор ответа: Mikel
Взято с Vingrad.ru
Как найти пароль к базе данных?
Как найти пароль к базе данных?
I know there that there are many utilities out there costing $$ for removing the password of an access database. Here's how to implement it in Delphi.Please note that this method is not meant for a database with user-level security and work group information file. The idea is based on the file format of an access db.
The password is stored from location $42 and encrypted using simple xoring. The following function does decryption.
functionGetPassword(filename: string): string;
var
Stream: TFilestream;
buffer: array[0..12] of char;
str: string;
begin
try
stream := TFileStream.Create(filename, fmOpenRead);
except
ShowMessage('Could not open the file.Make sure that the file is not in use.');
exit;
end;
stream.Seek($42, soFromBeginning);
stream.Read(buffer, 13);
stream.Destroy;
str := chr(Ord(buffer[0]) xor $86);
str := str + chr(Ord(buffer[1]) xor $FB);
str := str + chr(Ord(buffer[2]) xor $EC);
str := str + chr(Ord(buffer[3]) xor $37);
str := str + chr(Ord(buffer[4]) xor $5D);
str := str + chr(Ord(buffer[5]) xor $44);
str := str + chr(Ord(buffer[6]) xor $9C);
str := str + chr(Ord(buffer[7]) xor $FA);
str := str + chr(Ord(buffer[8]) xor $C6);
str := str + chr(Ord(buffer[9]) xor $5E);
str := str + chr(Ord(buffer[10]) xor $28);
str := str + chr(Ord(buffer[11]) xor $E6);
str := str + chr(Ord(buffer[12]) xor $13);
Result := str;
end;
Взято с
Delphi Knowledge BaseКак найти путь к моей программе?
Как найти путь к моей программе?
Application.ExeName
Автор ответа: Baa
Взято с Vingrad.ru
Или еще лучше Paramstr(0) - лучше потому что работает и без объекта Application и в DLL
Автор ответа: Vit
Взято с Vingrad.ru
Как найти размер записи?
Как найти размер записи?
procedureTMainFrm.CalculateRecordSizeClick(Sender: TObject);
var
MaxRecs, RecSize, RecsPerBlock, FreeSpace: Longint;
i: Integer;
begin
RecSize := 0;
with StrucGrid do
begin
for i := 0 to pred(RowCount) do
begin
case Cells[1, i][1] of
'A': RecSize := RecSize + StrToInt(Cells[2, i]);
'D', 'T', 'I', '+': RecSize := RecSize + 4;
'N', '$', 'Y', '@': RecSize := RecSize + 8;
'M', 'B', 'F', 'O', 'G': RecSize := RecSize + 10 + StrToInt(Cells[2, i]);
'S': RecSize := RecSize + 2;
'L': RecSize := RecSize + 1;
end;
end;
end;
RecsPerBlock := (SpinEdit2.Value - 6) div RecSize;
FreeSpace := (SpinEdit2.Value - 6) - (RecSize * RecsPerBlock);
MaxRecs := 65536 * RecsPerBlock;
ShowMessage('Record Size is: ' + IntToStr(RecSize) + ' bytes' + #13#10
+ 'Records per Block: ' + IntToStr(RecsPerBlock) + #13#10
+ 'Unused Space per Block: ' + IntToStr(FreeSpace) + ' bytes' + #13#10
+ 'Max No of Records in Table: ' + FormatFloat('###############,', MaxRecs));
end;
Взято с
Delphi Knowledge BaseКак найти системные папки Windows?
Как найти системные папки Windows?
Type TSystemPath=(Desktop,StartMenu,Programs,Startup,Personal, winroot, winsys);
...
Function GetSystemPath(SystemPath:TSystemPath):string;
var p:pchar;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', True);
case SystemPath of
Desktop: Result:=ReadString('Desktop');
StartMenu:Result:=ReadString('Start Menu');
Programs:Result:=ReadString('Programs');
Startup:Result:=ReadString('Startup');
Personal:Result:=ReadString('Personal');
Winroot:begin
GetMem(p,255);
GetWindowsDirectory(p,254);
result:=Strpas(p);
Freemem(p);
end;
WinSys:begin
GetMem(p,255);
GetSystemDirectory(p,254);
result:=Strpas(p);
Freemem(p);
end;
end;
finally
CloseKey;
free;
end;
if (result<>'') and (result[length(result)]<>'\') then result:=result+'\';
end;
Автор Vit
Взято с Vingrad.ru
Как найти скорость процессора?
Как найти скорость процессора?
Пример взят из рассылки: СообЧА. Программирование на Delphi ()
function GetCPUSpeed: Double;
const DelayTime = 500;
var TimerHi : DWORD;
TimerLo : DWORD;
PriorityClass : Integer;
Priority : Integer;
begin
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
Sleep(10);
asm
DW 310Fh // rdtsc
MOV TimerLo, EAX
MOV TimerHi, EDX
end;
Sleep(DelayTime);
asm
DW 310Fh // rdtsc
SUB EAX, TimerLo
SBB EDX, TimerHi
MOV TimerLo, EAX
MOV TimerHi, EDX
end;
SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result := TimerLo / (1000.0 * DelayTime);
end;
// Usage ...
LabelCPUSpeed.Caption := Format('CPU speed: %f MHz', [GetCPUSpeed]);
Взято с Vingrad.ru
function GetCPUSpeed: real;
function IsCPUID_Available: Boolean; assembler; register;
asm
PUSHFD { прямой доступ к флагам невозможен, только через стек }
POP EAX { флаги в EAX }
MOV EDX,EAX { сохраняем текущие флаги }
XOR EAX,$200000 { бит ID не нужен }
PUSH EAX { в стек }
POPFD { из стека в флаги, без бита ID }
PUSHFD { возвращаем в стек }
POP EAX { обратно в EAX }
XOR EAX,EDX { проверяем, появился ли бит ID }
JZ @exit { нет, CPUID не доступен }
MOV AL,True { Result=True }
@exit:
end;
function hasTSC: Boolean;
var
Features: Longword;
begin
asm
MOV Features,0 { Features = 0 }
PUSH EBX
XOR EAX,EAX
DW $A20F
POP EBX
CMP EAX,$01
JL @Fail
XOR EAX,EAX
MOV EAX,$01
PUSH EBX
DW $A20F
MOV Features,EDX
POP EBX
@Fail:
end;
hasTSC := (Features and $10) <> 0;
end;
const
DELAY = 500;
var
TimerHi, TimerLo: Integer;
PriorityClass, Priority: Integer;
begin
Result := 0;
if not (IsCPUID_Available and hasTSC) then Exit;
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread,
THREAD_PRIORITY_TIME_CRITICAL);
SleepEx(10, FALSE);
asm
DB $0F { $0F31 op-code for RDTSC Pentium инструкции }
DB $31 { возвращает 64-битное целое (Integer) }
MOV TimerLo,EAX
MOV TimerHi,EDX
end;
SleepEx(DELAY, FALSE);
asm
DB $0F { $0F31 op-code для RDTSC Pentium инструкции }
DB $31 { возвращает 64-битное целое (Integer) }
SUB EAX,TimerLo
SBB EDX,TimerHi
MOV TimerLo,EAX
MOV TimerHi,EDX
end;
SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result := TimerLo / (1000 * DELAY);
end;
Взято с Исходников.ru
const
ID_BIT=$200000; // EFLAGS ID bit
function GetCPUSpeed: Double;
const
DelayTime = 500;
var
TimerHi, TimerLo: DWORD;
PriorityClass, Priority: Integer;
begin
try
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriorit(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);
Sleep(10);
asm
dw 310Fh // rdtsc
mov TimerLo, eax
mov TimerHi, edx
end;
Sleep(DelayTime);
asm
dw 310Fh // rdtsc
sub eax, TimerLo
sbb edx, TimerHi
mov TimerLo, eax
mov TimerHi, edx
end;
SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result := TimerLo / (1000.0 * DelayTime);
except end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var cpuspeed:string;
begin
cpuspeed:=Format('%f MHz', [GetCPUSpeed]);
edit1.text := cpuspeed;
end;
Взято с Исходников.ru
function RdTSC : int64; register;
asm
db $0f, $31
end;
function GetCyclesPerSecond : int64;
var
hF, T, et, sc : int64;
begin
QueryPerformanceFrequency(hF); // HiTicks / second
QueryPerformanceCounter(T); // Determine start HiTicks
et := T + hF; // (Cycles are passing, but we can still USE them!)
sc := RdTSC; // Get start cycles
repeat // Use Hi Perf Timer to loop for 1 second
QueryPerformanceCounter(T); // Check ticks NOW
until (T >= et); // Break the moment we equal or exceed et
Result := RdTSC - sc; // Get stop cycles and calculate result
end;
Взято с Исходников.ru
Как найти список параллельных портов?
Как найти список параллельных портов?
functionPortExists(const PortName: string): Boolean;
var
hPort: HWND;
begin
Result := False;
hPort := CreateFile(PChar(PortName), {name}
GENERIC_READ or GENERIC_WRITE, {access attributes}
0, {no sharing}
nil, {no security}
OPEN_EXISTING, {creation action}
FILE_ATTRIBUTE_NORMAL or
FILE_FLAG_OVERLAPPED, {attributes}
0); {no template}
if hPort <> INVALID_HANDLE_VALUE then
begin
CloseHandle(hPort);
Result := True;
end;
end;
{Parallel Ports}
for i := 1 to 9 do
begin
if PortExists('LPT' + IntToStr(i)) then
List.Append('Ports: Printer Port (LPT' + IntTostr(i) + ')');
end;
Взято с
Delphi Knowledge BaseКак найти все Alias, укакзывающие на MS SQL Server?
Как найти все Alias, укакзывающие на MS SQL Server?
GetAliases(ComboBox1.Items)
procedureGetAliases(const AList: TStrings);
var
i: Integer;
Desc: DBDesc;
Buff: array[0..254] of char;
begin
// list all BDE aliases
Session.GetAliasNames(AList);
for i := AList.Count - 1 downto 0 do
begin
StrPCopy(Buff, AList[i]);
Check(DbiGetDatabaseDesc(Buff, @Desc));
// no Paradox, please
if StrPas(Desc.szDBType) = 'STANDARD' then
AList.Delete(i)
end
end;
Взято с
Delphi Knowledge BaseКак найти все форматы бумаги, поддерживаемые принтером?
Как найти все форматы бумаги, поддерживаемые принтером?
uses
Printers, WinSpool;
procedure GetPapernames(sl: TStrings);
type
TPaperName = array [0..63] of Char;
TPaperNameArray = array [1..High(Word) div SizeOf(TPaperName)] of TPaperName;
PPapernameArray = ^TPaperNameArray;
var
Device, Driver, Port: array [0..255] of Char;
hDevMode: THandle;
i, numPaperformats: Integer;
pPaperFormats: PPapernameArray;
begin
Printer.PrinterIndex := -1; // Standard printer
Printer.GetPrinter(Device, Driver, Port, hDevmode);
numPaperformats := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
if numPaperformats 0 then
begin
GetMem(pPaperformats, numPaperformats * SizeOf(TPapername));
try
WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES,
PChar(pPaperFormats), nil);
sl.Clear;
for i := 1 to numPaperformats do sl.Add(pPaperformats^[i]);
finally
FreeMem(pPaperformats);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetPapernames(memo1.Lines);
end;
Взято с сайта
Вот пример, выводящий список форматов бумаги для принтера, установленного по умолчанию:
procedure TForm1.Button2Click(Sender: TObject);
type
TPaperName = array[0..63] of Char;
TPaperNameArray = array[1..High(Cardinal) div Sizeof(TPaperName)] of
TPaperName;
PPapernameArray = ^TPaperNameArray;
var
Device, Driver, Port: array[0..255] of Char;
hDevMode: THandle;
i, numPaperformats: Integer;
pPaperFormats: PPapernameArray;
begin
Printer.PrinterIndex := -1;
Printer.GetPrinter(Device, Driver, Port, hDevmode);
numPaperformats :=
WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
if numPaperformats > 0 then
begin
GetMem(pPaperformats, numPaperformats * Sizeof(TPapername));
try
WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES,
Pchar(pPaperFormats), nil);
memo1.clear;
for i := 1 to numPaperformats do
memo1.lines.add(pPaperformats^[i]);
finally
FreeMem(pPaperformats);
end;
end;
end;
Взято из
Советов по Delphi от
Сборник Kuliba
Как найти все комьютеры в сети?
Как найти все комьютеры в сети?
unit FindComp;
interface
uses
Windows, Classes;
function FindComputers: DWORD;
var
Computers: TStringList;
implementation
uses
SysUtils;
const
MaxEntries = 250;
function FindComputers: DWORD;
var
EnumWorkGroupHandle, EnumComputerHandle: THandle;
EnumError: DWORD;
Network: TNetResource;
WorkGroupEntries, ComputerEntries: DWORD;
EnumWorkGroupBuffer, EnumComputerBuffer: array[1..MaxEntries] of TNetResource;
EnumBufferLength: DWORD;
I, J: DWORD;
begin
Computers.Clear;
FillChar(Network, SizeOf(Network), 0);
with Network do
begin
dwScope := RESOURCE_GLOBALNET;
dwType := RESOURCETYPE_ANY;
dwUsage := RESOURCEUSAGE_CONTAINER;
end;
EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @Network, EnumWorkGroupHandle);
if EnumError = NO_ERROR then
begin
WorkGroupEntries := MaxEntries;
EnumBufferLength := SizeOf(EnumWorkGroupBuffer);
EnumError := WNetEnumResource(EnumWorkGroupHandle, WorkGroupEntries, @EnumWorkGroupBuffer, EnumBufferLength);
if EnumError = NO_ERROR then
begin
for I := 1 to WorkGroupEntries do
begin
EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @EnumWorkGroupBuffer[I], EnumComputerHandle);
if EnumError = NO_ERROR then
begin
ComputerEntries := MaxEntries;
EnumBufferLength := SizeOf(EnumComputerBuffer);
EnumError := WNetEnumResource(EnumComputerHandle, ComputerEntries, @EnumComputerBuffer, EnumBufferLength);
if EnumError = NO_ERROR then
for J := 1 to ComputerEntries do
Computers.Add(Copy(EnumComputerBuffer[J].lpRemoteName, 3, Length(EnumComputerBuffer[J].lpRemoteName) - 2));
WNetCloseEnum(EnumComputerHandle);
end;
end;
end;
WNetCloseEnum(EnumWorkGroupHandle);
end;
if EnumError = ERROR_NO_MORE_ITEMS then
EnumError := NO_ERROR;
Result := EnumError;
end;
initialization
Computers := TStringList.Create;
finalization
Computers.Free;
end.
Взято с Vingrad.ru
Как найти все комьютеры в сети?
function TNetForm.FillNetLevel(xxx: PNetResource; List:TListItems): Word;
Type
PNRArr = ^TNRArr;
TNRArr = array[0..59] of TNetResource;
Var
x: PNRArr;
tnr: TNetResource;
I : integer;
EntrReq,
SizeReq,
twx: THandle;
WSName: string;
LI:TListItem;
begin
Result :=WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,RESOURCEUSAGE_CONTAINER, xxx, twx);
If Result = ERROR_NO_NETWORK Then Exit;
if Result = NO_ERROR then
begin
New(x);
EntrReq := 1;
SizeReq := SizeOf(TNetResource)*59;
while (twx <> 0) and
(WNetEnumResource(twx, EntrReq, x, SizeReq) <> ERROR_NO_MORE_ITEMS) do
begin
For i := 0 To EntrReq - 1 do
begin
Move(x^[i], tnr, SizeOf(tnr));
case tnr.dwDisplayType of
RESOURCEDISPLAYTYPE_SERVER:
begin
if tnr.lpRemoteName <> '' then
WSName:= tnr.lpRemoteName
else WSName:= tnr.lpComment;
LI:=list.Add;
LI.Caption:=copy(WSName,3,length(WSName)-2);
//list.Add(WSName);
end;
else FillNetLevel(@tnr, list);
end;
end;
end;
Dispose(x);
WNetCloseEnum(twx);
end;
end;
Пример вызова:
FillNetLevel(nil,ListView1.Items);
Автор Pegas
Взято с Vingrad.ru
Как найти все комьютеры в сети?
function EnumerateFunc( hwnd: HWND; hdc: HDC; lpnr: PNetResource ): Boolean;
const
cbBuffer : DWORD = 16384; // 16K is a good size
var
hEnum, dwResult, dwResultEnum : DWORD;
lpnrLocal : array
[0..16384 div SizeOf(TNetResource)] of TNetResource; // pointer to enumerated structures
i : integer;
cEntries : Longint;
begin
centries := -1; // enumerate all possible entries
// Call the WNetOpenEnum function to begin the enumeration.
dwResult := WNetOpenEnum(
RESOURCE_CONTEXT, // Enumerate currently connected resources.
RESOURCETYPE_DISK, // all resources
0, // enumerate all resources
lpnr, // NULL first time the function is called
hEnum // handle to the resource
);
if (dwResult <> NO_ERROR) then
begin
// Process errors with an application-defined error handler
Result := False;
Exit;
end;
// Initialize the buffer.
FillChar( lpnrLocal, cbBuffer, 0 );
// Call the WNetEnumResource function to continue
// the enumeration.
dwResultEnum := WNetEnumResource(hEnum, // resource handle
DWORD(cEntries), // defined locally as -1
@lpnrLocal, // LPNETRESOURCE
cbBuffer); // buffer size
// This is just printing
for i := 0 to cEntries - 1 do
begin
// loop through each structure and
// get remote name of resource... lpnrLocal[i].lpRemoteName)
end;
// Call WNetCloseEnum to end the enumeration.
dwResult := WNetCloseEnum(hEnum);
if(dwResult <> NO_ERROR) then
begin
// Process errors... some user defined function here
Result := False;
end
else
Result := True;
end;
Код вроде бы из борландовского FAQ. На форуме приведен SmaLL
Взято с Vingrad.ru
Как найти все комьютеры в сети?
Вот решение приведенное на для нахождения всех компютеров:
var
Computer: array[1..500] of string[25];
ComputerCount: Integer;
procedure FindAllComputers(Workgroup: string);
var
EnumHandle: THandle;
WorkgroupRS: TNetResource;
Buf: array[1..500] of TNetResource;
BufSize: Integer;
Entries: Integer;
Result: Integer;
begin
ComputerCount := 0;
Workgroup := Workgroup + #0;
FillChar(WorkgroupRS, SizeOf(WorkgroupRS), 0);
with WorkgroupRS do
begin
dwScope := 2;
dwType := 3;
dwDisplayType := 1;
dwUsage := 2;
lpRemoteName := @Workgroup[1];
end;
WNetOpenEnum(RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
0,
@WorkgroupRS,
EnumHandle);
repeat
Entries := 1;
BufSize := SizeOf(Buf);
Result :=
WNetEnumResource(EnumHandle,
Entries,
@Buf,
BufSize);
if (Result = NO_ERROR) and (Entries = 1) then
begin
Inc(ComputerCount);
Computer[ComputerCount] := StrPas(Buf[1].lpRemoteName);
end;
until (Entries <> 1) or (Result <> NO_ERROR);
WNetCloseEnum(EnumHandle);
end; { Find All Computers }
Взято с Vingrad.ru
Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
Вы должны определить в программе вызываемую снаружи функцию.
Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь
четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно
использовать в качестве owner'а своих dialog box'ов), второй - HINSTANCE
задачи, третий - остаток командной строки (LPCSTR, даже под NT),
четвертый - не знаю ;). Hапример,
int __stdcall __declspec(dllexport) Test
(
HWND hWnd,
HINSTANCE hInstance,
LPCSTR lpCmdLine,
DWORD dummy
)
{
MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
return 0;
}
rundll32 test.dll,_Test@16 this is a command line
выдаст message box со строкой "this is a command line".
Oleg Moroz
(2:5020/701.22)
function Test(
hWnd: Integer;
hInstance: Integer;
lpCmdLine: PChar;
dummy: Longint
): Integer; stdcall; export;
begin
Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);
Result := 0;
end;
Akzhan Abdulin
(2:5040/55)
Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень
забавную вещь. А именно -- пусть у нас есть исходник на Си пpимеpно такого
вида:
int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD
dummy )
......
int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD
dummy )
......
и .def-файл пpимеpно такого вида:
EXPORTS
RunDll
RunDllA=RunDll
RunDllW
то rundll32 становится pазбоpчивой -- под HТ вызывает UNICODE-веpсию. Под
95, pазумеется, ANSI. Rulez.
Alexey A Popoff
pvax@glas.apc.org, posp@ccas.ru
http://www.ccas.ru/~posp/popov/pvax.html
(2:5020/487.26)Администрирование
Как написать Outlook AddIn?
Как написать Outlook AddIn?
{
1. Create an ActiveX-Library
Save the project as e.g. "OLAddIn.dpr"
2.Create an automation object
Call the CoClass e.g. "AddIn"
Save the Unit as "AddIn.pas"
3. Add to the uses clause
- AddInDesignerObjects_TLB
- Outlook_TLB
}
- procedure OnConnection(const Application: IDispatch; ConnectMode: ext_ConnectMode;
const AddInInst: IDispatch; var custom: PSafeArray); safecall;
- procedure OnDisconnection(RemoveMode: ext_DisconnectMode; var custom: PSafeArray); safecall;
- procedure OnAddInsUpdate(var custom: PSafeArray); safecall;
- procedure OnStartupComplete(var custom: PSafeArray); safecall;
- procedure OnBeginShutdown(var custom: PSafeArray); safecall;
{
and complete the class by pressing Ctrl-Shft-C
4. Step
Register the COM-object with "run / register ActiveX Server"
Register the AddIn, so that the Addin will be recognized by Outlook
- Create a new key: HKEY_CURRENT_USER\Software\Microsoft\Office\Outlook\Addins\OLAddIn.AddIn
- create a DWOrd "LoadBehavior" with the value 3
5.
Compile the AddIn
Start Outllok
Sourcecode
*********************************************************************************
}
library OLAddIn;
uses
ComServ,
OLAddIn_TLB in 'OLAddIn_TLB.pas',
AddIn in 'AddIn.pas' {AddIn: CoClass};
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;
{$R *.TLB}
{$R *.RES}
begin
end.
{
*********************************************************************************
*********************************************************************************
}
unit AddIn;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
ComObj, ActiveX, OLAddIn_TLB, StdVcl, AddinDesignerObjects_TLB, Outlook_TLB;
type
TAddIn = class(TAutoObject, IAddIn, IDTExtensibility2)
protected
{ Protected declarations }
procedure OnConnection(const Application: IDispatch; ConnectMode: ext_ConnectMode;
const AddInInst: IDispatch; var custom: PSafeArray); safecall;
procedure OnDisconnection(RemoveMode: ext_DisconnectMode; var custom: PSafeArray); safecall;
procedure OnAddInsUpdate(var custom: PSafeArray); safecall;
procedure OnStartupComplete(var custom: PSafeArray); safecall;
procedure OnBeginShutdown(var custom: PSafeArray); safecall;
end;
implementation
uses ComServ, Dialogs;
{ TAddIn }
procedure TAddIn.OnAddInsUpdate(var custom: PSafeArray);
begin
end;
procedure TAddIn.OnBeginShutdown(var custom: PSafeArray);
begin
end;
procedure TAddIn.OnConnection(const Application: IDispatch;
ConnectMode: ext_ConnectMode; const AddInInst: IDispatch;
var custom: PSafeArray);
begin
// To show, that the AddIn has started just say anything
ShowMessage('Das AddIn wurde gestartet');
end;
procedure TAddIn.OnDisconnection(RemoveMode: ext_DisconnectMode;
var custom: PSafeArray);
begin
end;
procedure TAddIn.OnStartupComplete(var custom: PSafeArray);
begin
end;
initialization
TAutoObjectFactory.Create(ComServer, TAddIn, Class_AddIn,
ciMultiInstance, tmApartment);
end.
Взято с сайта
Как написать сквой хранитель экрана?
Как написать сквой хранитель экрана?
1.В файл проекта (*.DPR) добавить строку {$D SCRNSAVE <название хранителя>} после строки подключения модулей (Uses...). 2.У окна формы убрать системное меню, кнопки и придать свойству WindowState значение wsMaximize. 3.Предусмотреть выход из хранителя при нажатии на клавиши клавиатуры, мыши и при перемещении курсора мыши. 4.Проверить параметры с которым был вызван хранитель и если это /c - показать окно настройки хранителя, а иначе (можно проверять на /s, а можно и не проверять) сам хранитель. /p - для отображения в окне установок хранителя экрана. 5.Скомпилировать хранитель экрана. 6.Переименовать *.EXE файл в файл *.SCR и скопировать его в каталог WINDOWS\SYSTEM\. 7.Установить новый хранитель в настройках системы! Название хранителя может состоять из нескольких слов с пробелами, на любом языке. При работе хранителя необходимо прятать курсор мыши, только не забывайте восстанавливать его после выхода. Все параметры и настройки храните в файле .INI, так как хранитель и окно настройки не связаны друг с другом напрямую. Старайтесь сделать свой хранитель как можно меньше и быстрее. Иначе ваши долго работающие (в фоновом режиме) приложения будут работать еше дольше!
{в файле *.DPR}
{$D SCRNSAVE Пример хранителя экрана}
{проверить переданные параметры}
IF (ParamStr(1) = '/c') OR (ParamStr(1) = '/C') THEN
{скрыть курсор мыши}
ShowCursor(False);
{восстановить курсор мыши}
ShowCursor(True);
Главное о чем стоит упомянуть это, что ваш хранитель экрана будет работать в фоновом режиме и он не должен мешать работе других запущенных программ. Поэтому сам хранитель должен быть как можно меньшего объема. Для уменьшения объема файла в описанной ниже программе не используется визуальные компоненты Delphi, включение хотя бы одного из них приведет к увеличению размера файла свыше 200кб, а так, описанная ниже программа, имеет размер всего 20кб!!! Технически, хранитель экрана является нормальным EXE файлом (с расширением .SCR), который управляется через командные параметры строки. Например, если пользователь хочет изменить параметры вашего хранителя, Windows выполняет его с параметром "-c" в командной строке. Поэтому начать создание вашего хранителя экрана следует с создания примерно следующей функции:
Procedure RunScreenSaver;
Var S : String;
Begin
S := ParamStr(1);
If (Length(S) > 1) Then Begin
Delete(S,1,1); { delete first char - usally "/" or "-" }
S[1] := UpCase(S[1]);
End;
LoadSettings; { load settings from registry }
If (S = 'C') Then RunSettings
Else If (S = 'P') Then RunPreview
Else If (S = 'A') Then RunSetPassword
Else RunFullScreen;
End;
Поскольку нам нужно создавать небольшое окно предварительного просмотра и полноэкранное окно, их лучше объединить используя единственный класс окна. Следуя правилам хорошего тона, нам также нужно использовать многочисленные нити. Дело в том, что, во-первых, хранитель не должен переставать работать даже если что-то "тяжелое" случилось, и во-вторых, нам не нужно использовать таймер. Процедура для запуска хранителя на полном экране - приблизительно такова:
Procedure RunFullScreen;
Var
R : TRect;
Msg : TMsg;
Dummy : Integer;
Foreground : hWnd;
Begin
IsPreview := False; MoveCounter := 3;
Foreground := GetForegroundWindow;
While (ShowCursor(False) > 0) do ;
GetWindowRect(GetDesktopWindow,R);
CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,0);
CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
SystemParametersInfo(spi_ScreenSaverRunning,1,@Dummy,0);
While GetMessage(Msg,0,0,0) do Begin
TranslateMessage(Msg);
DispatchMessage(Msg);
End;
SystemParametersInfo(spi_ScreenSaverRunning,0,@Dummy,0);
ShowCursor(True);
SetForegroundWindow(Foreground);
End;
Во-первых, мы проинициализировали некоторые глобальные переменные (описанные далее), затем прячем курсор мыши и создаем окно хранителя экрана. Имейте в виду, что важно уведомлять Windows, что это - хранителя экрана через SystemParametersInfo (это выводит из строя Ctrl-Alt-Del чтобы нельзя было вернуться в Windows не введя пароль). Создание окна хранителя:
Function CreateScreenSaverWindow(Width,Height : Integer;
ParentWindow : hWnd) : hWnd;
Var WC : TWndClass;
Begin
With WC do Begin
Style := cs_ParentDC;
lpfnWndProc := @PreviewWndProc;
cbClsExtra := 0; cbWndExtra := 0; hIcon := 0; hCursor := 0;
hbrBackground := 0; lpszMenuName := nil;
lpszClassName := 'MyDelphiScreenSaverClass';
hInstance := System.hInstance;
end;
RegisterClass(WC);
If (ParentWindow 0) Then
Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
ws_Child Or ws_Visible or ws_Disabled,0,0,
Width,Height,ParentWindow,0,hInstance,nil)
Else Begin
Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
ws_Visible or ws_Popup,0,0,Width,Height, 0,0,hInstance,nil);
SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize
or swp_NoRedraw);
End;
PreviewWindow := Result;
End;
Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения. Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра ? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:
Procedure RunPreview;
Var
R : TRect;
PreviewWindow : hWnd;
Msg : TMsg;
Dummy : Integer;
Begin
IsPreview := True;
PreviewWindow := StrToInt(ParamStr(2));
GetWindowRect(PreviewWindow,R);
CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-
R.Top,PreviewWindow);
CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
While GetMessage(Msg,0,0,0) do Begin
TranslateMessage(Msg); DispatchMessage(Msg);
End;
End;
Как Вы видите, window handle является вторым параметром (после "-p"). Чтобы "выполнять" хранителя экрана - нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:
Function PreviewThreadProc(Data : Integer) : Integer; StdCall;
Var R : TRect;
Begin
Result := 0; Randomize;
GetWindowRect(PreviewWindow,R);
MaxX := R.Right-R.Left; MaxY := R.Bottom-R.Top;
ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);
Repeat
InvalidateRect(PreviewWindow,nil,False);
Sleep(30);
Until QuitSaver;
PostMessage(PreviewWindow,wm_Destroy,0,0);
End;
Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить !). Для того, чтобы оперировать этим сообщением, нам нужна процедура:
Function PreviewWndProc(Window : hWnd; Msg,WParam,
LParam : Integer): Integer; StdCall;
Begin
Result := 0;
Case Msg of
wm_NCCreate : Result := 1;
wm_Destroy : PostQuitMessage(0);
wm_Paint : DrawSingleBox; { paint something }
wm_KeyDown : QuitSaver := AskPassword;
wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :
Begin
If (Not IsPreview) Then Begin
Dec(MoveCounter);
If (MoveCounter <= 0) Then QuitSaver :=
AskPassword;
End;
End;
Else Result := DefWindowProc(Window,Msg,WParam,LParam);
End;
End;
Если мышь перемещается, кнопка нажала, мы спрашиваем у пользователя пароль:
Function AskPassword : Boolean;
Var
Key : hKey;
D1,D2 : Integer; { two dummies }
Value : Integer;
Lib : THandle;
F : TVSSPFunc;
Begin
Result := True;
If (RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop',0,
Key_Read,Key) = Error_Success) Then
Begin
D2 := SizeOf(Value);
If (RegQueryValueEx(Key,'ScreenSaveUsePassword',nil,@D1,
@Value,@D2) = Error_Success) Then
Begin
If (Value 0) Then Begin
Lib := LoadLibrary('PASSWORD.CPL');
If (Lib > 32) Then Begin
@F := GetProcAddress(Lib,'VerifyScreenSavePwd');
ShowCursor(True);
If (@F nil) Then Result := F(PreviewWindow);
ShowCursor(False);
MoveCounter := 3; { reset again if password was wrong }
FreeLibrary(Lib);
End;
End;
End;
RegCloseKey(Key);
End;
End;
Это также демонстрирует использование registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции? TVSSFunc ОПРЕДЕЛЕН как:
Type
TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall;
Теперь почти все готово, кроме диалога конфигурации. Это
запросто:
Procedure RunSettings;
Var Result : Integer;
Begin
Result :=
DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc);
If (Result = idOK) Then SaveSettings;
End;
Трудная часть -это создать диалоговый сценарий (запомните: мы не используем здесь Delphi формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:
SaverSettingsDlg DIALOG 70, 130, 166, 75
STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU
CAPTION "Settings for Boxes"
FONT 8, "MS Sans Serif"
BEGIN
DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16
PUSHBUTTON "Cancel", 6, 115, 28, 46, 16
CTEXT "Box &Color:", 3, 2, 30, 39, 9
COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
CTEXT "Box &Type:", 1, 4, 3, 36, 9
COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani
Jдrvinen.", 7, 4, 57, 103, 16,
WS_CHILD | WS_VISIBLE | WS_GROUP
End
Почти также легко сделать диалоговое меню:
Function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer):
Integer; StdCall;
Var S : String;
Begin
Result := 0;
Case Msg of
wm_InitDialog : Begin
{ initialize the dialog box }
Result := 0;
End;
wm_Command : Begin
If (LoWord(WParam) = 5) Then
EndDialog(Window,idOK)
Else If (LoWord(WParam) = 6) Then
EndDialog(Window,idCancel);
End;
wm_Close : DestroyWindow(Window);
wm_Destroy : PostQuitMessage(0);
Else Result := 0;
End;
End;
После того, как пользователь выбрал некоторые установочные параметры, нам нужно сохранить их.
Procedure SaveSettings;
Var
Key : hKey;
Dummy : Integer;
Begin
If (RegCreateKeyEx(hKey_Current_User,
'Software\SilverStream\SSBoxes',
0,nil,Reg_Option_Non_Volatile,
Key_All_Access,nil,Key,
@Dummy) = Error_Success) Then Begin
RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,
@RoundedRectangles,SizeOf(Boolean));
RegSetValueEx(Key,'SolidColors',0,Reg_Binary,
@SolidColors,SizeOf(Boolean));
RegCloseKey(Key);
End;
End;
Загружаем параметры так:
Procedure LoadSettings;
Var
Key : hKey;
D1,D2 : Integer; { two dummies }
Value : Boolean;
Begin
If (RegOpenKeyEx(hKey_Current_User,
'Software\SilverStream\SSBoxes',0,
Key_Read,
Key) = Error_Success) Then Begin
D2 := SizeOf(Value);
If (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1,
@Value, @D2) = Error_Success) Then
Begin
RoundedRectangles := Value;
End;
If (RegQueryValueEx(Key,'SolidColors',nil,@D1,
@Value,@D2) = Error_Success) Then
Begin
SolidColors := Value;
End;
RegCloseKey(Key);
End;
End;
Легко? Нам также нужно позволить пользователю, установить пароль. Я честно не знаю почему это оставлено разработчику приложений ? Тем не менее:
Procedure RunSetPassword;
Var
Lib : THandle;
F : TPCPAFunc;
Begin
Lib := LoadLibrary('MPR.DLL');
If (Lib > 32) Then Begin
@F := GetProcAddress(Lib,'PwdChangePasswordA');
If (@F nil) Then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);
FreeLibrary(Lib);
End;
End;
Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом. TPCPAFund ОПРЕДЕЛЕН как:
Type
TPCPAFunc = Function(A : PChar; Parent : hWnd; B,C : Integer) :
Integer; StdCall;
(Не спрашивайте меня что за параметры B и C) Теперь единственная вещь, которую нам нужно рассмотреть, - самая странная часть: создание графики. Я не великий ГУРУ графики, так что Вы не увидите затеняющие многоугольники, вращающиеся в реальном времени. Я только сделал некоторые ящики.
Procedure DrawSingleBox;
Var
PaintDC : hDC;
Info : TPaintStruct;
OldBrush : hBrush;
X,Y : Integer;
Color : LongInt;
Begin
PaintDC := BeginPaint(PreviewWindow,Info);
X := Random(MaxX); Y := Random(MaxY);
If SolidColors Then
Color :=
GetNearestColor(PaintDC,RGB(Random(255),Random(255),Random(255)))
Else Color := RGB(Random(255),Random(255),Random(255));
OldBrush := SelectObject(PaintDC,CreateSolidBrush(Color));
If RoundedRectangles Then
RoundRect(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y),20,20)
Else Rectangle(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y));
DeleteObject(SelectObject(PaintDC,OldBrush));
EndPaint(PreviewWindow,Info);
End;
Чтобы закончить создание хранителя, я даю Вам некоторые детали. Первые, глобальные переменные:
Var
IsPreview : Boolean;
MoveCounter : Integer;
QuitSaver : Boolean;
PreviewWindow : hWnd;
MaxX,MaxY : Integer;
RoundedRectangles : Boolean;
SolidColors : Boolean;
Затем исходная программа проекта (.dpr). Красива, а!?
program MySaverIsGreat;
uses
windows, messages, Utility; { defines all routines }
{$R SETTINGS.RES}
begin
RunScreenSaver;
end.
Ох, чуть не забыл: Если, Вы используете SysUtils в вашем проекте (StrToInt определен там) Вы получаете большой EXE чем обещанный 20k. Если Вы хотите все же иметь20k, Вы не можете использовать SysUtils так, или Вам нужно написать вашу собственную StrToInt программу. Конец. Use Val... ;-) перевод: Владимиров А.М. От переводчика. Если все же очень трудно обойтись без использования Delphi-форм, то можно поступить как в случае с вводом пароля: форму изменения параметров хранителя сохранить в виде DLL и динамически ее загружать при необходимости. Т.о. будет маленький и шустрый файл самого хранителя экрана и довеска DLL для конфигурирования и прочего (там объем и скорость уже не критичны).
Как написать собственный класс?
Как написать собственный класс?
Вот пример написания класса. Этот класс вычисляет сумму квадратов введенных чисел. Этот класс написан мной только для примера, и я исходил из соображений наглядности, а не оптимальности. Большая часть реализации не только не оптимальна, но и бессмыслена, но показывает бОльшую часть простейших приемов создания класса.
unit Unit2;
interface
Uses classes, Sysutils;
{Нам нужен процедурный тип для создания собственного события. Собственно - это описание процедуры которая должна будет исполнятся при каких-нибудь обстоятельствах}
Type
TError = procedure(Sender:TObject; Error: string) of object;
{Описание нашего класса, мы его наследуем от TObject, потому ?то нам практи?ески не нужна
никакия функциональность предков}
Type TStatistic=Class(TObject)
private {здесь описываются только внутренние переменные и процедуры - "для служебного пользования"}
{Описание полей, т.е. переменных которые работают только внутри класса, "снаружи" они не
доступны.}
FList:TStringList;
FPrecision: byte;
{Тоже переменная - для определения события}
FonError: TError;
{функция - будет использоваться только внутри класса, "снаружи" напрямую не доступна}
function GetCount: integer;
public {Описанное здесь доступно для пользователя класса}
{Конструктор - метод создания класса, имеет смысл его описывать только если он делает
?то-то специфи?еское - например нам надо будет создать переменную FList. В противном слу?ае
его описание можно опустить - будет работать конструктор родительского класса}
Constructor Create;
{Деструктор - метод разрушения класса}
Destructor Destroy; override;
{Описание методов - собственно методы мало ?ем отли?аются от процедур}
Procedure AddValue(Value:String);
Procedure Clear;
Function Solve:real;
{Описание свойств. Обратите внимание само свойство не способно хранить никакую информацию, это
только указатель на внутренюю струкруру. Например для хранения свойства Precision используется
переменная FPrecision. А для ?тение свойства Count используется функция GetCount}
Property Precision:byte read FPrecision write FPrecision;
Property Count:integer read GetCount;
{Описание событий. ?то такое событие? - Это указатель на процедуру. Сам класс реализации этой процедуры
не знает. Классу известно только заголовок процедуры, вы в коде программы будете писать реализацию
процедуры, а класс только в нужный момент передаст ей управление, используя указатель onError}
Property onError:TError read FonError write FonError;
end;
implementation
{ TStatistic }
constructor TStatistic.Create;
begin
inherited; {Вна?але надо вызвать конструктор класса-родителя}
FList:=TStringList.create;{создаем структуры нашего класса}
end;
destructor TStatistic.Destroy;
begin
FList.Free;{Разрушаем структуры нашего класса}
inherited;{в последнюю о?ередь вызываем деструктор клсса-родителя}
end;
procedure TStatistic.AddValue(Value: String);
begin
FList.add(Value); {Примерно так мы реализуем метод}
end;
procedure TStatistic.Clear;
begin
FList.clear;
end;
function TStatistic.GetCount: integer;
begin
Result:=FList.count+1;
end;
function TStatistic.Solve: real;
var i:integer;
begin
result:=0;
for i:=0 to FList.count-1 do
begin
try
result:=result+(Sqr(strtofloat(FList[i])));
except
{интересная конструкция. "on e:exception do" - мы "отлавливаем" ошибку как переменную "e".
Эта переменная имеет о?ень полезное свойство e.message - оно содержит описание ошибки. Далее
следует вызов события. Вна?але мы проверяем использует ли пользователь событие:
"if Assigned(FOnError) then", если использует то вызываем его процедуру: FOnError, с параметрами:
self - зарезервированная переменная - указатель на экземпляр нашего класса, e.message - описание
ошибки}
on e:exception do
if Assigned(FOnError) then FOnError(Self, e.message);
end;
end;
end;
end.
Вот пример использования этого класса:
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure OnError(Sender:TObject; Error: string);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var Statistic:TStatistic;
begin
Statistic:=TStatistic.create;
Statistic.onError:=onError;
Statistic.AddValue('123423');
Statistic.AddValue('123423');
showmessage(floattostr(Statistic.solve));
Statistic.Clear;
Statistic.AddValue('123423');
Statistic.AddValue('12ssss3');
showmessage(floattostr(Statistic.solve));
Statistic.Free;
end;
procedure TForm1.OnError(Sender: TObject; Error: string);
begin
showmessage('Error inside class:'+Sender.ClassName+#13#10+Error);
end;
end.
Автор ответа: Vit
Взято с Vingrad.ru
Как написать свой Plug in
Как написать свой Plug in
Типовая задача - разрабатывается некая задача и при этом
Некоторые ее компоненты могут не инсталлироваться баз ущерба для работоспособности
Некоторые компоненты предполагается изготавливать впоследствии и рассылать пользователям
Некоторые компоненты могут разрабатываться другими программистами и распространяться независимо от программы
.....
Классические примеры - фильтры для совместимости по форматам файлов с другими программами, некоторые расширения и дополнительные возможности. Примеры и моей практики - приведу парочку
Программа управления программатором ПЗУ. Заранее неизвестно, с каким железом она будет работать и как им управлять. Необходимо было дать возможнось разработчику железа написать для него поддержку
Программа печати отчетов. Она должна печатать в любой кодировке на любой принтере, в т.ч. и экзотическом типа АЦПУ. Заранее неизвестно, какие принтеры будуп применяться совместно с ней и как ими управлять (известно только одно - драйверов под них нет и не будет) - переделывать программу под каждый принтер - неинтересно ...
Итак, все это можно реализовать в DLL, однако обычное ее подключение приведет к тому, что при запуске программа будет искать все подключенне к ней DLL и в случае отсутствия хотя-бы одной откажется запускаться. Это не приемлемо, но к счастю есть возможность и весьма удоюный набор сервисных функций для динамической загрузки, использования и выгрузки DLL.
Пример (приложение имеет одно окно, на нем кнопка):
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
end;
// Тип "процедура". Естественно, можно определит типы
// "функция" или "функция с параметрами" ...
TDllProc = procedure;
var
Form1: TForm1;
DllProcPtr : TDllProc;
LibInstance : HMODULE; // Логический номер модуля DLL
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
// Проверим, загружена ли DLL
if LibInstance=0 then Begin
// Не загружена, попробуем загрузить
LibInstance := LoadLibrary('plug_in.dll');
// Проверим, успешна ли загрузка (LibInstance=0 - неуспешно)
If LibInstance=0 then Begin
ShowMessage('Ошибка загрузки библиотеки plug_in.dll');
exit;
end;
// Ищем функцию по ее имени (имя должно точно совпадать)
DllProcPtr := TDllProc(GetProcAddress(LibInstance,'MyProc'));
// Проверим, нашли ли (если нашли, то Assigned вернет true)
if not Assigned(DllProcPtr) then Begin
// Не нашли - выгружаем DLL из памяти
FreeLibrary(LibInstance);
LibInstance:=0;
ShowMessage('Ошибка: функция MyProc не найдена');
exit;
end;
// Непосредственно вызов функции
DllProcPtr;
// Выгрузка библиотеки
FreeLibrary(LibInstance);
LibInstance:=0;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DllProcPtr:=nil;
LibInstance:=0;
end;
end.
Естественно, в реальной задаче имеет смысл создать свой класс, который при инициализации будет загружать библиотеку, а при уничтожении - выгружать. Кроме того, он должен иметь функцию типа "Перезагрузить библиотеку", которая будет выгружать текущую и загружать новую. DLL - обычная, естественно может иметь неограниченное количество процедур и функций.
Особенности:
Пока библиотека загружена, ее файл нельзя ни удалить, ни переименовать. Поэтому при возникновении ошибок следует выгружать библиотеку, иначе пользователь не сможет ее заменит (без перезагрузки ПК).
Обычно имеет смысл создать ряд функции типа GetInfo, GetAutor, GetCopyRight ..., чтобы вызывающая программа могла получить информацию о назначении данной DLL
Расширение DLL не является обязательным, поэтому можно применять свои расширения (например DRV)
Источник:
Как напрямую добраться до Oracle?
Как напрямую добраться до Oracle?
Автор: Philip A. Milovanov ( http://korys.chat.ru )
Для этого можно воспользоваться компонентами от AllRoundAutomations Direct Oracle Access. Если кому надо могу поделиться. При помощи этих компонент можно не только производить простые запросы/вставки, но и выполнять DDL-скрипты, и иметь доступ к объектам Oracle 8, примет смотри ниже...
var Address: TOracleObject;
begin
Query.SQL.Text := 'select Name, Address from Persons';
Query.Execute;
while not Query.Eof do
begin
Address := Query.ObjField('Address');
if not Address.IsNull then
ShowMessage(Query.Field('Name') + ' lives in ' + Address.GetAttr('City'));
Query.Next;
end;
end;
Взято с Исходников.ru
Как нарисовать Bitmap с прозрачностью
Как нарисовать Bitmap с прозрачностью
procedure DrawTransparentBmp(Cnv: TCanvas; x,y: Integer; Bmp: TBitmap;
clTransparent: TColor);
var
bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
oldcol: Longint;
begin
try
bmpAND := TBitmap.Create;
bmpAND.Width := Bmp.Width;
bmpAND.Height := Bmp.Height;
bmpAND.Monochrome := True;
oldcol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent));
BitBlt(bmpAND.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height, Bmp.Canvas.Handle,
0,0, SRCCOPY);
SetBkColor(Bmp.Canvas.Handle, oldcol);
bmpINVAND := TBitmap.Create;
bmpINVAND.Width := Bmp.Width;
bmpINVAND.Height := Bmp.Height;
bmpINVAND.Monochrome := True;
BitBlt(bmpINVAND.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY);
bmpXOR := TBitmap.Create;
bmpXOR.Width := Bmp.Width;
bmpXOR.Height := Bmp.Height;
BitBlt(bmpXOR.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height, Bmp.Canvas.Handle,
0,0, SRCCOPY);
BitBlt(bmpXOR.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
bmpINVAND.Canvas.Handle, 0,0, SRCAND);
bmpTarget := TBitmap.Create;
bmpTarget.Width := Bmp.Width;
bmpTarget.Height := Bmp.Height;
BitBlt(bmpTarget.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height, Cnv.Handle, x,y,
SRCCOPY);
BitBlt(bmpTarget.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
bmpAND.Canvas.Handle, 0,0, SRCAND);
BitBlt(bmpTarget.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
bmpXOR.Canvas.Handle, 0,0, SRCINVERT);
BitBlt(Cnv.Handle, x,y,Bmp.Width,Bmp.Height, bmpTarget.Canvas.Handle, 0,0,
SRCCOPY);
finally
bmpXOR.Free;
bmpAND.Free;
bmpINVAND.Free;
bmpTarget.Free;
end;
end;
Взято с Исходников.ru
Как нарисовать что-нибудь на TMemo?
Как нарисовать что-нибудь на TMemo?
Для рисования на поверхности TMemo необходимо создать создать собственный компонент, наследованный от TMemo и переопределить в нём рисование. Примерно так:
type
TMyMemo = class(TMemo)
protected
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
А теперь добавьте реализацию этой процедуры:
procedure TMyMemo.WMPaint(var Message: TWMPaint);
var
MCanvas: TControlCanvas;
DrawBounds : TRect;
Begin
inherited;
MCanvas:=TControlCanvas.Create;
DrawBounds := ClientRect; // Работаем с временной записью TRect.
Try
MCanvas.Control:=Self;
With MCanvas do
Begin
Brush.Color := clBtnFace;
FrameRect( DrawBounds );
InflateRect( DrawBounds, -1, -1);
FrameRect( DrawBounds );
FillRect ( DrawBounds );
MoveTo ( 33, 0 );
Brush.Color := clWhite;
LineTo ( 33, ClientHeight );
PaintImages;
end;
finally
MCanvas.Free;
End;
end;
Процедура PaintImages рисует картинки на канвасе Memo.
procedure TMyMemo.PaintImages;
var
MCanvas: TControlCanvas;
DrawBounds : TRect;
i, j : Integer;
OriginalRegion : HRGN;
ControlDC : HDC;
begin
MCanvas:=TControlCanvas.Create;
DrawBounds := ClientRect; // Работаем с временной записью TRect.
try
MCanvas.Control:=Self;
ControlDC := GetDC ( Handle );
MCanvas.Draw(0, 1, Application.Icon);
finally
MCanvas.Free;
end;
end;
Теперь мы имеем собственноручно нарисованный memo.
Взято с Исходников.ru
Как нарисовать disable текст
Как нарисовать disable текст
{************************ Draw Disabled Text **************
***** This function draws text in "disabled" style. *****
***** i.e. the text is grayed . *****
**********************************************************}
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
var Rect: TRect; Format: Word): Integer;
begin
SetBkMode(Canvas.Handle, TRANSPARENT);
OffsetRect(Rect, 1, 1);
Canvas.Font.color:= ClbtnHighlight;
DrawText (Canvas.Handle, Str, Count, Rect,Format);
Canvas.Font.Color:= ClbtnShadow;
OffsetRect(Rect, -1, -1);
DrawText (Canvas.Handle, Str, Count, Rect, Format);
end;
Зайцев О.В.
Владимиров А.М.
Взято с Исходников.ru
Как нарисовать фрактал?
Как нарисовать фрактал?
![](image/796_1.jpg)
procedure DrawMandelbrot(ACanvas: TCanvas; X, Y, au, bu: Double; X2, Y2: Integer);
var
c1, c2, z1, z2, tmp: Double;
i, j, Count: Integer;
begin
c2 := bu;
for i := 10 to X2 do
begin
c1 := au;
for j := 0 to Y2 do
begin
z1 := 0;
z2 := 0;
Count := 0;
{count is deep of iteration of the mandelbrot set
if |z| >=2 then z is not a member of a mandelset}
while (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do
begin
tmp := z1;
z1 := z1 * z1 - z2 * z2 + c1;
z2 := 2 * tmp * z2 + c2;
Inc(Count);
end;
//the color-palette depends on TColor(n*count mod t)
{$IFDEF LINUX}
ACanvas.Pen.Color := (16 * Count mod 255);
ACanvas.DrawPoint(j, i);
{$ELSE}
ACanvas.Pixels[j, i] := (16 * Count mod 255);
{$ENDIF}
c1 := c1 + X;
end;
c2 := c2 + Y;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
R: TRect;
au, ao: Integer;
dX, dY, bo, bu: Double;
begin
// Initialize Mandelbrot
R.Left := 0;
R.Right := 200;
R.Top := 0;
R.Bottom := 205;
ao := 1;
au := -2;
bo := 1.5;
bu := -1.5;
//direct scaling cause of speed
dX := (ao - au) / (R.Right - R.Left);
dY := (bo - bu) / (R.Bottom - R.Top);
DrawMandelbrot(Self.Canvas, dX, dY, au, bu, R.Right, R.Bottom);
end;
Автор: Михаил Марковский
...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.
uses graph, crt;
const
GrafType = 1; {1..3}
type
PointPtr = ^Point;
Point = record
X, Y: Word;
Angle: Real;
Next: PointPtr
end;
GrfLine = array[0..5000] of
Byte;
ChangeType = array[1..30] of
record
Mean: Char;
NewString: string
end;
var
K, T, Dx, Dy, StepLength, GrafLength: Word;
grDriver, Xt: Integer;
grMode: Integer;
ErrCode: Integer;
CurPosition: Point;
Descript: GrfLine;
StartLine: string absolute Descript;
ChangeNumber, Generation: Byte;
Changes: ChangeType;
AngleStep: Real;
Mem: Pointer;
procedure Replace(var Stroka: GrfLine;
OldChar: Char;
Repl: string);
var
I, J: Word;
begin
if (GrafLength = 0) or (Length(Repl) = 0) then
Exit;
I := 1;
while I <= GrafLength do
begin
if Chr(Stroka[I]) = OldChar then
begin
for J := GrafLength downto I + 1 do
Stroka[J + Length(Repl) - 1] := Stroka[J];
for J := 1 to Length(Repl) do
Stroka[I + J - 1] := Ord(Repl[J]);
I := I + J;
GrafLength := GrafLength + Length(Repl) - 1;
continue
end;
I := I + 1
end
end;
procedure PushCoord(var Ptr: PointPtr;
C: Point);
var
P: PointPtr;
begin
New(P);
P^.X := C.X;
P^.Y := C.Y;
P^.Angle := C.Angle;
P^.Next := Ptr;
Ptr := P
end;
procedure PopCoord(var Ptr: PointPtr;
var Res: Point);
begin
if Ptr <> nil then
begin
Res.X := Ptr^.X;
Res.Y := Ptr^.Y;
Res.Angle := Ptr^.Angle;
Ptr := Ptr^.Next
end
end;
procedure FindGrafCoord(var Dx, Dy: Word;
Angle: Real;
StepLength: Word);
begin
Dx := Round(Sin(Angle) * StepLength * GetMaxX / GetMaxY);
Dy := Round(-Cos(Angle) * StepLength);
end;
procedure NewAngle(Way: ShortInt;
var Angle: Real;
AngleStep: Real);
begin
if Way >= 0 then
Angle := Angle + AngleStep
else
Angle := Angle - AngleStep;
if Angle >= 4 * Pi then
Angle := Angle - 4 * Pi;
if Angle < 0 then
Angle := 4 * Pi + Angle
end;
procedure Rost(var Descr: GrfLine;
Cn: Byte;
Ch: ChangeType);
var
I: Byte;
begin
for I := 1 to Cn do
Replace(Descr, Ch[I].Mean, Ch[I].NewString);
end;
procedure Init1;
begin
AngleStep := Pi / 8;
StepLength := 7;
Generation := 4;
ChangeNumber := 1;
CurPosition.Next := nil;
StartLine := 'F';
GrafLength := Length(StartLine);
with Changes[1] do
begin
Mean := 'F';
NewString := 'FF+[+F-F-F]-[-F+F+F]'
end;
end;
procedure Init2;
begin
AngleStep := Pi / 4;
StepLength := 3;
Generation := 5;
ChangeNumber := 2;
CurPosition.Next := nil;
StartLine := 'G';
GrafLength := Length(StartLine);
with Changes[1] do
begin
Mean := 'G';
NewString := 'GFX[+G][-G]'
end;
with Changes[2] do
begin
Mean := 'X';
NewString := 'X[-FFF][+FFF]FX'
end;
end;
procedure Init3;
begin
AngleStep := Pi / 10;
StepLength := 9;
Generation := 5;
ChangeNumber := 5;
CurPosition.Next := nil;
StartLine := 'SLFF';
GrafLength := Length(StartLine);
with Changes[1] do
begin
Mean := 'S';
NewString := '[+++G][---G]TS'
end;
with Changes[2] do
begin
Mean := 'G';
NewString := '+H[-G]L'
end;
with Changes[3] do
begin
Mean := 'H';
NewString := '-G[+H]L'
end;
with Changes[4] do
begin
Mean := 'T';
NewString := 'TL'
end;
with Changes[5] do
begin
Mean := 'L';
NewString := '[-FFF][+FFF]F'
end;
end;
begin
case GrafType of
1: Init1;
2: Init2;
3: Init3;
else
end;
grDriver := detect;
InitGraph(grDriver, grMode, '');
ErrCode := GraphResult;
if ErrCode <> grOk then
begin
WriteLn('Graphics error:', GraphErrorMsg(ErrCode));
Halt(1)
end;
with CurPosition do
begin
X := GetMaxX div 2;
Y := GetMaxY;
Angle := 0;
MoveTo(X, Y)
end;
SetColor(white);
for K := 1 to Generation do
begin
Rost(Descript, ChangeNumber, Changes);
Mark(Mem);
for T := 1 to GrafLength do
begin
case Chr(Descript[T]) of
'F':
begin
FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
with CurPosition do
begin
Xt := X + Dx;
if Xt < 0 then
X := 0
else
X := Xt;
if X > GetMaxX then
X := GetMaxX;
Xt := Y + Dy;
if Xt < 0 then
Y := 0
else
Y := Xt;
if Y > GetMaxY then
Y := GetMaxY;
LineTo(X, Y)
end
end;
'f':
begin
FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
with CurPosition do
begin
Xt := X + Dx;
if Xt < 0 then
X := 0
else
X := Xt;
if X > GetMaxX then
X := GetMaxX;
Xt := Y + Dy;
if Xt < 0 then
Y := 0
else
Y := Xt;
if Y > GetMaxY then
Y := GetMaxY;
MoveTo(X, Y)
end
end;
'+': NewAngle(1, CurPosition.Angle, AngleStep);
'-': NewAngle(-1, CurPosition.Angle, AngleStep);
'I': NewAngle(1, CurPosition.Angle, 2 * Pi);
'[': PushCoord(CurPosition.Next, CurPosition);
']':
begin
PopCoord(CurPosition.Next, CurPosition);
with CurPosition do
MoveTo(X, Y)
end
end
end;
Dispose(Mem);
Delay(1000)
end;
repeat
until KeyPressed;
CloseGraph
end.
Взято с сайта
Как нарисовать график функции?
Как нарисовать график функции?
procedure TForm1.Button3Click(Sender: TObject);
var x, y: array[1..50] of double;
i: integer;
scalex, scaley, ymin, ymax, xmin, xmax: double;
begin
for i := 1 to 50 do
begin
y[i] := sin(i * 0.5);
x[i] := i;
end;
xmin := x[1];
xmax := x[1];
ymin := y[1];
ymax := y[1];
for i := 2 to 50 do
begin // или используйте ymin:=MinValue(y); и т.д.
if y[i] < ymin then ymin := y[i];
if y[i] > ymax then ymax := y[i];
if x[i] < xmin then xmin := x[i];
if x[i] > xmax then xmax := x[i];
end;
scalex := paintbox1.Width / (xmax - xmin);
scaley := paintbox1.Height / (ymax - ymin);
with paintbox1.canvas do
begin
moveto(trunc(scalex * (x[1] - xmin)), paintbox1.height - trunc(scaley * (y[1] - ymin)));
for i := 2 to 50 do
Lineto(trunc(scalex * (x[i] - xmin)), paintbox1.height - trunc(scaley * (y[i] - ymin)));
end;
end;
Забавная штука синусы:
for i:=1 to 500 do begin
paintbox1.Canvas.Pixels [round(sin(i*5)*10+50),round(sin(i*10)*10+50)] := RGB(0,0,0);
Автор ответа: Baa
Взято с Vingrad.ru
Как нарисовать кривую Безье?
Как нарисовать кривую Безье?
Cтатья Даниила Карапетяна ( )
как нарисовать кривую
Безье. Именно она применяется для построения гладких кривых во всех графических
программах - от PaintBrush до CorelDraw и PhotoShop. Для задания кривой Безье n-ной степени (чем больше степень, тем более кривой
может быть линия; кривая первой степени - отрезок) нужно указать n+1 точку. Первая
и последняя точки будут началом и концом кривой, а остальные точки задаю ее поведение
на других участках. В частности, первая и n-ая точки задают касательные и кривизну
кривой на ее концах. В большинстве программ используются кривые Безье третьего
порядка. Начиная с Delphi5 такую кривую можно нарисовать при помощи функции PolyBezier. Кривая Безье задается параметрически (x=x(t), y=y(t)). Это позволяет ей вести
себя абсолютно произвольно. Если бы она задавалась, как y(x), она не смогла бы
даже сделать поворот на 180 градусов. Функции x(t) и y(t) выглядят так:
x(t)= Cn0 * t0 * (1-t)n * x0 + Cn1 * t1 * (1-t)n-1 * x1 + Cn2 * t2 * (1-t)n-2
* x2 + ... + Cnn * tn * (1-t)0 * xn
y(t)= Cn0 * t0 * (1-t)n * y0 + Cn1 * t1 * (1-t)n-1 * y1 + Cn2 * t2 * (1-t)n-2
* y2 + ... + Cnn * tn * (1-t)0 * yn
где n - порядок кривой, Cni - коэффициенты в разложении бинома Ньютона, t - параметр,
меняющийся от 0 до 1, xi, yi - координаты опорных точек. Эта программа строит кривую Безье n-ного порядка. n задается в SpinEdit1. Все
узлы можно перемещать по полю мышью. Для создания нового узла нужно нажать мышью
на пустое место на поле или увеличить порядок кривой. Скачать необходимые для компиляции файлы проекта можно на .
uses Math;
const
RectSize = 5;
MaxN = 128;
var
n: integer = -1;
pt: array [0..MaxN] of TPoint;
C: array [0..MaxN] of single;
bm: TBitMap;
function GetBinomialCoefficient(m, i: integer): single;
function Factorial(x: integer): double;
var i: integer;
begin
result := 1;
for i := 2 to x do result := result * i;
end;
begin
result := Factorial(m) / (Factorial(i) * Factorial(m - i));
end;
procedure DrawBezier(Canvas: TCanvas; Count: integer);
type
TPointArray = array [word] of TPoint;
PPointArray = ^TPointArray;
var
p: PPointArray;
Step, qx, qy, t, q: single;
i, j: integer;
begin
GetMem(p, sizeof(TPoint) * (Count + 1));
Step := 1.0 / Count;
for i := 0 to Count do
begin
t := i * Step;
qx := 0; qy := 0;
for j := 0 to n do
begin
q := C[j] * IntPower(1 - t, j) * IntPower(t, n - j);
qx := qx + q * pt[j].x;
qy := qy + q * pt[j].y;
end;
p[i] := Point(round(qx), round(qy));
end;
Canvas.Polyline(Slice(p^, Count + 1));
FreeMem(p);
end;
procedure DrawLines(canvas: TCanvas; const pt: array of TPoint);
var
i: integer;
begin
Canvas.Pen.Color := clGreen;
Canvas.Pen.Width := 1;
Canvas.MoveTo(pt[0].x, pt[0].y);
for i := 0 to n do
begin
Canvas.Rectangle(Bounds(pt[i].x - RectSize, pt[i].y - RectSize,
2 * RectSize, 2 * RectSize));
Canvas.LineTo(pt[i].x, pt[i].y);
end;
end;
procedure Redraw;
begin
with Form1.PaintBox1 do
begin
bm.Canvas.FillRect(Bounds(0, 0, Width, Height));
if Form1.CheckBox1.Checked then DrawLines(bm.Canvas, pt);
bm.Canvas.PolyBezier(pt);
bm.Canvas.Pen.Color := clRed;
bm.Canvas.pen.Width := Form1.SpinEdit3.Value;
DrawBezier(bm.Canvas, Form1.SpinEdit2.Value);
Canvas.Draw(0, 0, bm);
end;
end;
var
moving: integer = -1;
oldr: TRect;
procedure FillRandom(NewN: integer);
var
i: integer;
begin
randomize;
for i := n+1 to NewN do pt[i] := Point(random(Form1.PaintBox1.Width - 20) + 10,
random(Form1.PaintBox1.Height - 20) + 10);
n := NewN;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
bm := TBitmap.Create;
bm.Width := PaintBox1.Width;
bm.Height := PaintBox1.height; SpinEdit1.MinValue := 1;
SpinEdit1.MaxValue := MaxN;
SpinEdit1.Value := 3; SpinEdit2.MinValue := 6;
SpinEdit2.MaxValue := MaxN * 4;
SpinEdit2.Value := 50;
SpinEdit2.OnChange := PaintBox1.OnPaint; SpinEdit3.MinValue := 1;
SpinEdit3.MaxValue := 8;
SpinEdit3.Value := 3;
SpinEdit3.OnChange := PaintBox1.OnPaint; CheckBox1.Checked := true;
CheckBox1.OnClick := PaintBox1.OnPaint;
end;
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
i: integer;
r: TRect;
begin
if Button <> mbLeft then Exit;
for i := 0 to n do
if (abs(X - pt[i].x) <= RectSize) and (abs(Y - pt[i].y) <= RectSize) then
begin
moving := i;
r.TopLeft := Form1.ClientToScreen(PaintBox1.BoundsRect.TopLeft);
r.BottomRight := Form1.ClientToScreen(PaintBox1.BoundsRect.BottomRight);
GetClipCursor(oldr);
ClipCursor(@r);
Exit;
end;
if moving < 0 then
begin
SpinEdit1.Value := SpinEdit1.Value + 1;
pt[n] := Point(X, Y);
Redraw;
end;
end;
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if moving < 0 then Exit;
pt[moving] := Point(X, Y);
Redraw;
end;
procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) and (moving >= 0) then
begin
moving := -1;
ClipCursor(@oldr);
end;
end;
procedure TForm1.SpinEdit1Change(Sender: TObject);
var
i: integer;
begin
FillRandom(SpinEdit1.Value);
SpinEdit2.MinValue := n * 2;
for i := 0 to n do C[i] := GetBinomialCoefficient(n, i);
Redraw;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
Redraw;
end;
Взято с Vingrad.ru
Как нарисовать метафайл?
Как нарисовать метафайл?
unitMetaform;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
BitBtn1: TBitBtn;
Image1: TImage;
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TMetafileCanvas = class(TCanvas)
private
FClipboardHandle: THandle;
FMetafileHandle: HMetafile;
FRect: TRect;
protected
procedure CreateHandle; override;
function GetMetafileHandle: HMetafile;
public
constructor Create;
destructor Destroy; override;
property Rect: TRect read FRect write FRect;
property MetafileHandle: HMetafile read GetMetafileHandle;
end;
constructor TMetafileCanvas.Create;
begin
inherited Create;
FClipboardHandle := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TMetafilePict));
end;
destructor TMetafileCanvas.Destroy;
begin
DeleteMetafile(CloseMetafile(Handle));
if Bool(FClipboardHandle) then
GlobalFree(FClipboardHandle);
if Bool(FMetafileHandle) then
DeleteMetafile(FMetafileHandle);
inherited Destroy;
end;
procedure TMetafileCanvas.CreateHandle;
var
MetafileDC: HDC;
begin
{ Create a metafile DC in memory }
MetafileDC := CreateMetaFile(nil);
if Bool(MetafileDC) then
begin
{ Map the top,left corner of the displayed rectangle to the top,left of the
device context. Leave a border of 10 logical units around the picture. }
with FRect do
SetWindowOrg(MetafileDC, Left - 10, Top - 10);
{ Set the extent of the picture with a border of 10 logical units.}
with FRect do
SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20);
{ Play any valid metafile contents to it. }
if Bool(FMetafileHandle) then
begin
PlayMetafile(MetafileDC, FMetafileHandle);
end;
end;
Handle := MetafileDC;
end;
function TMetafileCanvas.GetMetafileHandle: HMetafile;
var
MetafilePict: PMetafilePict;
IC: HDC;
ExtRect: TRect;
begin
if Bool(FMetafileHandle) then
DeleteMetafile(FMetafileHandle);
FMetafileHandle := CloseMetafile(Handle);
Handle := 0;
{ Prepair metafile for clipboard display. }
MetafilePict := GlobalLock(FClipboardHandle);
MetafilePict^.mm := mm_AnIsoTropic;
IC := CreateIC('DISPLAY', nil, nil, nil);
SetMapMode(IC, mm_HiMetric);
ExtRect := FRect;
DPtoLP(IC, ExtRect, 2);
DeleteDC(IC);
MetafilePict^.xExt := ExtRect.Right - ExtRect.Left;
MetafilePict^.yExt := ExtRect.Top - ExtRect.Bottom;
MetafilePict^.HMF := FMetafileHandle;
GlobalUnlock(FClipboardHandle);
{ I'm giving you this handle, but please do NOT eat it. }
Result := FClipboardHandle;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
MetafileCanvas: TMetafileCanvas;
begin
MetafileCanvas := TMetafileCanvas.Create;
MetafileCanvas.Rect := Rect(0, 0, 500, 500);
MetafileCanvas.Ellipse(10, 10, 400, 400);
Image1.Picture.Metafile.LoadFromClipboardFormat(cf_MetafilePict,
MetafileCanvas.MetafileHandle, 0);
MetafileCanvas.Free;
end;
end.
Взято с
Delphi Knowledge BaseКак нарисовать повёрнутый текст
Как нарисовать повёрнутый текст
uses
QT;
procedure TForm1.RotatedText(Cnv: TCanvas; Wkl: Integer; Pxy: TPoint; Txt: string);
var
PrPoint: TPoint;
begin
// Rotate Canvas
QPainter_rotate(Cnv.Handle, Wkl);
// Convert Device Coord. to Modell- Coord.
QPainter_xFormDev(Cnv.Handle, PPoint(@PrPoint),
PPoint(@Pxy));
// Write text.
Canvas.TextOut(PrPoint.X, PrPoint.Y, 'Txt');
end;
Взято с сайта
Как нарисовать радугу?
Как нарисовать радугу?
How do I paint the color spectrum of a rainbow, and if the
spectrum is clicked on, how do I calculate what color was
clicked on?
The following example demonstrates painting a color spectrum,
and calculating the color of a given point on the spectrum.
Two procedures are presented: PaintRainbow() and
ColorAtRainbowPoint(). The PaintRainbow() procedure paints a
spectrum from red to magenta if the WrapToRed parameter is
false, or paint red to red if the WrapToRed parameter is true.
The rainbow can progress either in a horizontal or
vertical progression. The ColorAtRainbowPoint() function
returns a TColorRef containing the color at a given point in
the rainbow.
procedure PaintRainbow(Dc : hDc; {Canvas to paint to}
x : integer; {Start position X}
y : integer; {Start position Y}
Width : integer; {Width of the rainbow}
Height : integer {Height of the rainbow};
bVertical : bool; {Paint verticallty}
WrapToRed : bool); {Wrap spectrum back to red}
var
i : integer;
ColorChunk : integer;
OldBrush : hBrush;
OldPen : hPen;
r : integer;
g : integer;
b : integer;
Chunks : integer;
ChunksMinus1 : integer;
pt : TPoint;
begin
OffsetViewportOrgEx(Dc,
x,
y,
pt);
if WrapToRed = false then
Chunks := 5 else
Chunks := 6;
ChunksMinus1 := Chunks - 1;
if bVertical = false then
ColorChunk := Width div Chunks else
ColorChunk := Height div Chunks;
{Red To Yellow}
r := 255;
b := 0;
for i := 0 to ColorChunk do begin
g:= (255 div ColorChunk) * i;
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
{Yellow To Green}
g:=255;
b:=0;
for i := ColorChunk to (ColorChunk * 2) do begin
r := 255 - (255 div ColorChunk) * (i - ColorChunk);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
{Green To Cyan}
r:=0;
g:=255;
for i:= (ColorChunk * 2) to (ColorChunk * 3) do begin
b := (255 div ColorChunk)*(i - ColorChunk * 2);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
{Cyan To Blue}
r := 0;
b := 255;
for i:= (ColorChunk * 3) to (ColorChunk * 4) do begin
g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
{Blue To Magenta}
g := 0;
b := 255;
for i:= (ColorChunk * 4) to (ColorChunk * 5) do begin
r := (255 div ColorChunk) * (i - ColorChunk * 4);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush))
end;
if WrapToRed <> false then begin
{Magenta To Red}
r := 255;
g := 0;
for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin
b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5));
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
end;
{Fill Remainder}
if (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin
if WrapToRed <> false then begin
r := 255;
g := 0;
b := 0;
end else begin
r := 255;
g := 0;
b := 255;
end;
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc,
ColorChunk * Chunks,
0,
Width - (ColorChunk * Chunks),
Height,
PatCopy) else
PatBlt(Dc,
0,
ColorChunk * Chunks,
Width,
Height - (ColorChunk * Chunks),
PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
OffsetViewportOrgEx(Dc,
Pt.x,
Pt.y,
pt);
end;
function ColorAtRainbowPoint(ColorPlace : integer;
RainbowWidth : integer;
WrapToRed : bool) : TColorRef;
var
ColorChunk : integer;
ColorChunkIndex : integer;
ColorChunkStart : integer;
begin
if ColorPlace = 0 then begin
result := RGB(255, 0, 0);
exit;
end;
{WhatChunk}
if WrapToRed <> false then
ColorChunk := RainbowWidth div 6 else
ColorChunk := RainbowWidth div 5;
ColorChunkStart := ColorPlace div ColorChunk;
ColorChunkIndex := ColorPlace mod ColorChunk;
case ColorChunkStart of
0 : result := RGB(255,
(255 div ColorChunk) * ColorChunkIndex,
0);
1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex,
255,
0);
2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);
3 : result := RGB(0,
255 - (255 div ColorChunk) * ColorChunkIndex,
255);
4 : result := RGB((255 div ColorChunk) * ColorChunkIndex,
0,
255);
5 : result := RGB(255,
0,
255 - (255 div ColorChunk) * ColorChunkIndex);
else
if WrapToRed <> false then
result := RGB(255, 0, 0) else
result := RGB(255, 0, 255);
end;{Case}
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
PaintRainbow(Form1.Canvas.Handle,
0,
0,
Form1.ClientWidth,
Form1.ClientHeight,
false,
true);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
InvalidateRect(Form1.Handle, nil, false);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Color : TColorRef;
begin
Color := ColorAtRainbowPoint(y,
Form1.ClientWidth,
true);
ShowMessage(IntToStr(GetRValue(Color)) + #32 +
IntToStr(GetGValue(Color)) + #32 +
IntToStr(GetBValue(Color)));
end;
Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE
Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE
прописать в
\HKEY_LOCAL_MACHINE\SOFTWARE\ORACLEпараметр:
NLS_NUMERIC_CHARACTERS = '.,'
или
после соединения с ORACLE выполнить
ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'
Взято из
Как настроить табуляцию в компоненте TMemo?
Как настроить табуляцию в компоненте TMemo?
Пошлите в Memo сообщение EM_SETTABSTOPS
Взято с сайта
procedureTForm1.FormCreate(Sender: TObject);
var
DialogUnitsX: LongInt;
PixelsX: LongInt;
i: integer;
TabArray: array[0..4] of integer;
begin
Memo1.WantTabs := true;
DialogUnitsX := LoWord(GetDialogBaseUnits);
PixelsX := 20;
for i := 1 to 5 do
begin
TabArray[i - 1] := ((PixelsX * i) * 4) div DialogUnitsX;
end;
SendMessage(Memo1.Handle,
EM_SETTABSTOPS, 5, LongInt(@TabArray));
Memo1.Refresh;
end;
Взято из
DELPHI VCL FAQ
Перевод с английского Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для
Как научить приложение Delphi разговаривать?
Как научить приложение Delphi разговаривать?
Автор: Alec Bergamini
Совместимость: Delphi 5.x (или выше)
11-го августа 2001 Microsoft объявила о выпуске SAPI 5.1 SDK. Данный продукт можно использовать в любом языке, который поддерживает OLE автоматизацию.
В данной статье я постараюсь раасказать, как установить SAPI 5.1 SDK. Затем мы посмотрим, как использовать SDK в приложении Delphi для преобразования текста в синтезированную речь. Синтезированная речь будет проигрываться через спикер. Всё это тестировалось в Delphi 5 и 6.
Чтобы скачать SAPI 5.1, необходимо зайти на сайт Microsoft's Speech.net Technologies по адресу http://www.microsoft.com/speech/ и кликнуть по ссылке download. Далее будет предложено прочитать комментарии к данному продукту. Если в Вашей системе, язык по умолчанию отличается от US English, то настоятельно рекомендую прочитать эти комментарии до конца.
Если Вы используете beta версию операционной системы XP, то у Вас могут возникнуть некоторые проблемы. Проблемы связаны с тем, что большинство beta версий XP включают в себя ранние версии SAPI 5.1. Поэтому не пытайтесь инсталировать release версию SAPI 5.1 на XP, она не будет работать.
После того как Вы прочитаете комментарии, то приступайте к скачиванию Speech SDK 5.1. Всё что для этого потребуется, это нажать на ссылку Speech SDK 5.1 (68 MB). В архиве содержится сам SDK, докумантация, а так же текты на английском для примера.
Итак, после скачивания SAPI 5.1 SDK, запустите speechsdk51.exe для установки его на Ваш компьютер.
Теперь надо дать знать Delphi о новых объектах автоматизации SAPI. Для этого запустите Delphi 5 или 6 (Я не пробовал боле ранние версии) и откройте Project | Import Type Library. В диалоге Import Type Library выберите "Microsoft Speech Object Library (Version 5.1)". Если Вы не нашли его в списке, значит во время инсталяции SAPI 5.1 произошли какие-то ошибки.
Delphi предложит поместить компоненты SAPI на станицу ActiveX. Я рекомендую разместить их в новой странице под названием "SAPI 5", так как количество компонент довольно большое (19). Так же рекомендую Вам выбрать "Unit dir name" отличающуюся от той, которая предлагается по умолчанию. Убедитесь, что на "Generate Component Wrapper" стоит галочка и нажмите кнопку >Install<.
В диалоге Install выберите закладку "Into new package" и в поле "File name:" введите имя пакета наподобие "SAPI5.dpk", нажмите кнопку "Обзор..." (browse) и убедитесь, что dpk создан в той же директории, в которой были созданы компоненты. В диалоге Install в поле Description задайте какое-нибудь описание, например "SAPI 5 automation components". Нажмите OK
В подтверждающем диалоге нажмите yes. После этого новые компоненты будут установлены.
Теперь, если Вы посмотрите в директорию, которую указали для установки компонент, то обнаружите там файл SpeechLib_TLB.pas (и dcr) который содержит весь код компоненты (интерфайс, константы, типы, а так же другую полезную информацию). Эта директория так же содержит (если Вы следовали вышеприведённым инструкциям) SAPI5.dpk который является исходинком пакета.
А теперь самая интересная часть.
Давайте создадим приложение, которое будет синтезировать речь. В Delphi создайте новое приложение и поместите на форму кнопку. На странице компонент SAPI5 найдите SpVoice и перетащите его на форму.
Теперь создайте событие onClick для Вашей кнопки, которое должно выглядеть примерно так:
procedure TForm1.Button1Click(Sender: TObject);
begin
SpVoice1.Speak('Hello world!', SVSFDefault);
end;
Запустите программу и нажмите кнопку. Здорово?
Метод Speak объекта SPVoice предоставляет довольно большие возможности. Эти возможности можно использовать если поиграться со вторым параметром. В вышеприведённом примере я использовал режим поумолчанию, который позволяет функции вернуть управление только после завершения проигрывания звука. Избежать этого можно путём внедрения в текст специальных тэгов XML.
Документация по SDK содержит файл sapi.chm который можно найти в директории \Program Files\Microsoft Speech SDK 5.1\Docs\Help .
Sapi.chm содержит довольно много информации. Вот основные, часто используемые возможности компоненты и, соответствующие им флаги, которые передаются во втором параметре:
Воспроизведение текста находящегося в файле. (SVSFIsFilename)
Асинхронный решим проигрывания звука. Позволяет функции вернуть управление немедленно, во время воспроизведения. (SVSFlagsAsync)
Позволяет управлять воспроизведением через XML тэги (см. раздел под название "XML TTS Tutorial"). Тэги позволяют настроить тональность звучания, скорость воспроизведения и многое другое.( SVSFIsXML)
Одна из интересных вещей (не документирована) заключается в том, что можно озвучивать заголовок веб страницы путём установки флага в SVSFIsFilenam а имени файла в URL. Если Вы соединены с интернетом, попробуйте запустить следующую строчку:
SpVoice1.Speak('http://www.o2a.com', SVSFIsFilename);
Так же при помощи этого флага можно проигрывать wav файлы:
SpVoice1.Speak('C:\WINNT\MEDIA\Windows Logon Sound.wav', SVSFIsFilename);
На самом деле у этой SAPI намного больше возможностей, чем я здесь привёл. В следующий раз, мы подробнее рассмотрим другие возможности.
Взято с Исходников.ru
Как нажать кнопку в TWebbrowser когда в окне есть несколько кнопок?
Как нажать кнопку в TWebbrowser когда в окне есть несколько кнопок?
// If there is only one button, you can do something like:
WebBrowser1.OleObject.Document.forms.item(0).elements.item(0).click;
// This will do a click on the first element of the first <FORM>, where an
// element is either <INPUT>, <SELECT> or <TEXTAREA>.
// If there is more than one button, you can do something like:
procedure TForm1.Button1Click(Sender: TObject);
var
ovElements: OleVariant;
i: Integer;
begin
ovElements := WebBrowser1.OleObject.Document.forms.item(0).elements;
for i := 0 to (ovElements.Length - 1) do
if (ovElements.item(i).tagName = 'INPUT') and
(ovElements.item(i).type = 'SUBMIT') and
(ovElements.item(i).Value = 'Recent Charges') then
ovElements.item(i).Click;
end;
Взято с сайта
Как назначить горячие клавиши?
Как назначить горячие клавиши?
Вот код о том как назначить горячие клавиши если даже активна другая программа. Код взят из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..."
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
protected
procedure hotykey(var msg:TMessage); message WM_HOTKEY;
end;
var
Form1: TForm1;
id,id2:Integer;
implementation
{$R *.DFM}
procedure TForm1.hotykey(var msg:TMessage);
begin
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=81) then
begin
ShowMessage('Ctrl + Q wurde gedrьckt !');
end;
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=82) then
begin
ShowMessage('Ctrl + R wurde gedrьckt !');
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
id:=GlobalAddAtom('hotkey');
RegisterHotKey(handle,id,mod_control,81);
id2:=GlobalAddAtom('hotkey2');
RegisterHotKey(handle,id2,mod_control,82);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(handle,id);
UnRegisterHotKey(handle,id2);
end;
Взято с Vingrad.ru
Как назначить пароль на таблицу?
Как назначить пароль на таблицу?
usesUnit2;
// ..
TablePasswort(Table1, 'secret');
unit Unit2;
interface
uses
BDE, SysUtils, DBTables, Windows;
function TablePasswort(var table: TTable; password: string): Boolean;
implementation
function StrToOem(const AnsiStr: string): string;
begin
SetLength(result, Length(AnsiStr));
if Length(result) > 0 then
CharToOem(PChar(AnsiStr), PChar(result))
end;
function TablePasswort(var table: ttable; password: string): Boolean;
var
pTblDesc: pCRTblDesc;
hDb: hDBIDb;
begin
result := false;
with table do
begin
if Active and (not Exclusive) then
Close;
if (not Exclusive) then
Exclusive := true;
if (not Active) then
Open;
hDb := DBHandle;
Close
end;
GetMem(pTblDesc, sizeof(CRTblDesc));
FillChar(pTblDesc^, sizeof(CRTblDesc), 0);
with pTblDesc^ do
begin
StrPCopy(szTblName, StrToOem(table.tablename));
szTblType := szParadox;
StrPCopy(szPassword, StrToOem(password));
bPack := true;
bProtected := true
end;
if DbiDoRestructure(hDb, 1, pTblDesc, nil, nil, nil, false) <> DBIERR_NONE then
exit;
if pTblDesc <> nil then
FreeMem(pTblDesc, sizeof(CRTblDesc));
result := true
end;
end.
Взято с
Delphi Knowledge BaseКак обновить рабочий стол?
Как обновить рабочий стол?
procedureRefreshDesktop;
var
c1 : cardinal;
begin
c1:=FindWindowEx(FindWindowEx(FindWindow('Progman','Program Manager'),,'SHELLDLL_DefView',''),0,'SysListView32','');
PostMessage(c1,WM_KEYDOWN,VK_F5,0);
PostMessage(c1,WM_KEYUP,VK_F5,1 shl 31);
end;
Автор ответа: neutrino
Взято с Vingrad.ru
winexec(Pchar( 'rundll32 user,repaintscreen' ),sw_Show);
Автор ответа: Radmin
Взято с Vingrad.ru
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(FindWindow('Progman', 'Program Manager'),
WM_COMMAND,
$A065,
0);
end;
Взято с Исходников.ru
Как обновить TQuery не потеряв при этом текущей записи?
Как обновить TQuery не потеряв при этом текущей записи?
procedure RefreshQuery(AQuery : TQuery; const FieldsForSearch: String);
var
AList : TList;
AVarArray : Variant;
i : Byte;
begin
AList := TList.Create;
try
AQuery.GetFieldList(AList, FieldsForSearch);
AVarArray := VarArrayCreate([0, AList.Count - 1], varVariant);
for i := 0 to Pred(AList.Count) do
AVarArray[i] := TField(AList.Items[i]).AsVariant;
AQuery.Close;
AQuery.Open;
AQuery.Locate(FieldsForSearch, AVarArray, []);
finally
AList.Free;
AVarArray.Free;p
end;
end;
Взято с Исходников.ru
Как обрабатывать ошибки в COM-объектах
Как обрабатывать ошибки в COM-объектах
TCustomBasePlugObject= class(TAutoObject, IUnknown, IDispatch)
...
protected
function SafeCallException(ExceptObject: TObject; ExceptAddr:
Pointer): {$IFDEF _D4_}HResult{$ELSE}Integer{$ENDIF}; override;
...
function TCustomBasePlugObject.SafeCallException;
var
ExMsg: string;
begin
Result := inherited SafeCallException(ExceptObject, ExceptAddr);
try
if ExceptObject is EAbort then
exit;
ExMsg := 'Exception: PlugObject="' if ExceptObject is Exception then
begin
ExMsg := ExMsg + #13' Message: '#13' ' +
Exception(ExceptObject).Message +
#13' Module:' + GetModuleFileName +
#13' Adress:' + Format('%p', [ExceptAddr]);
if (ExceptObject is EOleSysError) and
(EOleSysError(ExceptObject).ErrorCode < 0) then
ExMsg := ExMsg + #13'
OleSysError.ErrorCode =
'+IntToStr(EOleSysError(ExceptObject).ErrorCode);
end;
toLog(ExMsg);
except
end;
end;
Взято с
Как очистить базу данных, оставив только структуру?
Как очистить базу данных, оставив только структуру?
ЗАМЕЧАНИЕ: Этот пример не работает в режиме редактирования, так как таблица должна быть открыта в эксклюзивном режиме.
procedure TForm1.Button2Click(Sender: TObject);
begin
{Opens the table in exclusive mode}
Try
With Table1 Do
Begin
Active:=False;
Exclusive:=True;
Active:=True;
try
EmptyTable;
except
ShowMessage('Cannot empty database');
end;
End
Except
ShowMessage('cannot open table in exclusive mode');
End
end;
Взято с Исходников.ru
Примечание Vit: если требуется очистить таблицу не прибегая к эксклюзивному доступу или используя другие способы доступа помимо BDE то рекомендуется выполнить квери:
Delete From MyTable
Которая полностью очистит таблицу. Для MS SQL Server существует и другой способ - выполнение квери:
Truncate Table MyTable
Различие между Delete и Truncate заключается в том, что для операции Delete создаётся запись в Transaction log, что обеспечивает более высокую надёжность, но при больших таблицах выполнение Delete может быть весьма долгим. Напротив, Truncate в Transaction log не попадает и таблица любых размеров необратимо очищается практически мгновенно вне зависимости от её размера. Delete - стандартная операция SQL и поддерживается всеми базами данных, напротив, Truncate - операция не стандартная, поэтому поддерживается лишь отдельными базами данных.
Как очистить буффер клавиатуры?
Как очистить буффер клавиатуры?
procedureEmptyKeyQueue;
var
msg: TMsg;
begin
while PeekMessage(msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE or PM_NOYIELD) do
;
end;
begin
EmptyKeyQueue;
end.