Как гарантированно сделать backup?
Как гарантированно сделать backup?
Как гарантированно сделать backup/restore БД InterBase с опцией 'Replace existing database' и записями протоколов в файлы с гарантированным отстрелом пользователей?
Att.bat:
at 01:00 /INTERACTIVE "e:\IB_DATA\BR.BAT"
BR.bat:
del e:\IB_DATA\b.txt
del e:\IB_DATA\r.txt
del e:\ib_data\AR_IB.PRV
del e:\IB_DATA\AR_IB.GBK
d:\ib_42\bin\gfix -shut -force 1 e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo"
net stop "InterBase Server"
copy e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.PRV
net start "InterBase Server"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.GBK -user "SYSDBA" -password "oooo" -B -L -Y "e:\IB_DATA\b.txt"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GBK e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo" -P 4096 -V -R -Y "e:\IB_DATA\r.txt"
Sergey Klochkovski
Взято с
Как хранятся строки?
Как хранятся строки?
Тип String:
по смещению -4 храниться длина строки
по смещению -8 храниться счётчик ссылок на строку (когда он обнуляется строка уничтожается)
Сама строка располагается в памяти как есть - каждая буква занимает 1 байт.
При копировании строки:
s1:=s2 - реального копирования не происходит, увеличивается только счётчик ссылок, но если после этого изменить одну из строк:
s1:=s1+'a';
то произойдёт физическое копирование содержимого строк, и теперь s1 и s2 будут показывать на разные адреса памяти.
PChar - длина строки определяется от начала до #0 байта, по сути это чистой воды pointer, так что все действия по отслеживанию распределения памяти лежат на программисте - сами заботьтесь о том чтобы хватило места для распределения памяти и освобождении после использования. Тоже одна буква = 1 байт
Для хранения unicode (т.е. 2х байтовых символов) используйте соответствующие символы с приставкой Wide...
Автор ответа: Vit
Примечание Fantasist'a:
Это верно только если s1 - локальная переменная, или s1 и s2 - обе не локальные. Если s1 не локальная(глобальная или член класса), а s2 - локальная происходит копирование.
Взято с Vingrad.ru
Как играть MIDI без медиаплеера?
Как играть MIDI без медиаплеера?
uses
MMSystem;
// Play Midi
procedure TForm1.Button1Click;
const
FileName = 'C:\YourFile.mid';
begin
MCISendString(PChar('play ' + FileName), nil, 0, 0);
end;
// Stop Midi
procedure TForm1.Button1Click;
const
FileName = 'C:\YourFile.mid';
begin
MCISendString(PChar('stop ' + FileName), nil, 0, 0);
end;
Взято с сайта
Как имитировать нажатие левой кнопки мыши?
Как имитировать нажатие левой кнопки мыши?
mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0);
Application.ProcessMessages;
mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0);
Автор ответа: Song, Spawn
Взято с Vingrad.ru
Как иммитировать появление формы как нового приложения?
Как иммитировать появление формы как нового приложения?
How i can create a form and this form stay in another icon in task bar ? (Looks like a new aplication).
In private clause:
type
TForm1 = class(TForm)
private
{ Private declarations }
procedure CreateParams(var Params: TCreateParams); override;
And, in the implementation:
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with params do
ExStyle := ExStyle or WS_EX_APPWINDOW;
end;
Взято с
Delphi Knowledge BaseКак импортировать данные из Excel в Stringgrid?
Как импортировать данные из Excel в Stringgrid?
uses
ComObj;
function Xls_To_StringGrid(AGrid: TStringGrid; AXLSFile: string): Boolean;
const
xlCellTypeLastCell = $0000000B;
var
XLApp, Sheet: OLEVariant;
RangeMatrix: Variant;
x, y, k, r: Integer;
begin
Result := False;
// Create Excel-OLE Object
XLApp := CreateOleObject('Excel.Application');
try
// Hide Excel
XLApp.Visible := False;
// Open the Workbook
XLApp.Workbooks.Open(AXLSFile);
// Sheet := XLApp.Workbooks[1].WorkSheets[1];
Sheet := XLApp.Workbooks[ExtractFileName(AXLSFile)].WorkSheets[1];
// In order to know the dimension of the WorkSheet, i.e the number of rows
// and the number of columns, we activate the last non-empty cell of it
Sheet.Cells.SpecialCells(xlCellTypeLastCell, EmptyParam).Activate;
// Get the value of the last row
x := XLApp.ActiveCell.Row;
// Get the value of the last column
y := XLApp.ActiveCell.Column;
// Set Stringgrid's row &col dimensions.
AGrid.RowCount := x;
AGrid.ColCount := y;
// Assign the Variant associated with the WorkSheet to the Delphi Variant
RangeMatrix := XLApp.Range['A1', XLApp.Cells.Item[X, Y]].Value;
// Define the loop for filling in the TStringGrid
k := 1;
repeat
for r := 1 to y do
AGrid.Cells[(r - 1), (k - 1)] := RangeMatrix[K, R];
Inc(k, 1);
AGrid.RowCount := k + 1;
until k > x;
// Unassign the Delphi Variant Matrix
RangeMatrix := Unassigned;
finally
// Quit Excel
if not VarIsEmpty(XLApp) then
begin
// XLApp.DisplayAlerts := False;
XLApp.Quit;
XLAPP := Unassigned;
Sheet := Unassigned;
Result := True;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Xls_To_StringGrid(StringGrid1, 'C:\Table1.xls') then
ShowMessage('Table has been exported!');
end;
Взято с сайта
Как инициализировать BDE, если она установлена в нестандартном месте?
Как инициализировать BDE, если она установлена в нестандартном месте?
I need to use a BDE that is placed in another directory than default. How can I do it? DbiInit(pDbiEnv) doesn't work when pDbiEnv < > nil (not default).
Answer:
pDbiEnv:= nil;
check(DbiInit(pDbiEnv));
or if you don't need the pointer simply
check(DbiInit(nil));
Взято с
Delphi Knowledge BaseКак инсталлировать INF файл?
Как инсталлировать INF файл?
uses
ShellAPI;
function InstallINF(const PathName: string; hParent: HWND): Boolean;
var
instance: HINST;
begin
instance := ShellExecute(hParent,
PChar('open'),
PChar('rundll32.exe'),
PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),
nil,
SW_HIDE);
Result := instance > 32;
end; { InstallINF }
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
InstallINF('C:\XYZ.inf', 0);
end;
Взято с сайта
Как инвертировать матрицу?
Как инвертировать матрицу?
type
RCOMat = array of array of Extended;
var
DimMat: integer;
procedure InvertMatrix(var aa: RCOMat);
var
numb, nula1, ipiv, indxr, indxc: array of Integer;
i, j, l, kod, jmax, k, ll, icol, irow: Integer;
amax, d, c, pomos, big, dum, pivinv: Double;
ind: Boolean;
begin
for j := 0 to Pred(DimMat) do ipiv[j] := 0;
irow := 1;
icol := 1;
for i := 0 to Pred(DimMat) do
begin
big := 0;
for j := 0 to Pred(DimMat) do
begin
if (ipiv[j] <> 1) then
begin
for k := 0 to Pred(DimMat) do
begin
if (ipiv[k] = 0) then
if (Abs(aa[j, k]) >= big) then
begin
big := Abs(aa[j, k]);
irow := j;
icol := k;
end
else;
end;
end;
end;
ipiv[icol] := ipiv[icol] + 1;
if (irow <> icol) then
begin
for l := 0 to Pred(DimMat) do
begin
dum := aa[irow, l];
aa[irow, l] := aa[icol, l];
aa[icol, l] := dum;
end;
for l := 0 to Pred(DimMat) do
begin
dum := aa[irow + DimMat + 1, l];
aa[irow + DimMat + 1, l] := aa[icol + DimMat + 1, l];
aa[icol + DimMat + 1, l] := dum;
end;
end;
indxr[i] := irow;
indxc[i] := icol;
if (aa[icol, icol] = 0) then;
pivinv := 1.0 / aa[icol, icol];
aa[icol, icol] := 1.0;
for l := 0 to Pred(DimMat) do aa[icol, l] := aa[icol, l] * pivinv;
for l := 0 to Pred(DimMat) do aa[icol + DimMat + 1, l] :=
aa[icol + DimMat + 1, l] * pivinv;
for ll := 0 to Pred(DimMat) do
begin
if (ll <> icol) then
begin
dum := aa[ll, icol];
aa[ll, icol] := 0.0;
for l := 0 to Pred(DimMat) do aa[ll, l] := aa[ll, l] - aa[icol, l] * dum;
for l := 0 to Pred(DimMat) do aa[ll + DimMat + 1, l] :=
aa[ll + DimMat + 1, l] - aa[icol + DimMat + 1, l] * dum;
end;
end;
end;
for l := Pred(DimMat) downto 0 do
begin
if (indxr[l] <> indxc[l]) then
begin
for k := 0 to Pred(DimMat) do
begin
dum := aa[k, indxr[l]];
aa[k, indxr[l]] := aa[k, indxc[l]];
aa[k, indxc[l]] := dum;
end;
end;
end;
end;
Взято с сайта
Как использовать anti-aliasing?
Как использовать anti-aliasing?
{The parameter "percent" needs an integer between 0 and 100 (include zero and 100). If "Percent" is 0, there will be no effect. If it's 100 there will be the strongest effect.}
procedure Antialising(C: TCanvas; Rect: TRect; Percent: Integer);
var
l, p: Integer;
R, G, B: Integer;
R1, R2, G1, G2, B1, B2: Byte;
begin
with c do
begin
Brush.Style := bsclear;
lineto(200, 100);
moveto(50, 150);
Ellipse(50, 150, 200, 30);
for l := Rect.Top to Rect.Bottom do
begin
for p := Rect.Left to Rect.Right do
begin
R1 := GetRValue(Pixels[p, l]);
G1 := GetGValue(Pixels[p, l]);
B1 := GetBValue(Pixels[p, l]);
//Pixel links
//Pixel left
R2 := GetRValue(Pixels[p - 1, l]);
G2 := GetGValue(Pixels[p - 1, l]);
B2 := GetBValue(Pixels[p - 1, l]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p - 1, l] := RGB(R, G, B);
end;
//Pixel rechts
//Pixel right
R2 := GetRValue(Pixels[p + 1, l]);
G2 := GetGValue(Pixels[p + 1, l]);
B2 := GetBValue(Pixels[p + 1, l]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p + 1, l] := RGB(R, G, B);
end;
//Pixel oben
//Pixel up
R2 := GetRValue(Pixels[p, l - 1]);
G2 := GetGValue(Pixels[p, l - 1]);
B2 := GetBValue(Pixels[p, l - 1]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p, l - 1] := RGB(R, G, B);
end;
//Pixel unten
//Pixel down
R2 := GetRValue(Pixels[p, l + 1]);
G2 := GetGValue(Pixels[p, l + 1]);
B2 := GetBValue(Pixels[p, l + 1]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p, l + 1] := RGB(R, G, B);
end;
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Antialising(Image1.Canvas, Image1.Canvas.ClipRect, 100);
end;
Взято с сайта
Как использовать базу данных BDE не указывая её имени?
Как использовать базу данных BDE не указывая её имени?
Если база данных находится в той же директории, что и экзешник, то в качестве имени базы можно использовать .\ в поле DatabaseName в TTable
Взято с Исходников.ru
Примечания Vit:
1) Если путь другой - то в поле DatabaseName можно прописать путь, например: c:\Program Files\...
2) Прописывание путивместо alias не исключает необходимости использования BDE
Как использовать ChartFX?
Как использовать ChartFX?
with ChartFX do begin
Visible := false;
{ Устанавливаем режим ввода значений }
{ 1 - количество серий (в нашем случае 1), 3 - количество значений }
OpenData [COD_VALUES] := MakeLong (1,3);
{ Hомер текущей серии }
ThisSerie := 0;
{ Value [i] - значение с индексом i }
{ Legend [i] - комментарий к этому значению }
Value [0] := a;
Legend [0] := 'Значение переменной A';
Value [1] := b;
Legend [1] := 'Значение переменной B';
Value [2] := c;
Legend [2] := 'Значение переменной C';
{ Закрываем режим }
CloseData [COD_VALUES] := 0;
{ Ширина поля с комментариями на экране (в пикселах) }
LegendWidth := 150;
Visible := true;
end;
end;Формы
Как использовать CHM help в своём проекте?
Как использовать CHM help в своём проекте?
Всё, что вам надо сделать, это сохранить ниже приведенный модуль на диске и добавить его в Uses вашего проекта. После этого Вы сможете использовать CHM файлы точно так же как и обычные HLP файлы.
unit StoHtmlHelp;
////////////////////////////////////////////////////////////////
// Implementation of context sensitive HTML help (.chm) for Delphi.
//
// Version: 1.2
// Author: Martin Stoeckli
// Homepage: www.martinstoeckli.ch/delphi
// Copyright(c): Martin Stoeckli 2002
//
// Restrictions: - Works only under the Windows platform.
// - Is written for Delphi v7, should work from v6 up.
//
// Description
// ***********
// This unit enables you to call ".chm" files from your Delphi projects.
// You can use the normal Delphi VCL framework, write your projects the
// same way, as you would using normal ".hlp" files.
//
// Installation
// ************
// Simply add this unit to your project, that's all.
//
// If your help project contains files with the extension ".html"
// instead of ".htm", then you can either pass the filename with the
// extension to Application.HelpJump(), or you can set the property
// "HtmlExt" of the global object in this unit.
// StoHelpViewer.HtmlExt := '.html';
//
// Examples
// ********
// // assign a helpfile, you could also select the helpfile at the
// // options dialog "Project/Options.../Application".
// Application.HelpFile := 'C:\MyHelp.chm';
// ...
// // shows the contents of the helpfile
// Application.HelpCommand(HELP_CONTENTS, 0);
// // or
// Application.HelpSystem.ShowTableOfContents;
// ...
// // opens the context sensitive help with a numerical id.
// // you could do the same by setting the "HelpContext"
// // property of a component and pressing the F1 key.
// Application.HelpContext(1000);
// // or with a string constant
// Application.HelpJump('welcome');
// ...
// // opens the help index with a keyword.
// // you could do the same by setting the "HelpKeyword"
// // property of a component and pressing the F1 key.
// Application.HelpKeyword('how to do');
//
interface
uses Classes, Windows, HelpIntfs;
type
THtmlHelpA = function(hwndCaller: HWND; pszFile: LPCSTR; uCommand: UINT; dwData: DWORD): HWND; stdcall;
TStoHtmlHelpViewer = class(TInterfacedObject, ICustomHelpViewer,
IExtendedHelpViewer, IHelpSelector)
private
FViewerID: Integer;
FViewerName: String;
FHtmlHelpFunction: THtmlHelpA;
protected
FHHCtrlHandle: THandle;
FHelpManager: IHelpManager;
FHtmlExt: String;
function GetHelpFileName: String;
function IsChmFile(const FileName: String): Boolean;
procedure InternalShutdown;
procedure CallHtmlHelp(const HelpFile: String; uCommand: UINT; dwData: DWORD);
// ICustomHelpViewer
function GetViewerName: String;
function UnderstandsKeyword(const HelpString: String): Integer;
function GetHelpStrings(const HelpString: String): TStringList;
function CanShowTableOfContents: Boolean;
procedure ShowTableOfContents;
procedure ShowHelp(const HelpString: String);
procedure NotifyID(const ViewerID: Integer);
procedure SoftShutDown;
procedure ShutDown;
// IExtendedHelpViewer
function UnderstandsTopic(const Topic: String): Boolean;
procedure DisplayTopic(const Topic: String);
function UnderstandsContext(const ContextID: Integer;
const HelpFileName: String): Boolean;
procedure DisplayHelpByContext(const ContextID: Integer;
const HelpFileName: String);
// IHelpSelector
function SelectKeyword(Keywords: TStrings) : Integer;
function TableOfContents(Contents: TStrings): Integer;
public
constructor Create; virtual;
destructor Destroy; override;
property HtmlExt: String read FHtmlExt write FHtmlExt;
end;
var
StoHelpViewer: TStoHtmlHelpViewer;
implementation
uses Forms, SysUtils, WinHelpViewer;
const
// imported from HTML Help Workshop
HH_DISPLAY_TOPIC = $0000;
HH_HELP_FINDER = $0000; // WinHelp equivalent
HH_DISPLAY_TOC = $0001;
HH_DISPLAY_INDEX = $0002;
HH_DISPLAY_SEARCH = $0003;
HH_KEYWORD_LOOKUP = $000D;
HH_DISPLAY_TEXT_POPUP = $000E; // display string resource id or text in a popup window
HH_HELP_CONTEXT = $000F; // display mapped numeric value in dwData
HH_TP_HELP_CONTEXTMENU = $0010; // text popup help, same as WinHelp HELP_CONTEXTMENU
HH_TP_HELP_WM_HELP = $0011; // text popup help, same as WinHelp HELP_WM_HELP
HH_CLOSE_ALL = $0012; // close all windows opened directly or indirectly by the caller
HH_ALINK_LOOKUP = $0013; // ALink version of HH_KEYWORD_LOOKUP
HH_GET_LAST_ERROR = $0014; // not currently implemented // See HHERROR.h
type
TStoWinHelpTester = class(TInterfacedObject, IWinHelpTester)
protected
// IWinHelpTester
function CanShowALink(const ALink, FileName: String): Boolean;
function CanShowTopic(const Topic, FileName: String): Boolean;
function CanShowContext(const Context: Integer;
const FileName: String): Boolean;
function GetHelpStrings(const ALink: String): TStringList;
function GetHelpPath : String;
function GetDefaultHelpFile: String;
function IsHlpFile(const FileName: String): Boolean;
end;
////////////////////////////////////////////////////////////////
// like "Application.ExeName", but in a DLL you get the name of
// the DLL instead of the application name
function Sto_GetModuleName: String;
var
szFileName: array[0..MAX_PATH] of Char;
begin
FillChar(szFileName, SizeOf(szFileName), #0);
GetModuleFileName(hInstance, szFileName, MAX_PATH);
Result := szFileName;
end;
////////////////////////////////////////////////////////////////
{ TStoHtmlHelpViewer }
////////////////////////////////////////////////////////////////
procedure TStoHtmlHelpViewer.CallHtmlHelp(const HelpFile: String; uCommand: UINT; dwData: DWORD);
begin
if Assigned(FHtmlHelpFunction) then
begin
case uCommand of
HH_CLOSE_ALL: FHtmlHelpFunction(0, nil, uCommand, dwData); // special parameters
HH_GET_LAST_ERROR: ; // ignore
else
FHtmlHelpFunction(FHelpManager.GetHandle, PChar(HelpFile), uCommand, dwData);
end;
end;
end;
function TStoHtmlHelpViewer.CanShowTableOfContents: Boolean;
begin
Result := True;
end;
constructor TStoHtmlHelpViewer.Create;
begin
inherited Create;
FViewerName := 'StoHtmlHelp';
FHtmlExt := '.htm';
// load dll
FHHCtrlHandle := LoadLibrary('HHCtrl.ocx');
if (FHHCtrlHandle <> 0) then
FHtmlHelpFunction := GetProcAddress(FHHCtrlHandle, 'HtmlHelpA');
end;
destructor TStoHtmlHelpViewer.Destroy;
begin
StoHelpViewer := nil;
// free dll
FHtmlHelpFunction := nil;
if (FHHCtrlHandle <> 0) then
FreeLibrary(FHHCtrlHandle);
inherited Destroy;
end;
procedure TStoHtmlHelpViewer.DisplayHelpByContext(const ContextID: Integer;
const HelpFileName: String);
var
sHelpFile: String;
begin
sHelpFile := GetHelpFileName;
if IsChmFile(sHelpFile) then
CallHtmlHelp(sHelpFile, HH_HELP_CONTEXT, ContextID);
end;
procedure TStoHtmlHelpViewer.DisplayTopic(const Topic: String);
var
sHelpFile: String;
sTopic: String;
sFileExt: String;
begin
sHelpFile := GetHelpFileName;
if IsChmFile(sHelpFile) then
begin
// prepare topicname as a html page
sTopic := Topic;
sFileExt := LowerCase(ExtractFileExt(sTopic));
if (sFileExt <> '.htm') and (sFileExt <> '.html') then
sTopic := sTopic + FHtmlExt;
CallHtmlHelp(sHelpFile + '::/' + sTopic, HH_DISPLAY_TOPIC, 0);
end;
end;
function TStoHtmlHelpViewer.GetHelpFileName: String;
var
sPath: String;
begin
Result := '';
// ask for the helpfile name
if Assigned(FHelpManager) then
Result := FHelpManager.GetHelpFile;
if (Result = '') then
Result := Application.CurrentHelpFile;
// if no path is specified, then add the application path
// (otherwise the file won't be found if the current directory is wrong).
if (Result <> '') then
begin
sPath := ExtractFilePath(Result);
if (sPath = '') then
Result := ExtractFilePath(Sto_GetModuleName) + Result;
end;
end;
function TStoHtmlHelpViewer.GetHelpStrings(const HelpString: String): TStringList;
begin
// create a tagged keyword
Result := TStringList.Create;
Result.Add(Format('%s: %s', [FViewerName, HelpString]));
end;
function TStoHtmlHelpViewer.GetViewerName: String;
begin
Result := FViewerName;
end;
procedure TStoHtmlHelpViewer.InternalShutdown;
begin
if Assigned(FHelpManager) then
begin
FHelpManager.Release(FViewerID);
FHelpManager := nil;
end;
end;
function TStoHtmlHelpViewer.IsChmFile(const FileName: String): Boolean;
var
iPos: Integer;
sFileExt: String;
begin
// find extension
iPos := LastDelimiter('.', FileName);
if (iPos > 0) then
begin
sFileExt := Copy(FileName, iPos, Length(FileName));
Result := CompareText(sFileExt, '.chm') = 0;
end
else
Result := False;
end;
procedure TStoHtmlHelpViewer.NotifyID(const ViewerID: Integer);
begin
FViewerID := ViewerID;
end;
function TStoHtmlHelpViewer.SelectKeyword(Keywords: TStrings): Integer;
var
i: Integer;
sViewerName: String;
begin
Result := 0;
i := 0;
// find first tagged line (see GetHelpStrings)
while (Result = 0) and (i <= Keywords.Count - 1) do
begin
sViewerName := Keywords.Strings[i];
Delete(sViewerName, Pos(':', sViewerName), Length(sViewerName));
if (FViewerName = sViewerName) then
Result := i
else
Inc(i);
end;
end;
procedure TStoHtmlHelpViewer.ShowHelp(const HelpString: String);
var
sHelpFile: String;
sHelpString: String;
begin
sHelpFile := GetHelpFileName;
if IsChmFile(sHelpFile) then
begin
// remove the tag if necessary (see GetHelpStrings)
sHelpString := HelpString;
Delete(sHelpString, 1, Pos(':', sHelpString));
sHelpString := Trim(sHelpString);
CallHtmlHelp(sHelpFile, HH_DISPLAY_INDEX, DWORD(Pchar(sHelpString)));
end;
end;
procedure TStoHtmlHelpViewer.ShowTableOfContents;
var
sHelpFile: String;
begin
sHelpFile := GetHelpFileName;
if IsChmFile(sHelpFile) then
CallHtmlHelp(sHelpFile, HH_DISPLAY_TOC, 0);
end;
procedure TStoHtmlHelpViewer.ShutDown;
begin
SoftShutDown;
if Assigned(FHelpManager) then
FHelpManager := nil;
end;
procedure TStoHtmlHelpViewer.SoftShutDown;
begin
CallHtmlHelp('', HH_CLOSE_ALL, 0);
end;
function TStoHtmlHelpViewer.TableOfContents(Contents: TStrings): Integer;
begin
// find line with viewer name
Result := Contents.IndexOf(FViewerName);
end;
function TStoHtmlHelpViewer.UnderstandsContext(const ContextID: Integer;
const HelpFileName: String): Boolean;
begin
Result := IsChmFile(HelpFileName);
end;
function TStoHtmlHelpViewer.UnderstandsKeyword(const HelpString: String): Integer;
begin
if IsChmFile(GetHelpFileName) then
Result := 1
else
Result := 0;
end;
function TStoHtmlHelpViewer.UnderstandsTopic(const Topic: String): Boolean;
begin
Result := IsChmFile(GetHelpFileName);
end;
////////////////////////////////////////////////////////////////
{ TStoWinHelpTester }
//
// delphi will call the WinHelpTester to determine, if the default
// winhelp should handle the requests.
// don't allow anything, because delphi (v7) will create an invalid
// helpfile path, calling GetHelpPath (it puts a pathdelimiter
// before the filename in "TWinHelpViewer.HelpFile").
////////////////////////////////////////////////////////////////
function TStoWinHelpTester.CanShowALink(const ALink,
FileName: String): Boolean;
begin
Result := False;
// Result := IsHlpFile(FileName);
end;
function TStoWinHelpTester.CanShowContext(const Context: Integer;
const FileName: String): Boolean;
begin
Result := False;
// Result := IsHlpFile(FileName);
end;
function TStoWinHelpTester.CanShowTopic(const Topic,
FileName: String): Boolean;
begin
Result := False;
// Result := IsHlpFile(FileName);
end;
function TStoWinHelpTester.GetDefaultHelpFile: String;
begin
Result := '';
end;
function TStoWinHelpTester.GetHelpPath: String;
begin
Result := '';
end;
function TStoWinHelpTester.GetHelpStrings(
const ALink: String): TStringList;
begin
// as TWinHelpViewer would do it
Result := TStringList.Create;
Result.Add(': ' + ALink);
end;
function TStoWinHelpTester.IsHlpFile(const FileName: String): Boolean;
var
iPos: Integer;
sFileExt: String;
begin
// file has extension '.hlp' ?
iPos := LastDelimiter('.', FileName);
if (iPos > 0) then
begin
sFileExt := Copy(FileName, iPos, Length(FileName));
Result := CompareText(sFileExt, '.hlp') = 0;
end
else
Result := False;
end;
initialization
StoHelpViewer := TStoHtmlHelpViewer.Create;
RegisterViewer(StoHelpViewer, StoHelpViewer.FHelpManager);
Application.HelpSystem.AssignHelpSelector(StoHelpViewer);
WinHelpTester := TStoWinHelpTester.Create;
finalization
// do not free StoHelpViewer, because the object is referenced by the
// interface and will be freed automatically by releasing the last reference
if Assigned(StoHelpViewer) then
StoHelpViewer.InternalShutdown;
end.
Взято с сайта
unit HtmlHelp;
interface
uses
Windows, Graphics;
const
HH_DISPLAY_TOPIC = $0000;
HH_DISPLAY_TOC = $0001;
HH_DISPLAY_INDEX = $0002;
HH_DISPLAY_SEARCH = $0003;
HH_SET_WIN_TYPE = $0004;
HH_GET_WIN_TYPE = $0005;
HH_GET_WIN_HANDLE = $0006;
HH_GET_INFO_TYPES = $0007;
HH_SET_INFO_TYPES = $0008;
HH_SYNC = $0009;
HH_ADD_NAV_UI = $000A;
HH_ADD_BUTTON = $000B;
HH_GETBROWSER_APP = $000C;
HH_KEYWORD_LOOKUP = $000D;
HH_DISPLAY_TEXT_POPUP = $000E;
HH_HELP_CONTEXT = $000F;
const
HHWIN_PROP_ONTOP = 2;
HHWIN_PROP_NOTITLEBAR = 4;
HHWIN_PROP_NODEF_STYLES = 8;
HHWIN_PROP_NODEF_EXSTYLES = 16;
HHWIN_PROP_TRI_PANE = 32;
HHWIN_PROP_NOTB_TEXT = 64;
HHWIN_PROP_POST_QUIT = 128;
HHWIN_PROP_AUTO_SYNC = 256;
HHWIN_PROP_TRACKING = 512;
HHWIN_PROP_TAB_SEARCH = 1024;
HHWIN_PROP_TAB_HISTORY = 2048;
HHWIN_PROP_TAB_FAVORITES = 4096;
HHWIN_PROP_CHANGE_TITLE = 8192;
HHWIN_PROP_NAV_ONLY_WIN = 16384;
HHWIN_PROP_NO_TOOLBAR = 32768;
const
HHWIN_PARAM_PROPERTIES = 2;
HHWIN_PARAM_STYLES = 4;
HHWIN_PARAM_EXSTYLES = 8;
HHWIN_PARAM_RECT = 16;
HHWIN_PARAM_NAV_WIDTH = 32;
HHWIN_PARAM_SHOWSTATE = 64;
HHWIN_PARAM_INFOTYPES = 128;
HHWIN_PARAM_TB_FLAGS = 256;
HHWIN_PARAM_EXPANSION = 512;
HHWIN_PARAM_TABPOS = 1024;
HHWIN_PARAM_TABORDER = 2048;
HHWIN_PARAM_HISTORY_COUNT = 4096;
HHWIN_PARAM_CUR_TAB = 8192;
const
HHWIN_BUTTON_EXPAND = 2;
HHWIN_BUTTON_BACK = 4;
HHWIN_BUTTON_FORWARD = 8;
HHWIN_BUTTON_STOP = 16;
HHWIN_BUTTON_REFRESH = 32;
HHWIN_BUTTON_HOME = 64;
HHWIN_BUTTON_BROWSE_FWD = 128;
HHWIN_BUTTON_BROWSE_BCK = 256;
HHWIN_BUTTON_NOTES = 512;
HHWIN_BUTTON_CONTENTS = 1024;
HHWIN_BUTTON_SYNC = 2048;
HHWIN_BUTTON_OPTIONS = 4096;
HHWIN_BUTTON_PRINT = 8192;
HHWIN_BUTTON_INDEX = 16384;
HHWIN_BUTTON_SEARCH = 32768;
HHWIN_BUTTON_HISTORY = 65536;
HHWIN_BUTTON_FAVORITES = 131072;
HHWIN_BUTTON_JUMP1 = 262144;
HHWIN_BUTTON_JUMP2 = 524288;
HHWIN_BUTTON_ZOOM = HHWIN_Button_Jump2 * 2;
HHWIN_BUTTON_TOC_NEXT = HHWIN_Button_Zoom * 2;
HHWIN_BUTTON_TOC_PREV = HHWIN_Button_Toc_Next * 2;
const
HHWIN_DEF_Buttons = HHWIN_Button_Expand or HHWIN_Button_Back or
HHWIN_Button_Options or HHWIN_Button_Print;
const
IDTB_EXPAND = 200;
IDTB_CONTRACT = 201;
IDTB_STOP = 202;
IDTB_REFRESH = 203;
IDTB_BACK = 204;
IDTB_HOME = 205;
IDTB_SYNC = 206;
IDTB_PRINT = 207;
IDTB_OPTIONS = 208;
IDTB_FORWARD = 209;
IDTB_NOTES = 210;
IDTB_BROWSE_FWD = 211;
IDTB_BROWSE_BACK = 212;
IDTB_CONTENTS = 213;
IDTB_INDEX = 214;
IDTB_SEARCH = 215;
IDTB_HISTORY = 216;
IDTB_FAVORITES = 217;
IDTB_JUMP1 = 218;
IDTB_JUMP2 = 219;
IDTB_CUSTOMIZE = 221;
IDTB_ZOOM = 222;
IDTB_TOC_NEXT = 223;
IDTB_TOC_PREV = 224;
const
HHN_First = Cardinal(-860);
HHN_Last = Cardinal(-879);
HHN_NavComplete = HHN_First - 0;
HHN_Track = HHN_First - 1;
type
HHN_Notify = record
hdr: Pointer;
pszUrl: PWideChar;
end;
HH_Popup = record
cbStruct: Integer;
hinst: THandle;
idString: Cardinal;
pszText: PChar;
pt: TPoint;
clrForeground: TColor;
clrBackground: TColor;
rcMargins: TRect;
pszFont: PChar;
end;
HH_AKLINK = record
cbStruct: Integer;
fReserved: bool;
pszKeywords: PChar;
pszUrl: PChar;
pszMsgText: PChar;
pszMsgTitle: PChar;
pszWindow: PChar;
fIndexOnFail: bool;
end;
type
HHWin_NavTypes = (HHWIN_NAVTYPE_TOC,
HHWIN_NAVTYPE_INDEX,
HHWIN_NAVTYPE_SEARCH,
HHWIN_NAVTYPE_HISTORY,
HHWIN_NAVTYPE_FAVOURITES);
type
HH_InfoType = Longint;
PHH_InfoType = ^ HH_InfoType;
type
HHWin_NavTabs = (HHWIN_NavTab_Top,
HHWIN_NavTab_Left,
HHWIN_NavTab_Bottom);
const
HH_Max_Tabs = 19;
type
HH_Tabs = (HH_TAB_CONTENTS,
HH_TAB_INDEX,
HH_TAB_SEARCH,
HH_TAB_HISTORY,
HH_TAB_FAVORITES
);
const
HH_FTS_DEFAULT_PROXIMITY = (-1);
type
HH_FTS_Query = record
cbStruct: Integer;
fUniCodeStrings: bool;
pszSearchQuery: PChar;
iProximity: Longint;
fStemmedSearch: bool;
fTitleOnly: bool;
fExecute: bool;
pszWindow: PChar;
end;
type
HH_WinType = record
cbStruct: Integer;
fUniCodeStrings: bool;
pszType: PChar;
fsValidMembers: Longint;
fsWinProperties: Longint;
pszCaption: PChar;
dwStyles: Longint;
dwExStyles: Longint;
rcWindowPos: TRect;
nShowState: Integer;
hwndHelp: THandle;
hwndCaller: THandle;
paInfoTypes: ^ HH_InfoType;
hwndToolbar: THandle;
hwndNavigation: THandle;
hwndHTML: THandle;
iNavWidth: Integer;
rcHTML: TRect;
pszToc: PChar;
pszIndex: PChar;
pszFile: PChar;
pszHome: PChar;
fsToolbarFlags: Longint;
fNotExpanded: bool;
curNavType: Integer;
tabPos: Integer;
idNotify: Integer;
TabOrder: array[0..HH_Max_Tabs + 1] of Byte;
cHistory: Integer;
pszJump1: PChar;
pszJump2: PChar;
pszUrlJump1: PChar;
pszUrlJump2: PChar;
rcMinSize: TRect;
end;
PHH_WinType = ^ HH_WinType;
type
HHACTTYpes = (HHACT_TAB_CONTENTS,
HHACT_TAB_INDEX,
HHACT_TAB_SEARCH,
HHACT_TAB_HISTORY,
HHACT_TAB_FAVORITES,
HHACT_EXPAND,
HHACT_CONTRACT,
HHACT_BACK,
HHACT_FORWARD,
HHACT_STOP,
HHACT_REFRESH,
HHACT_HOME,
HHACT_SYNC,
HHACT_OPTIONS,
HHACT_PRINT,
HHACT_HIGHLIGHT,
HHACT_CUSTOMIZE,
HHACT_JUMP1,
HHACT_JUMP2,
HHACT_ZOOM,
HHACT_TOC_NEXT,
HHACT_TOC_PREV,
HHACT_NOTES,
HHACT_LAST_ENUM
);
type
HHNTRACK = record
hdr: TNMHDR;
pszCurUrl: PWideChar;
idAction: Integer;
phhWinType: ^ HH_WinType;
end;
PHHNTRACK = ^ HHNTRACK;
HHNNAVCOMPLETE = record
hdr: TNMHDR;
pszUrl: PChar;
end;
PHHNNAVCOMPLETE = ^ HHNNAVCOMPLETE;
type
THtmlHelpA = function(hwndCaller: THandle; pszFile: PChar;
uCommand: Cardinal; dwData: Longint): THandle;
stdCall;
THtmlHelpW = function(hwndCaller: THandle; pszFile: PChar;
uCommand: Cardinal; dwData: Longint): THandle;
stdCall;
function HH(hwndCaller: THandle; pszFile: PChar; uCommand: Cardinal;
dwData: Longint): THandle;
function HtmlHelpInstalled: Boolean;
implementation
const
ATOM_HTMLHELP_API_ANSI = #14#0;
ATOM_HTMLHELP_API_UNICODE = #15#0;
var
HtmlHelpA: THtmlHelpA;
OCXHandle: THandle;
function HH;
begin
Result := 0;
if (Assigned(HtmlHelpA)) then
begin
Result := HtmlHelpA(hwndCaller, pszFile, uCommand, dwData);
end;
end;
function HtmlHelpInstalled: Boolean;
begin
Result := (Assigned(HtmlHelpA));
end;
initialization
begin
HtmlHelpA := nil;
OCXHandle := LoadLibrary('HHCtrl.OCX');
if (OCXHandle <> 0) then
begin
HtmlHelpA := GetProcAddress(OCXHandle, 'HtmlHelpA');
end;
end;
finalization
begin
if (OCXHandle <> 0) then
FreeLibrary(OCXHandle);
end;
end.
//-----------------------------------------------
unit Unit1;
{....}
implementation
uses
HtmlHelp;
const
HH_HELP_CONTEXT = $F;
MYHELP_FILE = 'DualHelp.chm' + Chr(0);
var
RetCode: LongInt;
{$R *.DFM}
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = vk_f1 then
begin
if HtmlHelpInstalled = True then
begin
RetCode := HH(Form1.Handle, PChar(MYHELP_FILE), HH_HELP_CONTEXT,
ActiveControl.HelpContext);
Key := 0; //eat it!
end
else
helpfile := 'hhtest.hlp';
end;
end;
Взято с сайта
Как использовать файлы справки?
Как использовать файлы справки?
{First we need to tell the Application object the name
of the Help file and where to locate it. }
Application.HelpFile := ExtractFilePath(Application.ExeName) + 'YourHelpFile.hlp';
{ To Show a help file's content tab: }
Application.HelpCommand(HELP_CONTENTS, 0);
{ To display a specific topic of your help file: }
Application.HelpJump('TApplication_HelpJump');
Взято с сайта
Вот код для трех стандартных пунктов меню "Help":
procedure TForm1.Contents1Click(Sender: TObject);
begin
Application.HelpCommand(HELP_CONTENTS, 0);
end;
procedure TForm1.SearchforHelpOn1Click(Sender: TObject);
begin
Application.HelpCommand(HELP_PARTIALKEY, 0);
end;
procedure TForm1.HowtoUseHelp1Click(Sender: TObject);
begin
Application.HelpCommand(HELP_HELPONHELP, 0);
end;
Взято с
Как использовать форму из DLL
Как использовать форму из DLL
libraryForm;
uses
Classes,
Unit1 in 'Unit1.pas' {Form1};
exports
CreateMyForm,
DestroyMyForm;
end.
Это его Unit1:
unit Unit1;
interface
// раздел uses и определение класса Form1
procedure CreateMyForm(AppHandle: THandle); stdcall;
procedure DestroyMyForm; stdcall;
implementation
{$R *.DFM}
procedure CreateMyForm(AppHandle: THandle);
begin
Application.Handle := AppHandle;
Form1 := TForm1.Create(Application);
Form1.Show
end;
procedure DestroyMyForm;
begin
Form1.Free;
end;
end.
Это UnitCall вызывающего EXE-шника:
unit
UnitCall;
interface
// раздел uses и определение класса Form1
procedure CreateMyForm(AppHandle: THandle); stdcall; external 'Form.dll';
procedure DestroyMyForm; stdcall; external 'Form.dll';
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateMyForm(Application.Handle);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DestroyMyForm;
end;
end.
Взято с
Как использовать joystick?
Как использовать joystick?
uses
MMSYSTEM;
var
MyJoy: TJoyInfo;
ErrorResult: MMRESULT;
begin
ErrorResult := joyGetPos(joystickid1, @MyJoy);
if ErrorResult = JOYERR_NOERROR then
begin
TrackBar1.Position := MyJoy.wypos;
TrackBar2.Position := MyJoy.wxpos;
RadioButton1.Checked := (MyJoy.wbuttons and joy_button1) > 0;
RadioButton2.Checked := (MyJoy.wbuttons and joy_button2) > 0;
end
else
case ErrorResult of
MMSYSERR_NODRIVER: ShowMessage('No Joystick driver present');
MMSYSERR_INVALPARAM: ShowMessage('Invalid Joystick Paramameters');
JOYERR_UNPLUGGED: ShowMessage('Joystick is Unplugged');
else
ShowMessage('Unknown error with Joystick');
end;
end;
Взято с сайта
var
myjoy: tjoyinfo;
begin
joygetpos(joystickid1, @myjoy);
trackbar1.position := myjoy.wypos;
trackbar2.position := myjoy.wxpos;
radiobutton1.checked := (myjoy.wbuttons and joy_button1) > 0;
radiobutton2.checked := (myjoy.wbuttons and joy_button2) > 0;
end;
Не забудьте включить MMSYSTEM в список используемых (USES) модулей
Взято из
Советов по Delphi от
Сборник Kuliba
Как использовать клавишу-акселератор в TTabsheets?
Как использовать клавишу-акселератор в TTabsheets?
Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.
Можно перехватить сообщение CM_DIALOGCHAR.
type
TForm1 = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
private
{Private declarations}
procedure CMDialogChar(var Msg: TCMDialogChar);
message CM_DIALOGCHAR;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CMDialogChar(var Msg: TCMDialogChar);
var
i: integer;
begin
with PageControl1 do
begin
if Enabled then
for i := 0 to PageControl1.PageCount - 1 do
if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
(Pages[i].TabVisible)) then
begin
Msg.Result := 1;
ActivePage := Pages[i];
exit;
end;
end;
inherited;
end;
Взято из
DELPHI VCL FAQ
Перевод с английского Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для
Как использовать консоль в не-консольном приложении?
Как использовать консоль в не-консольном приложении?
Для того, чтобы добавить в не-консольное приложение ввод/вывод из консоли, необходимо воспользоваться функциями AllocConsole и FreeConsole.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
AllocConsole;
try
Write('Type here your words and press ENTER: ');
Readln(s);
ShowMessage(Format('You typed: "%s"', [s]));
finally
FreeConsole;
end;
end;
Взято с Исходников.ru
Как использовать mouse_event() для эмулирования событий мышки?
Как использовать mouse_event() для эмулирования событий мышки?
Следующий пример демонстрирует использование API функции mouse_event() для эмуляции событий мышки. Когда Button2 нажата, то мышь перемещается на Button1 и щёлкает по ней. Координаты мыши даны в "Mickeys", где 65535 соответствует ширине экрана.
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Button 1 clicked');
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Pt : TPoint;
begin
{Allow Button2 to repaint it's self}
Application.ProcessMessages;
{Получаем координаты центра button 1}
Pt.x := Button1.Left + (Button1.Width div 2);
Pt.y := Button1.Top + (Button1.Height div 2);
{Преобразуем Pt в координаты экрана}
Pt := ClientToScreen(Pt);
{Преобразуем Pt в mickeys}
Pt.x := Round(Pt.x * (65535 / Screen.Width));
Pt.y := Round(Pt.y * (65535 / Screen.Height));
{Перемещаем мышку}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_MOVE,
Pt.x,
Pt.y,
0,
0);
{Эмулируем нажатие левой кнопки мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTDOWN,
Pt.x,
Pt.y,
0,
0);;
{Эмулируем отпускание левой кнопки мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTUP,
Pt.x,
Pt.y,
0,
0);;
end;
Взято с Исходников.ru
Как использовать не установленный шрифт?
Как использовать не установленный шрифт?
Зарегистрировать шрифт:
AddFontResource('путь к фонту\\Algerian.ttf');
Объект.Font.Name:="Algerian";
Удалить -
RemoveFontResource('путь к фонту\\Algerian.ttf');
Автор Alex101
Взято с Vingrad.ru
Как использовать параметры командной строки?
Как использовать параметры командной строки?
Paramcount - показывает сколько параметров передано
Paramstr(0) - это имя с путем твоей программы
Paramstr(1) - имя первого параметра
Paramstr(2) - имя второго параметра и т.д.
Если ты запускаешь:
с:\myprog.exe /a -b22 c:\dev
то Paramcount будет равен 3
Paramstr(0) будет равен с:\myprog.exe
Paramstr(1) будет равен /a
Paramstr(2) будет равен -b22
Paramstr(3) будет равен c:\dev
Параметр это просто строка, набор букв, выполнить ее нельзя - ты можешь только проверить на наличие строки и если она присутствует, то выполнить какое либо действие, это действие ты должен написать сам, никаких стандартных действий нет.
Например у тебя возможно 3 параметра:
Если параметр = "/v" то выдать сообщение, если параметр "/c" то покрасить форму в синий цвет, если параметр "/f" - поменять заголовок формы:
if paramstr(1) = '/v' then
showmessage('Parameter "/v" was found!');
if paramstr(1) = '/c' then
color := clBlue;
if paramstr(1) = '/f' then
caption := 'Parameter "/f" was found';
Поставь этот код на событие формы onActivate, откомпиллируй и попробуй запустить программу с одним из 3х указанных параметров и ты увидишь что произойдет.
Автор ответа: Vit
Взято с Vingrad.ru
Как использовать переменную для имени процедуры?
Как использовать переменную для имени процедуры?
Взято из FAQ:
Каким образом можно использовать переменную типа String в качестве имени процедуры?
Если все процедуры, которые вы собираетесь вызывать, имеют список с
одними и теми же параметрами (или все без параметров), то это не трудно.
Для этого необходимы: процедурный тип, соответствующий вашей процедуре, например:
type
TMacroProc = procedure(param: Integer);
//массив, сопоставляющий имена процедур их адресам во время выполнения приложения:
TMacroName = string[32];
TMacroLink = record
name: TMacroName;
proc: TMacroProc;
end;
TMacroList = array [1..MaxMacroIndex] of TMacroLink;
const
Macros: TMacroList = (
(name: 'Proc1'; proc: Proc1),
(name: 'Proc2'; proc: Proc2),
...
); //интерпретатор функций, типа:
procedure CallMacro(name: String; param: Integer);
var
i: Integer;
begin
for i := 1 to MaxMacroIndex do
if CompareText(name, Macros[i].name) = 0 then
begin
Macros[i].proc(param);
break;
end;
end;
{Макропроцедуры необходимо объявить в секции Interface модуля или с ключевым словом Far, например: }
procedure Proc1(n: Integer); far;
begin
...
end;
procedure Proc2(n: Integer); far;
begin
...
end;
Взято с Vingrad.ru
Как использовать протокол about?
Как использовать протокол about?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
procedure TForm1.LoadHTMLString(sHTML: String);
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WebBrowser1.Navigate('about:' + sHTML, Flags, TargetFrameName, PostData, Headers)
end;
Как использовать протокол res?
Как использовать протокол res?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
Протокол " res:" позволяет просмотреть HTML файл, сохранённый как ресурс.
Более подробная информация доступна на Microsoft site:
procedure TForm1.LoadHTMLResource;
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WebBrowser1.Navigate('res://' + Application.ExeName + '/myhtml',
Flags, TargetFrameName, PostData, Headers)
end;
Создайте файл ресурса (*.rc) со следующими строками и откомпилируйте
его при помощи brcc32.exe: MYHTML 23 " .\html\myhtml.htm" MOREHTML 23 " .\html\morehtml.htm" Отредактируйте файл проекта, чтобы он выглядел примерно так: {$R *.RES}
{$R HTML.RES} //где html.rc будет скомпилирован в html.res
Как использовать проверку грамматики?
Как использовать проверку грамматики?
{
If you are using Delphi 2+ and have the ActiveX component TVSSpell, it is very
simple to add a spell checker to your TMemo applications.
(Note: Do not use this component with a Rich Edit application because of text
formatting problems.)
}
procedure TForm1.Button1Click(Sender: TObject);
begin
if Memo1.Text = '' then Exit;
VSSpell1.CheckText := Memo1.Text;
if VSSpell1.ResultCode = 0 then
Memo1.Text := VSSpell1.Text;
end;
{
To distribute a VisualSpeller application you have to include the following
files:
}
{
- VsSpell.HLP
- VSPELL32.OCX
- VSPELL32.DLL
- AMERICAN.VTD
- VSPELL.HLP
}
Взято с сайта
Как использовать ресурсы?
Как использовать ресурсы?
{
To create resource files (*.res) for Kylix you can use the Delphi
brcc32.exe resource compiler.
Take a look at ;http://www.swissdelphicenter.ch/en/showcode.php?id=1049
Kylix dont support userdefined resourcetypes. Therefore you have to define
all resources without a predefined ResType as RCDATA.
Example with TResourceStream
Saves the resource (in userdefined.res) with the name MYRES1 to the file
test.txt
}
uses
SysUtils, Types, Classes, Variants, QGraphics, QControls, QForms, QDialogs,
QStdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.xfm}
{$R userdefined.res}
procedure TForm1.Button1Click(Sender: TObject);
var
stream: TResourceStream;
begin
stream := TResourceStream.Create(HInstance, 'MYRES1', RT_RCDATA);
with TFileStream.Create('test.txt', fmCreate) do begin
CopyFrom(stream, stream.Size);
Free;
end;
end;
Взято с сайта
Как использовать Shell API SHBrowseForFolder?
Как использовать Shell API SHBrowseForFolder?
Статья из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи...".
Как использовать функцию Shell API SHBrowseForFolder чтобы позволить пользователю выбрать каталог?
uses ShellAPI, ShlObj;
procedure TForm1.Button1Click(Sender: TObject);
var
TitleName : string;
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := Form1.Handle;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := 'Please specify a directory';
BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId <> nil then begin
SHGetPathFromIDList(lpItemID, TempPath);
ShowMessage(TempPath);
GlobalFreePtr(lpItemID);
end;
end;
Источник: Дельфи. Вокруг да около.
Вариант от Анатолия (SAVwa@eleks.lviv.ua)
threadvar myDir: string;
function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData:
LPARAM): integer; stdcall;
begin
Result := 0;
if uMsg = BFFM_INITIALIZED then begin
SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PChar(myDir)))
end;
end;
function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string): Boolean;
var
WindowList: Pointer;
BrowseInf!
o: TBrowseInfo;
Buffer: PChar;
RootItemIDList, ItemIDList: PItemIDList;
ShellMalloc: IMalloc;
IDesktopFolder: IShellFolder;
Eaten, Flags: LongWord;
begin
myDir := Directory;
Result := False;
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
begin
Buffer := ShellMalloc.Alloc(MAX_PATH);
try
RootItemIDList := nil;
if Root <> '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(Application.Handle, nil,
POleStr(Root), Eaten, RootItemIDList, Flags);
end;
with BrowseInfo do
begin
hwndOwner := Application.Handle;
pidlRoot := RootItemIDList;
pszDisplayName := Buffer;
lpfn := @BrowseCallbackProc;
lParam := Integer(PChar(Directory));
lpszTitle := PChar(Caption);
ulFlags := BIF_RETURNONLYFSDIRS or $0040 or BIF_EDITBOX or
BIF_STATUSTEXT;
end;
WindowList := DisableTaskWindows(0);
try
ItemIDList := ShBrowseForFolder(BrowseInfo);
finally
EnableTaskWindows(WindowList);
end;
Result := ItemIDList <> nil;
if Result then
begin
ShGetPathFromIDList(ItemIDList!
, Buffer);
ShellMalloc.Free(ItemIDList);
Directory := Buffer;
end;
finally
ShellMalloc.Free(Buffer);
end;
end;
end;
Взято с Vingrad.ru
Как использовать свои курсоры?
Как использовать свои курсоры?
{$R CURSORS.RES}
const
crZoomIn = 1;
crZoomOut = 2;
Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN');
Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT');
С вашей программой должен быть слинкован файл ресурсов, содержащий соответствующие курсоры или заменить зеленое на конкретное имя файла(он должен также поставляться с программой).
Взято с сайта
Как использовать свой диалог ввода пароля BDE?
Как использовать свой диалог ввода пароля BDE?
//.....
// .....
public
{ Public declarations }
procedure Password(Sender: TObject; var Continue: Boolean);
// ...
end;
var
FormMain: TFormMain;
implementation
{$R *.dfm}
procedure TFormMain.Password(Sender: TObject; var Continue: Boolean);
var
Passwd: String[15];
begin
Passwd := '';
FormPasswd := TFormPasswd.Create(Application); // Creating dialog
try
if (FormPasswd.ShowModal = ID_OK) then begin // If OK is pressed then get password from edit "edPassword"
Passwd := FormPasswd.edPasswd.Text
end
else begin // If Cancel is pressed then terminate application
Application.ShowMainForm := False;
Application.Terminate;
Exit;
end;
finally
FormPasswd.Free; // finally free password form
end;
Continue := (Passwd > '');
Session.AddPassword(Passwd); // Add password typed to session
end;
procedure TFormMain.FormCreate(Sender: TObject);
begin
ClientDatabase.Session.RemoveAllPasswords; // Remove all typed passwords from session, so user need type password again in app start
// Undocument next row in debug mode. This is for debugging and testing only, so we don't need typing password again and again ...
// ClientDatabase.Session.AddPassword('YOUR-PASSWORD');
ClientDatabase.Session.OnPassword := Password; // Set OnPassword Event
end;
Взято из
Как использовать TImageList для рисования прозрачных картинок
Как использовать TImageList для рисования прозрачных картинок
Следующий пример демонстрирует, динамическое создание компонента TImageList, используемого для рисования прозрачного битмапа.
procedure TForm1.Button1Click(Sender: TObject);
var
bm : TBitmap;
il : TImageList;
begin
bm := TBitmap.Create;
bm.LoadFromFile('C:\DownLoad\TEST.BMP');
il := TImageList.CreateSize(bm.Width,
bm.Height);
il.DrawingStyle := dsTransparent;
il.Masked := true;
il.AddMasked(bm, clRed);
il.Draw(Form1.Canvas, 0, 0, 0);
bm.Free;
il.Free;
end;
Взято с Исходников.ru
Как использовать в своей программе API DirectSound и DirectSound3D
Как использовать в своей программе API DirectSound и DirectSound3D
Представляю вашему вниманию рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WAV'файл в секундах (округление в сторону увеличения). При нажатии на кнопку происходит микширование из вторичных буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок, читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер данных, так как в некоторых WAV файлах существует текстовый довесок, и если его не убрать, в динамиках возможен треск).
Пример 1-ый
unitUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
DirectSound : IDirectSound;
DirectSoundBuffer : IDirectSoundBuffer;
SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer; Bits: Word; isStereo:Boolean; Time: Integer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData; SoundBytes: DWord);
procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050,8,False,10);
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050,16,True,1);
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then
DirectSoundBuffer.Release;
for i:=0 to 1 do
if Assigned(SecondarySoundBuffer[i]) then
SecondarySoundBuffer[i].Release;
if Assigned(DirectSound) then
DirectSound.Release;
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1, AudioPtr2 : Pointer;
AudioBytes1, AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
end
else
if H <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
Temp := @SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp := @SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK then
raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
raise Exception.Create('Unable to set Coopeative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
raise Exception.Create('Unable to set Coopeative Level');
end;
procedure TForm1.AppCreateWriteSecondaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then
PCM.nChannels:=2
else
PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.CopyWAVToBuffer;
var
Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : string[4];
Pos : Integer;
begin
FName:=TFileStream.Create(name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.read(Chunk[1],4);
Inc(Pos);
until
Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);
if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK then
ShowMessage('Can not play the Sound');
if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK then
ShowMessage('Can not play the Sound');
end;
end.
Пример 2-ой
Представляю вашему вниманию очередной пример работы с DirectSound на Delphi. В этом примере показан принцип работы с 3D буфером. Итак, процедуры AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил без изменения (см. письма с до этого). Процедура AppCreateWriteSecondary3DBuffer является полным аналогом процедуры AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который указывает на то, что со статическим вторичным буфером будет связан еще один буфер - SecondarySound3DBuffer. Чтобы его инициализировать, а также установить некоторые начальные значения (положение в пространстве, скорость и .т.д.) вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer. В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается положение источника звука в пространстве: SetPosition(Pos,1,1,0). X,Y,Z Таким образом в начальный момент времени источник находится на высоте 1 м (ось Y направлена вертикально вверх, а ось Z - "в экран"). Если смотреть сверху :
^ Z
|
|
|
O----------------> X
Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1). Разумеется понятие "метр" весьма условно. При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук 'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно 3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно повторяющийся звук; время в 0.01 с ухом практически не улавливается и получается непрерывный звук летящего вертолета. После этого запускется таймер (поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется вам совсем необязательно делать именно так, это просто пример. В процедуре Timer1Timer просто меняется координата X с шагом 0.1. В итоге получаем летящий вертолет слева направо. Заодно можете проверить, правильно ли у вас расположены колонки.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
DirectSound : IDirectSound;
DirectSoundBuffer : IDirectSoundBuffer;
SecondarySoundBuffer : IDirectSoundBuffer;
SecondarySound3DBuffer : IDirectSound3DBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer;
Bits: Word;
isStereo:Boolean;
Time: Integer);
procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
var _3DBuffer: IDirectSound3DBuffer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData;
SoundBytes: DWord);
procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
Result: HResult;
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer, 22050,8,False,4);
AppSetSecondary3DBuffer(SecondarySoundBuffer, SecondarySound3DBuffer);
Timer1.Enabled:=False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then
DirectSoundBuffer.Release;
if Assigned(SecondarySound3DBuffer) then
SecondarySound3DBuffer.Release;
if Assigned(SecondarySoundBuffer) then
SecondarySoundBuffer.Release;
if Assigned(DirectSound) then
DirectSound.Release;
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
raise Exception.Create('Unable to set Cooperative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
raise Exception.Create('Unable to set Cooperative Level');
end;
procedure TForm1.AppCreateWriteSecondary3DBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then
PCM.nChannels:=2
else
PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1, AudioPtr2 : Pointer;
AudioBytes1, AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
end
else
if H <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then
raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.CopyWAVToBuffer;
var
Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : string[4];
Pos : Integer;
begin
FName:=TFileStream.Create(name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.read(Chunk[1],4);
Inc(Pos);
until
Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;
var
Pos: Single = -25;
procedure TForm1.AppSetSecondary3DBuffer;
begin
if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then
raise Exception.Create('Failed to create IDirectSound3D object');
if _3DBuffer.SetPosition(Pos,1,1,0) <> DS_OK then
raise Exception.Create('Failed to set IDirectSound3D Position');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);
if SecondarySoundBuffer.Play(0,0,DSBPLAY_LOOPING) <> DS_OK then
ShowMessage('Can not play the Sound');
Timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
SecondarySound3DBuffer.SetPosition(Pos,1,1,0);
Pos:=Pos + 0.1;
end;
end.
Взято с
Как использовать верхние и нижние индексы?
Как использовать верхние и нижние индексы?
RichEdit поддерживает верхние/нижние индексы;
Вот как это делается:
usesRichEdit;
procedure TForm1.Button1Click(Sender: TObject);
var
CF: TCharFormat;
begin
cf.cbSize := sizeof(cf);
cf.dwMask := CFM_OFFSET;
cf.yOffset := 70; // смещение по y; положительное/отрицательное для смещение верх/вниз
RichEdit1.Perform(EM_SETCHARFORMAT, SCF_SELECTION, integer(@cf));
end;
SCF_ALL применить ко всему тексту
SCF_SELECTION применить к веделенному тексту
SCF_WORD | SCF_SELECTION применить к выделенным словам
Взято из MSDN. Проверено на Delphi7. Это работает. Попробый сделать сам, чтобы верхние/нижние индексы имели меньший размер.
Тем более это работает в rxRichEdit.
Автор:
SetiВзято из
Как использовать встроенные в Windows иконки в своём приложении?
Как использовать встроенные в Windows иконки в своём приложении?
Сперва необходимо узнать, константы, которые соответствуют определённым иконкам. Все они определены в API unit (windows.pas) в Delphi:
IDI_HAND
IDI_EXCLAMATION
or
IDI_QUESTION
Следующий пример рисует иконку вопроса на панели:
var
DC: HDC;
Icon: HICON;
begin
DC := GetWindowDC(Panel1.Handle);
Icon := LoadIcon(0, IDI_QUESTION);
DrawIcon(DC, 5, 5, Icon);
ReleaseDC(Panel1.Handle, DC);
end;
Взято с Исходников.ru
Как использовать WinAPI?
Как использовать WinAPI?
WinAPI - это те функции которыми управляется работа приложений в Windows. Они являются частью системы, и подгружаются вместе с виндос в библиотеке kernel32.dll.
В Делфи эти функции приемущественно описанны в библиотеке Windows, которая автоматически включается в ваш новый проект. Вы можете открыть эту библиотеку и посмотреть сами. Большая часть VCL - это надстройка над WinAPI.
Для каждого запущенного приложения создается процесс и в этом процессе основной поток (приложение может создавать свои дополнитльные потоки - все они будут принадлежать его процессу), а уж потоки создают окна. Каждый поток имеет уникальный числовой индификатор называемый ThreadID. Это просто целое число которое дается (ассоциируется) этому потоку. Точно так же имеет свой уникальный индификатор каждое окно в системе, называемый Handle. Он обозначается обычно типом HWND, но это просто целое. 4-х байтное.
В виндосе взаимодействие построено на сообщениях. Сообщени - это небольшой набор данных (record, условно говоря), который содержит:
Handle - Handle окна, которому сообщение предназначается.
Message - целое число, которое указывает, что же это за сообщение. Для системных сообщений определены константы типа WM_KEYPRESSED, WM_MOUSEMOVE и т. д. Их значение(числовое) совершенно никого не интересует однако его легко узнать: ShowMessage('WM_MOUSEMOVE: '+IntToStr(WM_MOUSEMOVE));
wParam - целое, значение зависит от сообщения
lParaw - целое, значение зависит от сообщения.
Для каждого потока отводиться специальное место в памяти, куда складываются сообщение по мере из поступления - называется это очередью сообщений. Сами окна сообщения не получают - все они складываются в очередь потока. Чтобы достать следующее сообщение, используется функция GetMessage(PeekMessage). Если вы хотите доставить сообщение окну, то проще всего это сделать вызвав DispatchMessage передав в качестве параметра полученное сообшение. Эта функция находит нужное окно в вашем потоке, и вызывает WindowsProc - процедура окна, которое должна обработать это сообщение. Адрес этой процедуры (для каждого окна свой) известен системе - он передается ей во время регистрации окна.
Пракически каждое приложение осуществляет цикл обработки сообщений. То есть цикл, который вызывает GetMessage и обрабатывает сообщение (рассылает окнам), пока не попадется сообщение WM_QUIT, после чего приложение должно завершить работу. В Delphi этот цикл представлен в методе Application.Run
Автор: Fantasist
Взято с Vingrad.ru
Как из HBitmap получить адрес Bitmap в памяти?
Как из HBitmap получить адрес Bitmap в памяти?
Вот кусок одного моего класса, в котором есть две интересные вещицы -
проецирование файлов в память и работа с битмэпом в памяти через указатель.
Сразу оговорюсь, что все это работает только Delphi 2 и Win95/NT.
type
TarrRGBTriple=array[byte] of TRGBTriple;
ParrRGBTriple=^TarrRGBTriple;
{организует битмэп размером SX,SY;true_color}
procedure TMBitmap.Allocate(SX,SY:integer);
var DC:HDC;
begin
if BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был}
BM:=0; PB:=nil;
fillchar(BI,sizeof(BI),0);
with BI.bmiHeader do {заполняем структуру с параметрами битмэпа}
begin
biSize:=sizeof(BI.bmiHeader);
biWidth:=SX; biHeight:=SY;
biPlanes:=1; biBitCount:=24;
biCompression:=BI_RGB;
biSizeImage:=0;
biXPelsPerMeter:=0; biYPelsPerMeter:=0;
biClrUsed:=0; biClrImportant:=0;
FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}
if (biWidth or biHeight)<>0 then
begin
DC:=CreateDC('DISPLAY',nil,nil,nil);
{замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу
разместить выделяемый битмэп в спроецированном файле, что позволяет
ускорять работу и экономить память при генерировании большого битмэпа}
{!} BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0);
DeleteDC(DC); {в PB получаем указатель на битмэп-----^^}
if BM=0 then Error('error creating DIB');
end;
end;
end;
{эта процедура загружает из файла true-color'ный битмэп}
procedure TMBitmap.LoadFromFile(const FileName:string);
var HF:integer; {file handle}
HM:THandle; {file-mapping handle}
PF:pchar; {pointer to file view in memory}
i,j:integer;
Ofs:integer;
begin
{открываем файл}
HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite);
if HF<0 then Error('open file '''+FileName+'''');
try
{создаем объект-проецируемый файл}
HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil);
if HM=0 then Error('can''t create file mapping');
try
{собственно проецируем объект в адресное }
PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0);
{получаем указатель на область памяти, в которую спроецирован файл}
if PF=nil then Error('can''t create map view of file');
try
{работаем с файлом как с областью памяти через указатель PF}
if PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format');
Ofs:=PBitmapFileHeader(PF)^.bfOffBits;
with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do
begin
if (biSize<>40) or (biPlanes<>1) then Error('file format');
if (biCompression<>BI_RGB) or
(biBitCount<>24) then Error('only true-color BMP supported');
{выделяем память под битмэп}
Allocate(biWidth,biHeight);
end;
for j:=0 to BI.bmiHeader.biHeight-1 do
for i:=0 to BI.bmiHeader.biWidth-1 do
{Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}
Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i];
finally
UnmapViewOfFile(PF);
end;
finally
CloseHandle(HM);
end;
finally
FileClose(HF);
end;
end;
{эта функция - реализация Pixels read}
function TMBitmap.GetPixel(X,Y:integer):PRGB;
begin
if (X>=0) and (Xand
(Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3)
else Result:=PRGB(PB);
end;
Как из RXRichEdit сохранить в RTF формате?
Как из RXRichEdit сохранить в RTF формате?
procedure TForm1.Button1Click(Sender: TObject);
var t:TFileStream;
begin
t:=TFileStream.create('c:\myfilename.txt', fmCreate or fmOpenWrite);
t.Size:=0;
RxRichEdit1.Lines.SaveToStream(t);
t.free;
end;
Автор ответа: Vit
Взято с Vingrad.ru
Как избавиться от ошибки multiple rows in singleton select?
Как избавиться от ошибки multiple rows in singleton select?
Очевидно что данная ошибка происходит в вашем триггере или хранимой процедуре. Обычный SELECT внутри триггера или процедуры должен возвращать одну строку (row), т.к. при двух и более строках IB не знает куда поместить значения полей этих строк. Если ваш SELECT возвращает несколько записей, то нужно пользоваться конструкцией FOR SELECT ... INTO ... DO ... которая производит обработку возвращаемого набора записей в цикле.
Если-же вы уверены, что ваш SELECT должен вернуть только одну запись, а ошибка все-таки возникает, то давайте рассмотрим следующую ситуацию:
существуют таблицы ORDERS (заказы) и CLIENTS (клиенты).
обе эти таблицы имеют поле связи CLIENT_ID INTEGER.
для того чтобы вытащить информацию о клиенте используется запрос:
SELECT CLIENT_ID, CLIENT_NAME
FROM CLIENTS
WHERE CLIENT_ID = ?
где ? - либо значение либо переменная.
Теперь представим себе, что этот запрос должен выполняться в триггере при вставке записи в таблицу ORDERS
CREATE TRIGGER TI_ORDERS FOR ORDERS
ACTIVE AFTER INSERT POSITION 0
AS
DECLARE VARIABLE CID INTEGER;
DECLARE VARIABLE CNAME CHAR(30);
BEGIN
SELECT C.CLIENT_ID, C.CLIENT_NAME
FROM CLIENTS C
WHERE C.CLIENT_ID = CLIENT_ID
INTO :CID, :CNAME;
...
Итак, поскольку в запросе использован псевдоним C (FROM CLIENTS C), то якобы существует гарантия что в предложении WHERE будут сравниваться поле C.CLIENT_ID из таблицы CLIENTS и поле CLIENT_ID из таблицы ORDERS (в триггере доступны имена полей собственной таблицы). На самом деле даже использование псевдонимов не дает гарантии что переменные будут разичаться, и получается что в предложении WHERE сравнивается само с собой поле таблицы CLIENTS.CLIENT_ID, и в запросе возвращается ВСЯ таблица CLIENTS.
Вот почему возникает вышеупомянутое сообщение об ошибке.
Избавиться от него можно несколькими путями:
Использовать разные имена полей для связи между CLIENTS и ORDERS. например OCLIENT_ID и CCLIENT_ID.
Использовать уточнитель new.CLIENT_ID, несмотря на то что в документации указано что для триггеров последействия (AFTER) он не имеет смысла.
SELECT C.CLIENT_ID, C.CLIENT_NAME
FROM CLIENTS C
WHERE C.CLIENT_ID = new.CLIENT_ID
...
Перед запросом поместить CLIENT_ID в локальную переменную, и в запросе использовать сравнение не с полем, а с этой локальной переменной.
CID=CLIENT_ID;
SELECT C.CLIENT_ID, C.CLIENT_NAME
FROM CLIENTS C
WHERE C.CLIENT_ID = :CID
...
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко
Как избежать использования неактуальных указателей
Как избежать использования неактуальных указателей
Я создал простой модуль и разработал несколько простых методов, помогающих избежать использования неактуальных (в оригинале было "stale" - черствый, несвежий) указателей. Я настоятельно рекомендую добавить во все модули, содержащие указатели или объектные переменные секцию инициализации ('initialization') и установить все указатели (объектные переменные это те же реальные указатели) в nil. Что это даст: прежде чем хотя бы один указатель будет использован, он обязательно будет проверен, освобожден и установлен в nil. Затем, после освобождения указателей, просто установите их в nil. Мой модуль содержит функцию Nilify() для установки указателей в nil, а также специальные версии методов Free, Dispose, и FreeMem (названные NilXXX) для проверки значения nil перед освобождением памяти, и установления указателя в nil сразу после того, как он был освобожден. Я также включил специальную версию Assigned(), названную IsNil(), которая вместо переменного (var) параметра получает константу, которую вы можете затем использовать в своих свойствах, и т.п.
Этот модуль, конечно, ничего не делает с VCL, но тем не менее вы можете иметь неактуальные указатели и с VCL... Строгое соблюдение функций модуля сделает вас уверенным в отсутствии ошибок при работе с указателями. Единственное условие использования модуля - в случае любых изменений кода с вашей стороны или наличия каких-либо замечаний или предложений пришлите их пожалуйста мне. Пользуйтесь на здоровье!
unitPointers;
{
Автор: David S. Becker (dsb@plaza.ds.adp.com)
Дата: 1/27/97
Авторские права: Нет
Дистрибутивные права: Свободные, неограниченное использование, в случае любых изменений кода
с вашей стороны или наличия каких-либо замечаний или предложений пришлите их пожалуйста мне.
Данный модуль создавался для помощи в управлении указателями и объектами. Так как
компилятор не инициализирует указатели и объекты в nil и не сбрасывает
их в nil при освобождении, существует вероятность применения неактуального
указателя. По этой причине я рекомендую добавление секции 'initialization'
во все модули и вызове Nilify() для всех указателей/объектов в данном модуле.
Это позволит быть уверенным, что все указатели/объекты стартуют как nil.
Кроме того, вместо стандартных аналогов, вы можете использовать NilFree
(для объектов), NilDispose (для указателей, создаваемых с помощью New),
и NilFreeMem (для указателей, создаваемых с помощью GetMem). Эти процедуры
безопасны при вызове nil-вых указателей/объектов, так как перед выполнением
любых действий они проверяют их на nil. После освобождения распределенной
указателем/объектом памяти они сбрасываются в nil. Строгое соблюдение функций
модуля значительно снижает риск использования неактуального указателя.
(Конечно, вы еще можете получить неактуальные указатели из VCL, т.к.
они, естественно, не используют данные функции.)
}
interface
{ Проверка указателя на nil }
{ ПРИМЕЧАНИЕ: Данная функция отличается от Assigned() тем, что Assigned() }
{ требует переменную, а IsNil() нет. }
function IsNil(const p: Pointer): Boolean;{ Устанавливает указатель в nil }
procedure Nilify(var p);{ Освобождает не-nil объект и устанавливает его в nil }
procedure NilFree(o: TObject);{ Освобождает не-nil указатель, созданный с помощью New и устанавливает его в nil }
procedure NilDispose(var p: Pointer);{ Освобождает не-nil указатель и устанавливает его в nil }
procedure NilFreeMem(var p: Pointer; size: Word);
implementation
function IsNil(const p: Pointer): Boolean;
begin
Result := (p = nil);
end;
procedure Nilify(var p);
begin
Pointer(p) := nil;
end;
procedure NilFree(o: TObject);
begin
if not IsNil(o) then
begin
o.Free;
Nilify(o);
end;
end;
procedure NilDispose(var p: Pointer);
begin
if not IsNil(p) then
begin
Dispose(p);
Nilify(p);
end;
end;
procedure NilFreeMem(var p: Pointer; size: Word);
begin
if not IsNil(p) then
begin
FreeMem(p, size);
Nilify(p);
end;
end;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
Как изменить число фиксированных колонок в TDbGrid?
Как изменить число фиксированных колонок в TDbGrid?
procedure TForm1.Button1Click(Sender: TObject);
begin
TStringGrid(DbGrid1).FixedCols := 2;
end;
Взято с Исходников.ru
Как изменить цвет TButton?
Как изменить цвет TButton?
{
You cannot change the color of a standard TButton,
since the windows button control always paints itself with the
button color defined in the control panel.
But you can derive derive a new component from TButton and handle
the and drawing behaviour there.
}
unit ColorButton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls;
type
TDrawButtonEvent = procedure(Control: TWinControl;
Rect: TRect; State: TOwnerDrawState) of object;
TColorButton = class(TButton)
private
FCanvas: TCanvas;
IsFocused: Boolean;
FOnDrawButton: TDrawButtonEvent;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure SetButtonStyle(ADefault: Boolean); override;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
procedure DrawButton(Rect: TRect; State: UINT);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas: TCanvas read FCanvas;
published
property OnDrawButton: TDrawButtonEvent read FOnDrawButton write FOnDrawButton;
property Color;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TColorButton]);
end;
constructor TColorButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TCanvas.Create;
end;
destructor TColorButton.Destroy;
begin
inherited Destroy;
FCanvas.Free;
end;
procedure TColorButton.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do Style := Style or BS_OWNERDRAW;
end;
procedure TColorButton.SetButtonStyle(ADefault: Boolean);
begin
if ADefault <> IsFocused then
begin
IsFocused := ADefault;
Refresh;
end;
end;
procedure TColorButton.CNMeasureItem(var Message: TWMMeasureItem);
begin
with Message.MeasureItemStruct^ do
begin
itemWidth := Width;
itemHeight := Height;
end;
end;
procedure TColorButton.CNDrawItem(var Message: TWMDrawItem);
var
SaveIndex: Integer;
begin
with Message.DrawItemStruct^ do
begin
SaveIndex := SaveDC(hDC);
FCanvas.Lock;
try
FCanvas.Handle := hDC;
FCanvas.Font := Font;
FCanvas.Brush := Brush;
DrawButton(rcItem, itemState);
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
RestoreDC(hDC, SaveIndex);
end;
end;
Message.Result := 1;
end;
procedure TColorButton.CMEnabledChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TColorButton.CMFontChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TColorButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;
procedure TColorButton.DrawButton(Rect: TRect; State: UINT);
var
Flags, OldMode: Longint;
IsDown, IsDefault, IsDisabled: Boolean;
OldColor: TColor;
OrgRect: TRect;
begin
OrgRect := Rect;
Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
IsDown := State and ODS_SELECTED <> 0;
IsDefault := State and ODS_FOCUS <> 0;
IsDisabled := State and ODS_DISABLED <> 0;
if IsDown then Flags := Flags or DFCS_PUSHED;
if IsDisabled then Flags := Flags or DFCS_INACTIVE;
if IsFocused or IsDefault then
begin
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Style := bsClear;
FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
InflateRect(Rect, - 1, - 1);
end;
if IsDown then
begin
FCanvas.Pen.Color := clBtnShadow;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Color := clBtnFace;
FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
InflateRect(Rect, - 1, - 1);
end
else
DrawFrameControl(FCanvas.Handle, Rect, DFC_BUTTON, Flags);
if IsDown then OffsetRect(Rect, 1, 1);
OldColor := FCanvas.Brush.Color;
FCanvas.Brush.Color := Color;
FCanvas.FillRect(Rect);
FCanvas.Brush.Color := OldColor;
OldMode := SetBkMode(FCanvas.Handle, TRANSPARENT);
FCanvas.Font.Color := clBtnText;
if IsDisabled then
DrawState(FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(Caption), 0,
((Rect.Right - Rect.Left) - FCanvas.TextWidth(Caption)) div 2,
((Rect.Bottom - Rect.Top) - FCanvas.TextHeight(Caption)) div 2,
0, 0, DST_TEXT or DSS_DISABLED)
else
DrawText(FCanvas.Handle, PChar(Caption), - 1, Rect,
DT_SINGLELINE or DT_CENTER or DT_VCENTER);
SetBkMode(FCanvas.Handle, OldMode);
if Assigned(FOnDrawButton) then
FOnDrawButton(Self, Rect, TOwnerDrawState(LongRec(State).Lo));
if IsFocused and IsDefault then
begin
Rect := OrgRect;
InflateRect(Rect, - 4, - 4);
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Brush.Color := clBtnFace;
DrawFocusRect(FCanvas.Handle, Rect);
end;
end;
end.
В книгах Калверта, Свана и других авторов можно найти похожий текст. Смысл текста ? "Изменить цвет кнопок Button, BitBtn нельзя, т.к. их рисует WINDOWS". Если нельзя, но ОЧЕНЬ НУЖНО, то можно.
Небольшой компонент ColorBtn, дает возможность использовать в кнопках цвет. Кроме того, представлено новое свойство - Frame3D, позволяющее получить более реалистичный вид нажатой кнопки. В отличие от API, при изменении значения свойства Frame3D, не требуется переоткрытие компонента.
Примечание. Кнопку по-прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Чаще заглядывайте в VCL - можно найти много интересного. На рисунке представлены ColorButton и ColorBitBtn.
unit colorbtn;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons;
type
TColorBtn = class(TButton)
private
FCanvas: TCanvas;
IsFocused: Boolean;
F3DFrame: boolean;
FButtonColor: TColor;
procedure Set3DFrame(Value: boolean);
procedure SetButtonColor(Value: TColor);
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message
WM_LBUTTONDBLCLK;
procedure DrawButtonText(const Caption: string; TRC: TRect; State:
TButtonState; BiDiFlags: Longint);
procedure CalcuateTextPosition(const Caption: string; var TRC: TRect;
BiDiFlags: Longint);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure SetButtonStyle(ADefault: Boolean); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property ButtonColor: TColor read FButtonColor write SetButtonColor default
clBtnFace;
property Frame3D: boolean read F3DFrame write Set3DFrame default False;
end;
procedure Register;
implementation
{ TColorBtn }
constructor TColorBtn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Height := 21;
FCanvas := TCanvas.Create;
FButtonColor := clBtnFace;
F3DFrame := False;
end;
destructor TColorBtn.Destroy;
begin
FCanvas.Free;
inherited Destroy;
end;
procedure TColorBtn.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := Style or BS_OWNERDRAW;
end;
procedure TColorBtn.Set3DFrame(Value: boolean);
begin
if F3DFrame <> Value then
F3DFrame := Value;
end;
procedure TColorBtn.SetButtonColor(Value: TColor);
begin
if FButtonColor <> Value then
begin
FButtonColor := Value;
Invalidate;
end;
end;
procedure TColorBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;
procedure TColorBtn.SetButtonStyle(ADefault: Boolean);
begin
if IsFocused <> ADefault then
IsFocused := ADefault;
end;
procedure TColorBtn.CNDrawItem(var Message: TWMDrawItem);
var
RC: TRect;
Flags: Longint;
State: TButtonState;
IsDown, IsDefault: Boolean;
DrawItemStruct: TDrawItemStruct;
begin
DrawItemStruct := Message.DrawItemStruct^;
FCanvas.Handle := DrawItemStruct.HDC;
RC := ClientRect;
with DrawItemStruct do
begin
IsDown := ItemState and ODS_SELECTED <> 0;
IsDefault := ItemState and ODS_FOCUS <> 0;
if not Enabled then
State := bsDisabled
else if IsDown then
State := bsDown
else
State := bsUp;
end;
Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if IsDown then
Flags := Flags or DFCS_PUSHED;
if DrawItemStruct.ItemState and ODS_DISABLED <> 0 then
Flags := Flags or DFCS_INACTIVE;
if IsFocused or IsDefault then
begin
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Style := bsClear;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
end;
if IsDown then
begin
FCanvas.Pen.Color := clBtnShadow;
FCanvas.Pen.Width := 1;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
if F3DFrame then
begin
FCanvas.Pen.Color := FButtonColor;
FCanvas.Pen.Width := 1;
DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
end;
end
else
DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
FCanvas.Brush.Color := FButtonColor;
FCanvas.FillRect(RC);
InflateRect(RC, 1, 1);
if IsFocused then
begin
RC := ClientRect;
InflateRect(RC, -1, -1);
end;
FCanvas.Font := Self.Font;
if IsDown then
OffsetRect(RC, 1, 1);
DrawButtonText(Caption, RC, State, 0);
if IsFocused and IsDefault then
begin
RC := ClientRect;
InflateRect(RC, -4, -4);
FCanvas.Pen.Color := clWindowFrame;
Windows.DrawFocusRect(FCanvas.Handle, RC);
end;
FCanvas.Handle := 0;
end;
procedure TColorBtn.CalcuateTextPosition(const Caption: string; var TRC: TRect;
BiDiFlags: Integer);
var
TB: TRect;
TS, TP: TPoint;
begin
with FCanvas do
begin
TB := Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom);
DrawText(Handle, PChar(Caption), Length(Caption), TB, DT_CALCRECT or
BiDiFlags);
TS := Point(TB.Right - TB.Left, TB.Bottom - TB.Top);
TP.X := ((TRC.Right - TRC.Left) - TS.X + 1) div 2;
TP.Y := ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2;
OffsetRect(TB, TP.X + TRC.Left, TP.Y + TRC.Top);
TRC := TB;
end;
end;
procedure TColorBtn.DrawButtonText(const Caption: string; TRC: TRect; State:
TButtonState; BiDiFlags: Integer);
begin
with FCanvas do
begin
CalcuateTextPosition(Caption, TRC, BiDiFlags);
Brush.Style := bsClear;
if State = bsDisabled then
begin
OffsetRect(TRC, 1, 1);
Font.Color := clBtnHighlight;
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
OffsetRect(TRC, -1, -1);
Font.Color := clBtnShadow;
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
end
else
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
end;
end;
procedure Register;
begin
RegisterComponents('Controls', [TColorBtn]);
end;
end.
Небольшое дополнение. Кнопку по прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Хочется повторить слова Калверта ? "Пользуйтесь исходным кодом". Чаще заглядывайте в VCL - можно найти много интересного.
Взято с
Как изменить цвет всех компонентов на форме в Run-time?
Как изменить цвет всех компонентов на форме в Run-time?
I would like to change the font color on all components on a form at runtime (and the components owned by the components etc). I devised a recursive algorithm using RTTI that accepts a TComponent as a parameter. It works to some extent, but I still have to use 'if' statements to cast the object to a particular descendant, resulting in about 30 lines of code to test for all of the components I use. Also, some objects (TColumnTitle), are not descended from TComponent, even though they have a font property.
This may do the trick (with D6 and maybe D5):
uses
TypInfo;
{ ... }
var
i: integer;
aFont: TFont;
begin
for i := 0 to aComponent.ComponentCount - 1 do
begin
aFont := TFont(GetOrdProp(aComponent.Components[i], 'Font'));
if assigned(aFont) then
aFont.Color := clWhite;
end;
end;
With D4:
{ ... }
var
i: integer;
aFont: TFont;
pi: PPropInfo;
begin
for i := 0 to aComponent.ComponentCount - 1 do
begin
pi := GetPropInfo(aComponent.Components[i].ClassInfo, 'Font');
if assigned(pi) then
TFont(GetOrdProp(aComponent.Components[i],pi)).Color := clWhite;
end;
end;
Tip by Charles McNicoll
Взято из
Как изменить фоновый цвет текста?
Как изменить фоновый цвет текста?
Воспользуйтесь API функциями SetBkColor и TextOut.
procedure TForm1.Button1Click(Sender: TObject);
var
OldTextColor : TColorRef;
OldBkColor : TColorRef;
OldBkMode : Integer;
begin
OldTextColor := SetTextColor(Form1.Canvas.Handle, RGB(0, 0, 255));
OldBkColor := SetBkColor(Form1.Canvas.Handle, RGB(255, 0, 0));
OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE);
TextOut(Form1.Canvas.Handle,
100, 100,
'Синий текст на красном фоне',
27);
SetBkMode(Form1.Canvas.Handle, OldBkMode);
SetBkColor(Form1.Canvas.Handle, OldBkColor);
SetTextColor(Form1.Canvas.Handle, OldTextColor);
end;
Взято с Исходников.ru
Как изменить фоновый цвет текста в различных строчках TListBox?
Как изменить фоновый цвет текста в различных строчках TListBox?
После того, как поместите TListBox на форму, необходимо изменить свойство Style в TListBox на lbOwnerDrawFixed. Если не изменить свойство Style, то событие OnDrawItem никогда не вызовется. Теперь поместите следующий код в обработчик события OnDrawItem Вашего TListBox:
procedure TForm1.ListBox1DrawItem
(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
myColor: TColor;
myBrush: TBrush;
begin
myBrush := TBrush.Create;
with (Control as TListBox).Canvas do
begin
if not Odd(Index) then
myColor := clSilver
else
myColor := clYellow;
myBrush.Style := bsSolid;
myBrush.Color := myColor;
Windows.FillRect(handle, Rect, myBrush.Handle);
Brush.Style := bsClear;
TextOut(Rect.Left, Rect.Top,
(Control as TListBox).Items[Index]);
MyBrush.Free;
end;
end;
Взято с Исходников.ru
Как изменить громкость?
Как изменить громкость?
procedure SetVolume(X: Word);
var
iErr : Integer;
i: integer;
a: TAuxCaps;
begin
for i := 0 to auxGetNumDevs do begin
auxGetDevCaps(i,Addr(a),SizeOf(a));
If a.wTechnology = AUXCAPS_CDAUDIO Then break;
end;
// Устанавливаем одинаковую громкость для левого и правого каналов.
// VOLUME := LEFT*$10000 + RIGHT*1
iErr:=auxSetVolume(i,(X*$10001));
if (iErr‹›0) then ShowMessage('No audio devices are available!');
end;
function GetVolume: Word;
var
iErr : Integer;
i: integer;
a: TAuxCaps;
vol: word;
begin
for i := 0 to auxGetNumDevs do begin
auxGetDevCaps(i,Addr(a),SizeOf(a));
If a.wTechnology = AUXCAPS_CDAUDIO Then break;
end;
iErr:=auxGetVolume(i,addr(vol));
GetVolume := vol;
if (iErr‹›0) then ShowMessage('No audio devices are available!');
end;
Взято с Исходников.ru
Как изменить иконку на Tray?
Как изменить иконку на Tray?
После добавления иконки на Tray можно менять саму иконку, ToolTip и сообщение, посылаемое окну. Для этого необходимо заполнить экземпляр структуры NOTIFYICONDATA и вызвать функцию Shell_NotifyIcon() с параметром NIM_MODIFY и указателем на заполненный экземпляр структуры. При изменении иконки необходимо заполнить поля cbSize, hWnd, uID, uFlags и поля, отвечающие за параметры иконки, которые вы хотите менять. При этом uFlags должен содержать комбинацию флагов, описывающую поля, которые необходимо модифицировать.
Взято из FAQ:
Как изменить имя компьютера?
Как изменить имя компьютера?
SetComputerName(PChar(Edit1.text));
Автор Vit
Взято с Vingrad.ru
Как изменить изображение кнопки Пуск?
Как изменить изображение кнопки Пуск?
Автор: Misha Moellner
Пример из серии "Что можно сделать с рабочим столом". В общем, это обычный трюк с кнопкой "Пуск" (Start).
{ объявляем глобальные переменные }
var
Form1: TForm1;
StartButton: hWnd;
OldBitmap: THandle;
NewImage: TPicture;
{ добавляем следующий код в событие формы OnCreate }
procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage := TPicture.create;
NewImage.LoadFromFile('C:\Windows\Circles.BMP');
StartButton := FindWindowEx
(FindWindow(
'Shell_TrayWnd', nil),
0,'Button', nil);
OldBitmap := SendMessage(StartButton,
BM_SetImage, 0,
NewImage.Bitmap.Handle);
end;
{ Событие OnDestroy }
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(StartButton,BM_SetImage,0,OldBitmap);
NewImage.Free;
end;
Взято с Исходников.ru
Как изменить яркость и контраст?
Как изменить яркость и контраст?
You must change the RBG values of the pixels. For 1, 4 and 8 bit bitmaps, you must edit the palette. For 15 - 32 bit bitmaps, you must edit the pixel direct. For larger bitmaps you should precalulate a table and set the RGB values from this table.
Red:= BCTable[Red];
Green := BCTable[Green];
Blue := BCTable[Blue];
You can find the calculation of the table below. The rest is standard source code, look at EFG's Computer Lab for any solution.
I define the brightness and contrast value between 0..255. Other definitions are possible, change BMax, CMax, BNorm and CNorm.
type
TBCTable = array[Byte] of Byte;
const
RGBCount = 256;
RGBMax = 255;
RGBHalf = 128;
RGBMin = 0;
BMax = 128; { Maximal value brightness 100% - 0% = 0% - - 100% }
CMax = 128; { Maximal value contrast 100% - 0% = 0% - - 100% }
BNorm = 128; { Normal value brightness 0% }
CNorm = 128; { Normal value contrast 0% }
procedure CalcBCTable(var ABCTable: TBCTable; ABrightness, AContrast: Integer);
var
i, v: Integer;
BOffset: Integer;
M, D: Integer;
begin
Dec(ABrightness, BNorm);
Dec(AContrast, CNorm);
{ precalculation brightness assistance values }
BOffset := ((ABrightness) * RGBMax div BMax);
{ precalculation contrast assistance values }
if AContrast < CMax then
begin { because Division by 0 on 100% }
if AContrast <= 0 then
begin { decrement contrast }
M := CMax + AContrast;
D := CMax;
end
else
begin { increment contrast }
M := CMax;
D := CMax - AContrast;
end;
end
else
begin
M := 0;
D := 1;
end;
for i := RGBMin to RGBMax do
begin
{ calculate contrast }
if AContrast < CMax then
begin
v := ((i - RGBHalf) * M) div D + RGBHalf;
{ restrict to byte range }
if v < RGBMin then
v := RGBMin
else if v > RGBMax then
v := RGBMax;
end
else
begin { contrast = 100% }
if i < RGBHalf then
v := RGBMin
else
v := RGBMax;
end;
{ calculate brightness }
Inc(v, BOffset);
{ restrict to byte range }
if v < RGBMin then
v := RGBMin
else if v > RGBMax then
v := RGBMax;
ABCTable[i] := v;
end;
end;
Add a fixed value and clip it to the range. I have used a LUT, which is faster for larger bitmaps. The range of Brightness is -255 (-100%) to 255 (+100%). You can use a 32 or 24 Bit calculation depending on the compiler setting ChangeBrightness24Bit.
procedure ChangeBrightness(Bitmap: TBitmap; Brightness: Integer);
var
LUT: array[Byte] of Byte;
v, i: Integer;
{$IFDEF ChangeBrightness24Bit}
w, h, x, y: Integer;
LineSize: LongInt;
pLineStart: PByte;
{$ENDIF}
p: PByte;
begin
{ create LUT }
for i := 0 to 255 do
begin
v := i + Brightness;
if v < 0 then
v := 0
else if v > 255 then
v := 255;
LUT[i] := v;
end;
{$IFDEF ChangeBrightness24Bit}
{ edit bitmap }
w := Bitmap.Width;
h := Bitmap.Height - 1;
Bitmap.PixelFormat := pf24Bit;
pLineStart := PByte(Bitmap.ScanLine[h]);
{ pixel line is aligned to 32 Bit }
LineSize := ((w * 3 + 3) div 4) * 4;
w := w * 3 - 1;
for y := 0 to h do
begin
p := pLineStart;
for x := 0 to w do
begin
p^ := LUT[p^];
Inc(p);
end;
Inc(pLineStart, LineSize);
end;
{$ELSE}
{ edit bitmap }
Bitmap.PixelFormat := pf32Bit;
p := PByte(Bitmap.ScanLine[Bitmap.Height - 1]);
for i := 0 to Bitmap.Width * Bitmap.Height - 1 do
begin
p^ := LUT[p^];
Inc(p);
p^ := LUT[p^];
Inc(p);
p^ := LUT[p^];
Inc(p, 2);
end;
{$ENDIF}
end;
Взято с
Delphi Knowledge BaseКак изменить языковый драйвер в runtime?
Как изменить языковый драйвер в runtime?
procedureSetLanguage(Tbl: TTable; Lang: DbiName);
var
pOptDesc: pFLDDesc;
pOptData: pBYTE;
hDb: hDbiDb;
TblDesc: CRTblDesc;
Dir: string;
begin
pOptDesc := AllocMem(sizeof(FLDDesc));
pOptData := AllocMem(20);
SetLength(Dir, dbiMaxNameLen + 1);
Tbl.Active := True;
Check(DbiGetDirectory(Tbl.DBHandle, False, PChar(Dir)));
SetLength(Dir, StrLen(PChar(Dir)));
try
FillChar(TblDesc, sizeof(CRTblDesc), #0);
Tbl.DisableControls;
Tbl.Close;
Check(DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil,
hDb));
Check(DbiSetDirectory(hDb, PChar(Dir)));
pOptDesc.iOffset := 0;
pOptDesc.iLen := Length(Lang) + 1;
StrPCopy(pOptDesc.szName, 'LANGDRIVER');
StrPCopy(PChar(pOptData), Lang);
TblDesc.iOptParams := 1;
TblDesc.pfldOptParams := pOptDesc;
TblDesc.pOptData := pOptData;
StrPCopy(TblDesc.szTblName, Tbl.TableName);
StrCopy(TblDesc.szTblType, szParadox);
Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
finally
Check(DbiCloseDatabase(hDb));
FreeMem(pOptDesc, sizeof(FLDDesc));
FreeMem(pOptData, 20);
Tbl.EnableControls;
end;
end;
Взято с
Delphi Knowledge BaseКак изменить кодовую страницу шрифта принтера?
Как изменить кодовую страницу шрифта принтера?
procedure TForm1.Button1Click(Sender: TObject);
var
Dosya: TextFile
begin
with Printer do
begin
AssignPrn(Dosya);
Rewrite(Dosya);
Printer.Canvas.Font.Name := 'Courier New';
Printer.Canvas.Font.Style := [fsBold];
Printer.Canvas.Font.Size := 18;
//****for Turkish special characters
Writeln(Dosya, '?ьi??ц?');
//****set Font CharSet to Turkish(162)
Printer.Canvas.Font.Charset := 162;
Writeln(Dosya, '?ьi??ц?');
CloseFile(Dosya);
end;
end;
The following table lists the predefined constants provided for standard character sets:
type
TFontCharset = 0..255;
Constant Value Description
ANSI_CHARSET 0 ANSI characters.
DEFAULT_CHARSET 1 Font is chosen based solely on Name and Size. If the described font is not available on the system, Windows will substitute another font.
SYMBOL_CHARSET 2 Standard symbol set.
MAC_CHARSET 77 Macintosh characters. Not available on NT 3.51.
SHIFTJIS_CHARSET 128 Japanese shift-jis characters.
HANGEUL_CHARSET 129 Korean characters (Wansung).
JOHAB_CHARSET 130 Korean characters (Johab). Not available on NT 3.51
GB2312_CHARSET 134 Simplified Chinese characters (mainland china).
CHINESEBIG5_CHARSET 136 Traditional Chinese characters (taiwanese).
GREEK_CHARSET 161 Greek characters. Not available on NT 3.51.
TURKISH_CHARSET 162 Turkish characters. Not available on NT 3.51
VIETNAMESE_CHARSET 163 Vietnamese characters. Not available on NT 3.51.
HEBREW_CHARSET 177 Hebrew characters. Not available on NT 3.51
ARABIC_CHARSET 178 Arabic characters. Not available on NT 3.51
BALTIC_CHARSET 186 Baltic characters. Not available on NT 3.51.
RUSSIAN_CHARSET 204 Cyrillic characters. Not available on NT 3.51.
THAI_CHARSET 222 Thai characters. Not available on NT 3.51
EASTEUROPE_CHARSET 238 Includes diacritical marks for eastern european countries. Not available on NT 3.51.
OEM_CHARSET 255 Depends on the codepage of the operating system.
Взято с
Delphi Knowledge Base