Как сделать окно системно-модальным?
Как сделать окно системно-модальным?
Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией. В любой момент времени может быть возможен только один модально-системны диалог, чей дескриптор возвращается функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить показ диалога таким образом. Вот как примерно это должно выглядеть:
procedureTForm1.Button1Click(Sender: TObject);
var
x: word ;
begin
x := SetSysModalWindow(AboutBox.handle) ;
AboutBox.showmodal ;
SetSysModalWindow(x) ;
end;
Взято с
Как сделать откат внутри триггера
Как сделать откат внутри триггера
Внутри триггера нельзя управлять транзакциями, поэтому генерируешь там исключение а откат транзакции делаешь в приложении, пославшем запрос. Естественно exception должен предварительно создан
SETTERM !!;
CREATE TRIGGER " DELETE_INV" FOR " TINV"
ACTIVE BEFORE DELETE
POSITION 10
AS
BEGIN
IF (EXISTS (SELECT tOst.Id FROM tOst
WHERE tOst.Id = tInv.Id))
THEN
EXCEPTION EST_OSTATOK;
END !!
SET TERM ;!!
DBase.StartTransaction;
try
Query.ExecSQL;
DBase.Commit;
except
DBase.Rollback;
raise; // Для последующей обработки
end;
Взято из
Как сделать отступ в Memo?
Как сделать отступ в Memo?
С помощью API-функции SendMessage можно задать поля в Memo-компоненте. Если необходимо, например, сделать отступ в 20 пикселей слева то можно это сделать следующим образом:
var Rect: TRect;
begin
SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
Rect.Left:= 20;
SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
Memo1.Refresh;
end;
Как сделать PING?
Как сделать PING?
Протокол Ping предназначен для тестирования компьютерных соединений в Интернете путём посылки через протокол Internet Protocol (IP) по обределённому адресу сообщения и ожидания от него ответа.
ICMP - Internet Control Message Protocol. ICMP служит для передачи сообщений об ошибках а так же управляющих сообщений . ICMP-тест может показать насколько быстро проходит информация между двумя узлами в Интернете.
1. Запускаем Delphi;
2. В Новом проекте добавляем в форму Tbutton, Tedit и Tmemo;
3. Вставляем "winsock";
4. объявляем структурку для IP-заголовка:
type
IPINFO = record
Ttl: char;
Tos: char;
IPFlags: char;
OptSize: char;
Options: ^char;
end;
5. объявляем структурку для хранения ICMP пакета:
type
ICMPECHO = record
Source: longint;
Status: longint;
RTTime: longint;
DataSize: Shortint;
Reserved: Shortint;
pData: ^variant;
i_ipinfo: IPINFO;
end;
6. Объявляем функции и процедуры, которые мы будем вызывать из ICMP.DLL
TIcmpCreateFile = function():integer; {$IFDEF WIN32} stdcall; {$ENDIF}
TIcmpCloseHandle = procedure(var handle:integer);{$IFDEF WIN32} stdcall; {$ENDIF}
TIcmpSendEcho = function(var handle:integer; endereco:DWORD; buffer:variant; tam:WORD; IP:IPINFO; ICMP:ICMPECHO; tamicmp:DWORD; tempo:DWORD):DWORD;{$IFDEF WIN32} stdcall; {$ENDIF}
7. В Tbutton в событие Onclick вставляем следующий код:
procedure TForm1.Button1Click(Sender: TObject);
var
wsadt: wsadata;
icmp: icmpecho;
HNDicmp: integer;
hndFile: integer;
Host: PHostEnt;
Destino: in_addr;
Endereco: ^DWORD;
IP: ipinfo;
Retorno: integer;
dwRetorno: DWORD;
x: integer;
IcmpCreateFile: TIcmpCreateFile;
IcmpCloseHandle: TIcmpCloseHandle;
IcmpSendEcho: TIcmpSendEcho;
begin
if (edit1.Text = '') then
begin
Application.MessageBox('Enter a HostName ro a IP Adress',
'Error', MB_OK);
exit;
end;
HNDicmp := LoadLibrary('ICMP.DLL');
if (HNDicmp <> 0) then
begin
@IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
@IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
@IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
begin
Application.MessageBox('Error getting ICMP Adress', 'Error', MB_OK);
FreeLibrary(HNDicmp);
end;
end;
Retorno := WSAStartup($0101, wsadt);
if (Retorno <> 0) then
begin
Application.MessageBox('Canґt Load WinSockets', 'WSAStartup', MB_OK);
WSACleanup();
FreeLibrary(HNDicmp);
end;
Destino.S_addr := inet_addr(Pchar(Edit1.text));
if (Destino.S_addr = 0) then
begin
Host := GetHostbyName(PChar(Edit1.text));
end
else
begin
Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
end;
if (host = nil) then
begin
Application.MessageBox('Host not found', 'Error', MB_OK);
WSACleanup();
FreeLibrary(HNDicmp);
exit;
end;
memo1.Lines.Add('Pinging ' + Edit1.text);
Endereco := @Host.h_addr_list;
HNDFile := IcmpCreateFile();
for x := 0 to 4 do
begin
Ip.Ttl := char(255);
Ip.Tos := char(0);
Ip.IPFlags := char(0);
Ip.OptSize := char(0);
Ip.Options := nil;
dwRetorno := IcmpSendEcho(
HNDFile,
Endereco^,
null,
0,
Ip,
Icmp,
sizeof(Icmp),
DWORD(5000));
Destino.S_addr := icmp.source;
Memo1.Lines.Add('Ping ' + Edit1.text);
end;
IcmpCLoseHandle(HNDFile);
FreeLibrary(HNDicmp);
WSACleanup();
end;
У данного примера есть один недостаток - программа не воспримет доменное имя, только IP-адресс. Для пользователей NT не используйте функцию IcmpCloseHandle.
Это всё…..
Ну и в конце полный исходный код примера:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
winsock, StdCtrls;
type
IPINFO = record
Ttl: char;
Tos: char;
IPFlags: char;
OptSize: char;
Options: ^char;
end;
type
ICMPECHO = record
Source: longint;
Status: longint;
RTTime: longint;
DataSize: Shortint;
Reserved: Shortint;
pData: ^variant;
i_ipinfo: IPINFO;
end;
TIcmpCreateFile = function(): integer; {$IFDEF WIN32}stdcall; {$ENDIF}
TIcmpCloseHandle = procedure(var handle: integer); {$IFDEF WIN32}stdcall; {$ENDIF}
TIcmpSendEcho = function(var handle: integer; endereco: DWORD; buffer: variant; tam: WORD; IP: IPINFO; ICMP: ICMPECHO; tamicmp: DWORD; tempo: DWORD): DWORD; {$IFDEF WIN32}stdcall; {$ENDIF}
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
wsadt: wsadata;
icmp: icmpecho;
HNDicmp: integer;
hndFile: integer;
Host: PHostEnt;
Destino: in_addr;
Endereco: ^DWORD;
IP: ipinfo;
Retorno: integer;
dwRetorno: DWORD;
x: integer;
IcmpCreateFile: TIcmpCreateFile;
IcmpCloseHandle: TIcmpCloseHandle;
IcmpSendEcho: TIcmpSendEcho;
begin
if (edit1.Text = '') then
begin
Application.MessageBox('Digite um HostName ou um End. IP',
'Error', MB_OK);
exit;
end;
HNDicmp := LoadLibrary('ICMP.DLL');
if (HNDicmp <> 0) then
begin
@IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
@IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
@IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
begin
Application.MessageBox('Erro pegando endereзos ICMP', 'Error', MB_OK);
FreeLibrary(HNDicmp);
end;
end;
Retorno := WSAStartup($0101, wsadt);
if (Retorno <> 0) then
begin
Application.MessageBox('Nгo foi possнvel carregar WinSockets', 'WSAStartup', MB_OK);
WSACleanup();
FreeLibrary(HNDicmp);
end;
Destino.S_addr := inet_addr(Pchar(Edit1.text));
if (Destino.S_addr = 0) then
begin
Host := GetHostbyName(PChar(Edit1.text));
end
else
begin
Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
end;
if (host = nil) then
begin
Application.MessageBox('Host nгo encontrado', 'Error', MB_OK);
WSACleanup();
FreeLibrary(HNDicmp);
exit;
end;
memo1.Lines.Add('Pinging ' + Edit1.text);
Endereco := @Host.h_addr_list;
HNDFile := IcmpCreateFile();
for x := 0 to 4 do
begin
Ip.Ttl := char(255);
Ip.Tos := char(0);
Ip.IPFlags := char(0);
Ip.OptSize := char(0);
Ip.Options := nil;
dwRetorno := IcmpSendEcho(
HNDFile,
Endereco^,
null,
0,
Ip,
Icmp,
sizeof(Icmp),
DWORD(5000));
Destino.S_addr := icmp.source;
Memo1.Lines.Add('Pingou ' + Edit1.text);
end;
IcmpCLoseHandle(HNDFile);
FreeLibrary(HNDicmp);
WSACleanup();
end;
end.
Как сделать плавную прокрутку?
Как сделать плавную прокрутку?
В RxLib есть компонент SecretPanel для этого..
Автор ответа: Vit
Взято с Vingrad.ru
Как сделать поиск/замену в документе?
Как сделать поиск/замену в документе?
You should use a variant because the Find.Execute method is a bit buggy. Something like this, for example:
{... }
var
Rnge: OleVariant;
{ ... }
Rnge := Doc.Content;
Rnge.Find.Execute('old', Wrap := wdFindContinue, ReplaceWith := 'new', Replace :=
wdReplaceAll);
{ ... }
{ ... }
{ Create the OLE Object }
WordApp := CreateOLEObject('Word.Application');
WordApp.Documents.Open(yourDocFile);
WordApp.Selection.Find.ClearFormatting;
WordApp.Selection.Find.Text := yourOldStr;
WordApp.Selection.Find.Replacement.Text := yourNewStr;
WordApp.Selection.Find.Forward := True;
WordApp.Selection.Find.Wrap := 1; {wdFindContinue}
WordApp.Selection.Find.Format := False;
WordApp.Selection.Find.MatchCase := False;
WordApp.Selection.Find.MatchWholeWord := False;
WordApp.Selection.Find.MatchWildcards := True;
WordApp.Selection.Find.MatchSoundsLike := False;
WordApp.Selection.Find.MatchAllWordForms := False;
WordApp.Selection.Find.Execute(Replace := 2); {wdReplaceAll}
{Or as alternative: WordApp.Selection.Find.Execute(Replace := 1); for one replace}
WordApp.ActiveDocument.SaveAs(yourNewDocFile);
WordApp.Quit;
WordApp := Unassigned;
{ ... }
Взято с
Delphi Knowledge BaseКак сделать pop-up Combobox по позиции курсора в Memo?
Как сделать pop-up Combobox по позиции курсора в Memo?
unitCBoxInMemo;
interface
uses
Windows, Classes, Controls, Graphics, Forms, StdCtrls;
type
TFrmCboxInMemo = class(TForm)
Button1: TButton;
Memo1: TMemo;
Label1: TLabel;
ComboBox1: TComboBox;
procedure Button1Click(Sender: TObject);
procedure ComboBox1Exit(Sender: TObject);
procedure ComboBox1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FrmCboxInMemo: TFrmCboxInMemo;
implementation
{$R *.DFM}
procedure TFrmCboxInMemo.Button1Click(Sender: TObject);
var
clientPos: TPoint;
lineHeight: Integer;
tmpFont: TFont;
begin
GetCaretPos(clientPos);
{Use the following calculation of line height only if you want your combobox
to appear below the char position you are referencing.}
tmpFont := Canvas.Font;
Canvas.Font := Memo1.Font;
lineHeight := Canvas.TextHeight('Xy');
Canvas.Font := tmpFont;
with ComboBox1 do
begin
{Adjustment of Top by lineHeight only necessary if combobox is to appear below line.}
Top := clientPos.Y + Memo1.Top + lineHeight;
Left := clientPos.X + Memo1.Left;
Visible := true;
SetFocus;
end;
end;
procedure TFrmCboxInMemo.ComboBox1Exit(Sender: TObject);
begin
ComboBox1.Visible := false;
end;
procedure TFrmCboxInMemo.ComboBox1Click(Sender: TObject);
begin
ComboBox1.Visible := false;
end;
end.
Взято с
Delphi Knowledge BaseКак сделать Pop-Up меню при щелчке иконке в Sys tray?
Как сделать Pop-Up меню при щелчке иконке в Sys tray?
Многие программы показывают Pop-Up меню при щелчке на их иконке, помещенной на Tray, как этого добиться ?
Вы должны обрабатывать сообщение, указанное вами при добавлении иконки на Tray. При значении (UINT)lParam, равном WM_RBUTTONDOWN (это обычно дял Pop-Up меню по правой кнопке), или любому другому необходимому вам, вы должны вызовом функции GetCursorPos() получить позицию курсора в момент события (вряд ли пользователь успеет убрать мышь за время обработки сообщения, особенно если он ожидает меню), получить вескриптор Pop-Up меню одним из многих способов (LoadMenu(), GetSubMenu(), CreateMenu(), и т.д.) и выполнить следующий код:
SetForegroundWindow(hWnd);
TrackPopupMenuEx(hMenu,TPM_HORIZONTAL|TPM_LEFTALIGN,x, y,hWnd, NULL);
DestroyMenu(hMenu);
PostMessage(hWnd,WM_USER,0,0);
где hWnd - дескриптор окна, которое будет обрабатывать команду меню,
hMenu - дескриптор меню,
x и y - позиция курсора.
Для подробностей смотрите Win32 SDK Help по функции TrackPopupMenuEx.
Взято из FAQ:
Как сделать предпросмотр?
Как сделать предпросмотр?
unitprintpreview;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
PreviewPaintbox: TPaintBox;
Label1: TLabel;
Label2: TLabel;
LeftMarginEdit: TEdit;
TopMarginEdit: TEdit;
Label3: TLabel;
Label4: TLabel;
RightMarginEdit: TEdit;
Label5: TLabel;
BottomMarginEdit: TEdit;
ApplyMarginsButton: TButton;
OrientationRGroup: TRadioGroup;
Label6: TLabel;
ZoomEdit: TEdit;
ZoomUpDown: TUpDown;
procedure LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
procedure FormCreate(Sender: TObject);
procedure PreviewPaintboxPaint(Sender: TObject);
procedure ApplyMarginsButtonClick(Sender: TObject);
private
{ Private declarations }
PreviewText: string;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses printers;
{$R *.DFM}
procedure TForm1.LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
begin
if not (Key in ['0'..'9', #9, DecimalSeparator]) then
Key := #0;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
S: string;
procedure loadpreviewtext;
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Loadfromfile(Extractfilepath(application.exename) + 'printpreview.pas');
PreviewText := sl.Text;
finally
sl.free
end;
end;
begin
{Initialize the margin edits with a margin of 0.75 inch}
S := FormatFloat('0.00', 0.75);
LeftMarginEdit.Text := S;
TopMarginEdit.Text := S;
RightMarginEdit.Text := S;
BottomMarginEdit.Text := S;
{Initialize the orientation radio group}
if Printer.Orientation = poPortrait then
OrientationRGroup.ItemIndex := 0
else
OrientationRGroup.ItemIndex := 1;
{load test text for display}
LoadPreviewtext;
end;
procedure TForm1.PreviewPaintboxPaint(Sender: TObject);
var
pagewidth, pageheight: Double; {printer page dimension in inch}
printerResX, printerResY: Integer; {printer resolution in dots/inch}
minmarginX, minmarginY: Double; {nonprintable margin in inch}
outputarea: TRect; {print area in 1/1000 inches}
scale: Double; {conversion factor, pixels per 1/1000 inch}
procedure InitPrintSettings;
function GetMargin(S: string; inX: Boolean): Double;
begin
Result := StrToFloat(S);
if InX then
begin
if Result < minmarginX then
Result := minmarginX;
end
else
begin
if Result < minmarginY then
Result := minmarginY;
end;
end;
begin
printerResX := GetDeviceCaps(printer.handle, LOGPIXELSX);
printerResY := GetDeviceCaps(printer.handle, LOGPIXELSY);
pagewidth := GetDeviceCaps(printer.handle, PHYSICALWIDTH) / printerResX;
pageheight := GetDeviceCaps(printer.handle, PHYSICALHEIGHT) / printerResY;
minmarginX := GetDeviceCaps(printer.handle, PHYSICALOFFSETX) / printerResX;
minmarginY := GetDeviceCaps(printer.handle, PHYSICALOFFSETY) / printerResY;
outputarea.Left := Round(GetMargin(LeftMarginEdit.Text, true) * 1000);
outputarea.Top := Round(GetMargin(TopMarginEdit.Text, false) * 1000);
outputarea.Right := Round((pagewidth - GetMargin(RightMarginEdit.Text, true)) *
1000);
outputarea.Bottom := Round((pageheight - GetMargin(BottomMarginEdit.Text, false))
* 1000);
end;
procedure ScaleCanvas(Canvas: TCanvas; widthavail, heightavail: Integer);
var
needpixelswidth, needpixelsheight: Integer;
{dimensions of preview at current zoom factor in pixels}
orgpixels: TPoint;
{origin of preview in pixels}
begin
{set up a coordinate system for the canvas that uses 1/1000 inch as unit,
honors the zoom factor and maintains the MM_TEXT orientation of the
coordinate axis (origin in top left corner, positive Y axis points down}
scale := Screen.PixelsPerInch / 1000;
{Apply zoom factor}
scale := scale * StrToInt(Zoomedit.text) / 100;
{figure out size of preview}
needpixelswidth := Round(pagewidth * 1000 * scale);
needpixelsheight := Round(pageheight * 1000 * scale);
if needpixelswidth >= widthavail then
orgpixels.X := 0
else
orgpixels.X := (widthavail - needpixelswidth) div 2;
if needpixelsheight >= heightavail then
orgpixels.Y := 0
else
orgpixels.Y := (heightavail - needpixelsheight) div 2;
{change mapping mode to MM_ISOTROPIC}
SetMapMode(canvas.handle, MM_ISOTROPIC);
{move viewport origin to orgpixels}
SetViewportOrgEx(canvas.handle, orgpixels.x, orgpixels.y, nil);
{scale the window}
SetViewportExtEx(canvas.handle, Round(1000 * scale), Round(1000 * scale), nil);
SetWindowExtEx(canvas.handle, 1000, 1000, nil);
end;
begin
if OrientationRGroup.ItemIndex = 0 then
Printer.Orientation := poPortrait
else
Printer.Orientation := poLandscape;
InitPrintsettings;
with Sender as TPaintBox do
begin
ScaleCanvas(Canvas, ClientWidth, ClientHeight);
{specify font height in 1/1000 inch}
Canvas.Font.Height := Round(font.height / font.pixelsperinch * 1000);
{paint page white}
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, 0, Round(pagewidth * 1000), Round(pageheight * 1000)));
{draw the text}
DrawText(canvas.handle, PChar(PreviewText), Length(PreviewText),
outputarea, DT_WORDBREAK or DT_LEFT);
{Draw thin gray lines to mark borders}
Canvas.Pen.Color := clGray;
Canvas.Pen.Style := psSolid;
Canvas.Pen.Width := 10;
with Canvas do
begin
MoveTo(outputarea.left - 100, outputarea.top);
LineTo(outputarea.right + 100, outputarea.top);
MoveTo(outputarea.left - 100, outputarea.bottom);
LineTo(outputarea.right + 100, outputarea.bottom);
MoveTo(outputarea.left, outputarea.top - 100);
LineTo(outputarea.left, outputarea.bottom + 100);
MoveTo(outputarea.right, outputarea.top - 100);
LineTo(outputarea.right, outputarea.bottom + 100);
end;
end;
end;
procedure TForm1.ApplyMarginsButtonClick(Sender: TObject);
begin
PreviewPaintbox.Invalidate;
end;
end.
object Form1: TForm1
Left = 192
Top = 128
Width = 696
Height = 480
Caption = 'Form1'
Color = clBtnFace
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -15
Font.Name = 'Arial'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 120
TextHeight = 17
object Panel1: TPanel
Left = 503
Top = 0
Width = 185
Height = 453
Align = alRight
TabOrder = 0
object Label1: TLabel
Left = 8
Top = 8
Width = 92
Height = 17
Caption = 'Margins (inch)'
end
object Label2: TLabel
Left = 8
Top = 45
Width = 24
Height = 17
Caption = 'Left'
end
object Label3: TLabel
Left = 8
Top = 77
Width = 25
Height = 17
Caption = 'Top'
end
object Label4: TLabel
Left = 8
Top = 109
Width = 34
Height = 17
Caption = 'Right'
end
object Label5: TLabel
Left = 8
Top = 141
Width = 47
Height = 17
Caption = 'Bottom'
end
object Label6: TLabel
Left = 8
Top = 261
Width = 64
Height = 17
Caption = 'Zoom (%)'
end
object LeftMarginEdit: TEdit
Left = 60
Top = 40
Width = 100
Height = 25
TabOrder = 0
OnKeyPress = LeftMarginEditKeyPress
end
object TopMarginEdit: TEdit
Left = 60
Top = 72
Width = 100
Height = 25
TabOrder = 1
OnKeyPress = LeftMarginEditKeyPress
end
object RightMarginEdit: TEdit
Left = 60
Top = 104
Width = 100
Height = 25
TabOrder = 2
OnKeyPress = LeftMarginEditKeyPress
end
object BottomMarginEdit: TEdit
Left = 60
Top = 136
Width = 100
Height = 25
TabOrder = 3
OnKeyPress = LeftMarginEditKeyPress
end
object ApplyMarginsButton: TButton
Left = 24
Top = 304
Width = 137
Height = 25
Caption = 'Apply'
TabOrder = 4
OnClick = ApplyMarginsButtonClick
end
object OrientationRGroup: TRadioGroup
Left = 8
Top = 176
Width = 161
Height = 65
Caption = 'Orientation'
Items.Strings = (
'Portrait'
'Landscape')
TabOrder = 5
end
object ZoomEdit: TEdit
Left = 80
Top = 256
Width = 40
Height = 25
TabOrder = 6
Text = '50'
end
object ZoomUpDown: TUpDown
Left = 120
Top = 256
Width = 17
Height = 25
Associate = ZoomEdit
Min = 0
Increment = 10
Position = 50
TabOrder = 7
Wrap = False
end
end
object Panel2: TPanel
Left = 0
Top = 0
Width = 503
Height = 453
Align = alClient
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -17
Font.Name = 'Times New Roman'
Font.Style = []
ParentFont = False
TabOrder = 1
object PreviewPaintbox: TPaintBox
Left = 1
Top = 1
Width = 501
Height = 451
Align = alClient
OnPaint = PreviewPaintboxPaint
end
end
end
Взято с
Delphi Knowledge BaseКак сделать прозрачное окно родными средствами Windows2000?
Как сделать прозрачное окно родными средствами Windows2000?
В Windows2000 есть для этого ф-я SetLayeredWindowAttributes, вот пример её использования:
unit Win2k;
interface
uses Graphics, Windows;
function SetLayeredWindowAttributes(
hwnd : HWND; // handle to the layered window
crKey : TColor; // specifies the color key
bAlpha : byte; // value for the blend function
dwFlags : DWORD // action
): BOOL; stdcall;
function SetLayeredWindowAttributes; external 'user32.dll';
implementation
end.
program WinLayer;
uses
Windows, SysUtils,
Win2k in 'Win2k.pas';
const
WS_EX_LAYERED= $80000;
LWA_COLORKEY = 1;
LWA_ALPHA = 2;
var
Hndl : THandle;
Transp : Byte;
begin
Writeln('Windows2000 Layer <- build by AK ->');
Writeln(' Usage: WINLAYER.EXE [window name] [Transp (0-255)]');
Writeln(' Example: WINLAYER "Calculator" 200');
Writeln;
if ParamCount <> 2 then exit;
Hndl := FindWindow(nil, PChar(ParamStr(1)));
Transp := StrToIntDef(ParamStr(2), 128);
if SetWindowLong(Hndl, GWL_EXSTYLE, GetWindowLong(Hndl, GWL_EXSTYLE) or WS_EX_LAYERED) = 0 then
Writeln('Error !');
if not SetLayeredWindowAttributes(Hndl, 0, Transp, LWA_ALPHA) then
// ^^^ степень прозрачности
// 0 - полная прозрачность
// 255 - полная непрозрачность
Writeln('Error !');
end.
Взято с Исходников.ru
Как сделать пункты меню с картинками?
Как сделать пункты меню с картинками?
Следующий код показывает, как добавить картинку в виде объекта TImage в объект TMenuItem.
var
hHandle: THandle;
x: integer;
// visual controls:
hMenu: TMenuItem;
Image1: TImage;
...
x:= 10; // десятый пункт меню
hHandle := GetMenuItemID(hMenu.handle, x);
ModifyMenu(hMenu.handle, hHandle, MF_BYCOMMAND Or MF_BITMAP, hHandle,
PChar(Image1.picture.bitmap.handle))
Взято с Исходников.ru
Как сделать различные подсказки для каждой ячейки в StringGrid?
Как сделать различные подсказки для каждой ячейки в StringGrid?
Следующий пример демонстрирует отслеживаение движения мышки в компоненте TStringGrid. Если мышка переместится на другую ячейку в гриде, то будет показано новое окно подсказки с номером колонки и строки данной ячейки:
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
Col : integer;
Row : integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Hint := '0 0';
StringGrid1.ShowHint := True;
end;
procedure TForm1.StringGrid1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
r : integer;
c : integer;
begin
StringGrid1.MouseToCell(X, Y, C, R);
if ((Row <> r) or
(Col <> c)) then begin
Row := r;
Col := c;
Application.CancelHint;
StringGrid1.Hint := IntToStr(r) + #32 + IntToStr(c);
end;
end;
Взято с Исходников.ru
Как сделать регулятор громкости?
Как сделать регулятор громкости?
ВОТ нашел в Интернете:
Эта программа увеличивает громкость выбранного канала на 1000.
uses MMSystem;
procedure TForm1.Button1Click(Sender: TObject);
var
vol: longint;
LVol, RVol: integer;
begin
AuxGetVolume(ListBox1.ItemIndex, @Vol);
LVol := Vol shr 16;
if LVol < MaxWord - 1000
then LVol := LVol + 1000
else LVol := MaxWord;
RVol := (Vol shl 16) shr 16;
if RVol < MaxWord - 1000
then RVol := RVol + 1000
else RVol := MaxWord;
AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
cap: TAuxCaps;
begin
for i := 0 to auxGetNumDevs - 1 do begin
auxGetDevCaps(i, Addr(cap), SizeOf(cap));
ListBox1.Items.Add(cap.szPname)
end;
end;
Второй вариант:
uses mmsystem;
function GetWaveVolume: DWord;
var
Woc : TWAVEOUTCAPS;
Volume : DWord;
begin
result:=0;
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
begin
WaveOutGetVolume(WAVE_MAPPER, @Volume);
Result := Volume;
end;
end;
procedure SetWaveVolume(const AVolume: DWord);
var Woc : TWAVEOUTCAPS;
begin
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then WaveOutSetVolume(WAVE_MAPPER, AVolume);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Beep;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
LeftVolume: Word;
RightVolume: Word;
begin
LeftVolume := StrToInt(Edit1.Text);
RightVolume := StrToInt(Edit2.Text);
SetWaveVolume(MakeLong(LeftVolume, RightVolume));
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Caption := IntToStr(GetWaveVolume);
end;
Автор MMM
Взято с Vingrad.ru
Как сделать roll-up форму?
Как сделать roll-up форму?
unittestmain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Buttons, ShellAPI;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
FOldHeight: Integer;
procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown);
message WM_NCRBUTTONDOWN;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
FOldHeight := ClientHeight;
end;
procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown);
var
I: Integer;
begin
if (Msg.HitTest = HTCAPTION) then
if (ClientHeight = 0) then
begin
I := 0;
while (I < FOldHeight) do
begin
I := I + 40;
if (I > FOldHeight) then
I := FOldHeight;
ClientHeight := I;
Application.ProcessMessages;
end;
end
else
begin
FOldHeight := ClientHeight;
I := ClientHeight;
while (I > 0) do
begin
I := I - 40;
if (I < 0) then
I := 0;
ClientHeight := I;
Application.ProcessMessages;
end;
end;
end;
end.
First, by way of synopsis, the roll-up/down occurs in response to a WM_NCRBUTTONDOWN message firing off and the WMNCRButtonDown procedure handling the message, telling the window to roll up/down depending upon the height of the client area. WM_NCRBUTTONDOWN fires whenever the right mouse button is clicked in a "non-client" area, such as a border, menu or, for our purposes, the caption bar of a form. (The client area of a window is the area within the border where most of the interesting activity usually occurs. In general, the Windows API restricts application code to drawing only within the client area.)
Delphi encapsulates the WM_NCRBUTTONDOWN in a TWMNCRButtonDown type, which is actually an assignment from a TWMNCHitMessage type that has the following structure:
type
TWMNCHitMessage = record
Msg: Cardinal;
HitTest: Integer;
XCursor: SmallInt;
YCursor: SmallInt;
Result: Longint;
end;
It's easy to create message wrappers in Delphi to deal with messages that aren't handled by an object by default. Since a right-click on the title bar of a form isn't handled by default, I had to create a wrapper. The procedure procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN; is the wrapper I created. All that goes on in the procedure is the following:
In order to make this work, I had to create a variable called FOldHeight and set its value at FormCreate whenever the form was to be rolled up. FOldHeight is used as a place for the form to remember what size it was before it was re-sized to 0. When a form is to be rolled up, FOldHeight is immediately set to the current ClientHeight, which means you can interactively set the form's size, and the function will always return the form's ClientHeight to what it was before you rolled it up.
So what use is this? Well, sometimes I don't want to iconize a window; I just want to get it out of the way so I can see what's underneath. Having the capability to roll a form up to its title bar makes it a lot easier to see underneath a window without iconizing it, then having to Alt-tab back to it. (If you are familiar with the Macintosh platform, the System 7.5 environment offers a very similar facility called a "window shade," and makes a roll-up sound when the shade goes up.)
Взято с
Delphi Knowledge BaseКак сделать список всех пользователей BDE?
Как сделать список всех пользователей BDE?
With Paradox:
procedureBDEGetPDXUserList(AList: TStrings);
var
hCur: hDBICur;
UDesc: USERDesc;
begin
AList.Clear;
Check(DBIOpenUserList(hCur));
try
while DBIGetNextRecord(hCur, dbiNOLOCK, @UDesc, nil) <> DBIERR_EOF do
begin
AList.Add(StrPas(UDesc.szUserName));
end;
finally
DBICloseCursor(hCur);
end;
end;
Взято с
Delphi Knowledge BaseКак сделать стандартные цвета в Delphi светлее или темнее
Как сделать стандартные цвета в Delphi светлее или темнее
Автор: Den Bedard
В данной статье хотелось бы показать принцип получения из обычного цвета более тёмный или более светлый. А так же рассмотрим, как этот принцип реализовани в программном коде.
Итак, немного теории:
Каждый из трёх основных цветов (Красный,Зелёный,Синий) могут иметь значение от 0 до 255, соответственно скомбинировав их мы можем получить 16,777,216 возможных цветов. Визуально это можно предствить как три оси куба, в котором направления x, y и z отвечают за цвета красный, зелёный и синий. В сочетании эти направления дают точку в кубе, представляющую один цвет из 16 миллионов. Точка куба, в которой значение равняется 0 (0,0,0) соответствует чёрному цвету, значение (255,255,255) - белому цвету, (255,0,0) - чисто красному, и т.д.
Если визуально провести линию между каким-либо цветом (r,g,b) и белым цветом (255,255,255), то получится, что на этой линии будут лежать все значения данного цвета (r,g,b). Если мы будем двигаться по линии в сторону белого цвета, то яркость будет увеличиваться до тех пор пока не получим чисто белый цвет.
То же самое можно сделать и для уменьшения яркости цвета. Достаточно провести линию из цвета (r,g,b) в чёрный (0,0,0). То есть при движении по линии к чёрному цвету мы будем уменьшать яркость до тех пор, пока не получим чёрный цвет.
Функция "Darker" возвращает новое значение цвета, которое будет на сколько-то процентов темнее. Естевственно, что при 100% мы получим чёрный цвет.
Функция "Lighter" возвращает цвет, который светлее на сколько-то процентов исходного. 100% - белый цвет.
Функции Darker и Lighter требуют 2 параметра и используются примерно так:
Panel1.Color := Darker(clBlue,20);
Получется панель цветов, которая на 20% темнее обычного синего цвета.
Теперь давайте посмотрим, как выглядят внутри наши функции:
function Darker(Color:TColor; Percent:Byte):TColor;
var
r,g,b:Byte;
begin
Color:=ColorToRGB(Color);
r:=GetRValue(Color);
g:=GetGValue(Color);
b:=GetBValue(Color);
r:=r-muldiv(r,Percent,100); //процент% уменьшения яркости
g:=g-muldiv(g,Percent,100);
b:=b-muldiv(b,Percent,100);
result:=RGB(r,g,b);
end;
function Lighter(Color:TColor; Percent:Byte):TColor;
var
r,g,b:Byte;
begin
Color:=ColorToRGB(Color);
r:=GetRValue(Color);
g:=GetGValue(Color);
b:=GetBValue(Color);
r:=r+muldiv(255-r,Percent,100); //процент% увеличения яркости
g:=g+muldiv(255-g,Percent,100);
b:=b+muldiv(255-b,Percent,100);
result:=RGB(r,g,b);
end;
Так же я добавил некоторые функции, в которых уже добавлены стандартные значения процентов. Это для тех, кому некогда задумываться над процентами :)
Panel1.Color := Light(clBlue);
Panel1.Color := SlightlyDark(clRed);
Panel1.Color := VeryLight(clMagenta);
etc.
function SlightlyDark(Color:TColor):TColor;
begin
Result := Darker(Color,25);
end;
function Dark(Color:TColor):TColor;
begin
Result := Darker(Color,50);
end;
function VeryDark(Color:TColor):TColor;
begin
Result := Darker(Color,75);
end;
function SlightlyLight(Color:TColor):TColor;
begin
Result := Lighter(Color,25);
end;
function Light(Color:TColor):TColor;
begin
Result := Lighter(Color,50);
end;
function VeryLight(Color:TColor):TColor;
begin
Result := Lighter(Color,75);
end;
Взято с Исходников.ru
Как сделать subform?
Как сделать subform?
Those programmers who use the Win API in their programs know that Win32 allows you to insert one dialog box into another one and you'll can deal with subdialog's controls as them were in parent dialog. The good example of it is PropertySheet. I don't know why Borland hided this ability from us and why didn't it insert 'subforming' ability in TForm control. Here I can tell how to use a form as control (subform) in other one and how to create subform controls. It will work in D2, D3 and may be D4 (unfortunatelly, I have not it and can't check). The next steps shows how to make subform component:
First, we have to make the form to be a child. For this we need to override the method CreateParams.
type
TSubForm = class(TForm)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_CHILD or WS_DLGFRAME or WS_VISIBLE or DS_CONTROL;
end;
It's enough if you will not register this control into Delphi IDE. Now you can insert TSubForm control into a form at run time as shown below:
{ ... }
with TSubForm.Create(YourForm) do
begin
Parent := YourForm;
Left := 8;
Top := 8;
end;
{ ... }
Unfortunately, it's not enough if you want insert this control into Delphi IDE. You have to do next two important things for it. Override TSubForm's destructor for prevent Delphi from break when subform will be deleted at design time (by user or Delphi). It can be fixed with next code:
destructor TSubForm.Destroy;
begin
SetDesigning(False);
inherited Destroy;
end;
Now your subform (sure inserted into form) looks like gray rectangle. The good deal is to make subform to show it's components at design time:
constructor TSubForm.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
if csDesigning in ComponentState then
ReadComponentRes(Self.ClassName, Self);
end;
Now you have a nice subform control which can be used at run time or design time. You can do it with any form which you wish see as subform.
Note: You can define events handler for subform and them will work. In case subform already has some event handler defined and you try redefine it, only subform's event handler will work at run time!
Full source code of the subform control:
unit SubForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Menus, Dialogs,
StdCtrls;
type
TSubForm = class(TForm)
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
end;
procedure Register;
implementation
{$R *.DFM}
procedure Register;
begin
RegisterComponents('SubForms', [TSubForm]);
end;
constructor TSubForm.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
if (csDesigning in ComponentState) then
ReadComponentRes(Self.ClassName, Self);
end;
destructor TSubForm.Destroy;
begin
SetDesigning(False);
inherited Destroy;
end;
procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_CHILD or WS_DLGFRAME or WS_VISIBLE or DS_CONTROL;
end;
end.
Взято с
Delphi Knowledge BaseКак сделать свои собственные сообщения при компилляции?
Как сделать свои собственные сообщения при компилляции?
Формат команды:
{$MESSAGE HINT|WARN|ERROR|FATAL 'text string' }
Например, добавление следующих строк приведёт к появлению:
{$MESSAGE 'Появился новый hint!'}
{$MESSAGE Hint 'И это тоже hint!'}
{$MESSAGE Warn 'А это уже Warning'}
{$MESSAGE Error 'Эта строка вызовет ошибку компиляции!'}
{$MESSAGE Fatal 'А это фатальная ошибка компиляции!'}
Пример:
destructor TumbSelectionTempTable.Destroy;
begin
// Clear the temp tables.
{$MESSAGE Warn ' - remember to free all allocated objects'}
ClearAllOuterWorldFold;
if FSubjectsTempTableCreated then
DropTempTable(FTableName);
FOuterWorldsFolded.Free;
FQuery.Free;
inherited;
end;
Работает только в Дельфи 6/7
Как сделать текстовый список всех доступных свойств перечисляемого типа?
Как сделать текстовый список всех доступных свойств перечисляемого типа?
I need to get a list of strings (like a StringList) with the possible values for a TBrushStyle property (bsSolid, bsClear, bsHorizontal, for example). I want to build a ComboBox with this options. How can I set the property Items of my ComboBox directly with all the values from the enumerated type TBrushStyle? My ComboBox will be alike the Property Editor for this type.
You can use runtime type information (RTTI) to do that. Below is an example:
uses
{...}, TypInfo
procedure BrushStylesAsStrings(AList: TStrings);
var
a: integer;
pInfo: PTypeInfo;
pEnum: PTypeData;
begin
AList.Clear;
pInfo := PTypeInfo(TypeInfo(TBrushStyle));
pEnum := GetTypeData(pInfo);
with pEnum^ do
begin
for a := MinValue to MaxValue do
AList.Add(GetEnumName(pInfo, a));
end;
end;
Tip by Sen
Взято из
Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?
Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?
Смотри пример $Delphi\Demos\Docking\
Автор SmaLL
Взято с Vingrad.ru
Как сделать Twist / Swirl эффект
Как сделать Twist / Swirl эффект
{... }
try
try
begin
b := TBitmap.Create;
tBufr := TBitmap.Create;
CopyMe(b, Image1.Picture.Graphic); {copy image to b}
Twist(100);
end;
finally
begin
b.Free;
tBufr.Free;
end;
end;
except
raise ESomeErrorWarning.Create('Kaboom!');
end;
{ ... }
Hope this is what you were looking for:
{A procedure to copy a graphic to a bitmap}
procedure TForm1.CopyMe(tobmp: TBitmap; frbmp: TGraphic);
begin
tobmp.PixelFormat := pf24bit;
tobmp.Width := frbmp.Width;
tobmp.Height := frbmp.Height;
tobmp.Canvas.Draw(0, 0, frbmp);
end;
procedure TForm1.Twist(Amount: integer);
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: Integer;
dx, dy: Single;
K: integer;
Offset: Single;
ty, tx: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: pRGBArray;
function ArcTan2(xt, yt: Single): Single;
begin
if xt = 0 then
if yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;
begin
Screen.Cursor := crHourGlass;
CopyMe(tBufr, b);
K := Amount; {Adjust this for 'amount' of twist}
Offset := -(Pi / 2);
dx := b.Width - 1;
dy := b.Height - 1;
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (b.Width - 1) / 2; {Adjust these to move center of rotation}
tymid := (b.Height - 1) / 2; {Adjust these to move}
fxmid := (b.Width - 1) / 2;
fymid := (b.Height - 1) / 2;
if tx2 >= b.Width then
tx2 := b.Width - 1;
if ty2 >= b.Height then
ty2 := b.Height - 1;
for ty := 0 to Round(ty2) do
begin
for tx := 0 to Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
if r = 0 then
begin
fx := 0;
fy := 0;
end
else
begin
theta := ArcTan2(dx, dy) - r / K - Offset;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
ify := Trunc(fy);
ifx := Trunc(fx);
{Calculate the weights}
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
if ifx < 0 then
ifx := b.Width - 1 - (-ifx mod b.Width)
else if ifx > b.Width - 1 then
ifx := ifx mod b.Width;
if ify < 0 then
ify := b.Height - 1 - (-ify mod b.Height)
else if ify > b.Height - 1 then
ify := ify mod b.Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < b.Height then
sli := tBufr.Scanline[ify + iy]
else
sli := tBufr.ScanLine[b.Height - ify - iy];
if ifx + ix < b.Width then
begin
new_red := sli[ifx + ix].rgbtRed;
new_green := sli[ifx + ix].rgbtGreen;
new_blue := sli[ifx + ix].rgbtBlue;
end
else
begin
new_red := sli[b.Width - ifx - ix].rgbtRed;
new_green := sli[b.Width - ifx - ix].rgbtGreen;
new_blue := sli[b.Width - ifx - ix].rgbtBlue;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := b.ScanLine[ty];
slo[tx].rgbtRed := Round(total_red);
slo[tx].rgbtGreen := Round(total_green);
slo[tx].rgbtBlue := Round(total_blue);
end;
end;
Image1.Picture.Assign(b);
Screen.Cursor := crDefault;
end;
Взято с
Delphi Knowledge BaseКак сделать виртуальный диск?
Как сделать виртуальный диск?
{... }
if DefineDosDevice(DDD_RAW_TARGET_PATH, 'P:', 'F:\Backup\Music\Modules') then
ShowMessage('Drive was created successfully')
else
ShowMessage('Error creating drive");
{ ... }
Взято с
Delphi Knowledge BaseКак сделать выделение "резиновым прямоугольником"?
Как сделать выделение "резиновым прямоугольником"?
Cтатья Даниила Карапетяна ( )
как реализовать выделение "резиновым прямоугольником". Иными словами, когда пользоватьль нажимает на левую кнопку мыши и сдвигает ее, на экране появляется прямоугольник, изменяющий размеры при движении мыши, причем все объекты, попавшие в этот прямоугольник выделяются.
В качестве объекта я взял Label, меняющий цвет в зависимости от того, выделен он или нет. При нажатии мышью на форме в FirstPoint кладутся координата курсора. При дальнейшем движении мыши координаты прямоугольника будут высчитываться по FirstPoint и текущим координатам курсора. Причем, чтобы программа нормально отрабатывала случай, когда высота или ширина прямоугольника отрицательная (это произойдет, если увести мышь левее или выше начальной точки), создана процедура NormalRect. NormalRect устанавливает координаты прямоугольника sel по координатам двух протвоположенных углов прямоугольника, вне зависимости от порядка. DrawRect рисует на форме прямоугольник, использую режим XOR. Благодаря этому режиму, чтобы стереть такой прямоугольник, достаточно нарисовать его повторно.
Скачать необходимые для компиляции файлы проекта можно на program.dax.ru/subscribe/.
uses stdctrls;
var
Selecting: boolean = false;
FirstPoint: TPoint;
sel: TRect;
procedure DrawRect;
begin
with Form1.Canvas do begin
Pen.Style := psDot;
Pen.Color := clGray;
Pen.Mode := pmXor;
Brush.Style := bsClear;
Rectangle(sel.Left, sel.Top, sel.Right, sel.Bottom);
end;
end;
procedure NormalRect(p1, p2: TPoint);
begin
if p1.x < p2.x then
begin
sel.Left := p1.x;
sel.Right := p2.x;
end
else
begin
sel.Left := p2.x;
sel.Right := p1.x;
end;
if p1.y < p2.y then
begin
sel.Top := p1.y;
sel.Bottom := p2.y;
end
else
begin
sel.Top := p2.y;
sel.Bottom := p1.y;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var i: integer;
begin
randomize;
for i := 1 to random(5) + 5 do
begin
with TLabel.Create(Form1) do
begin
Caption := 'Label' + IntToStr(i);
Left := random(Form1.ClientWidth - Width);
Top := random(Form1.ClientHeight - Height);
Visible := true;
Parent := Form1;
end;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if selecting or (Button <> mbLeft) then Exit;
SetCapture(Form1.Handle);
Selecting := true;
FirstPoint := Point(X, Y);
sel := Bounds(X, Y, 0, 0);
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure SelectLebel(lb: TLabel; r: TRect);
var
select: boolean;
res: TRect;
begin
select := IntersectRect(res, lb.BoundsRect, r);
if select and (lb.Color = clNavy) then Exit;
if select then
begin
lb.Color := clNavy;
lb.Font.Color := clWhite;
end
else
begin
lb.Color := clBtnFace;
lb.Font.Color := clBlack;
end;
end;
var i: integer;
begin
if not Selecting then Exit;
DrawRect;
NormalRect(FirstPoint, Point(X, Y));
for i := 0 to Form1.ComponentCount - 1 do
if (Form1.Components[i] is TLabel) then
SelectLebel(Form1.Components[i] as TLabel, sel);
Application.ProcessMessages;
DrawRect;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (not Selecting) or (Button <> mbLeft) then Exit;
NormalRect(FirstPoint, Point(X, Y));
DrawRect;
ReleaseCapture;
Selecting := false;
end;
Взято с Vingrad.ru
Как сделать выравнивание по правому краю в TEdit?
Как сделать выравнивание по правому краю в TEdit?
type
TNumEdit = class(TEdit)
procedure CreateParams(var Params: TCreateParams); override;
.......
procedure TNumEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
end;
Автор ответа: МММ
Взято с Vingrad.ru
{ Пример TEdit с правым выравниванием
© Song }
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
{ Обявляем класс нашего едита как потомок от стандартного}
type TMySuperEdit=class(TCustomEdit)
public
{ Внутри класса переопредялем процедуру CreateParams,
т.к. нужный нам стиль можно изменить только на создании или пересоздании
окна }
Procedure CreateParams(Var Params: TCreateParams); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
Procedure TMySuperEdit.CreateParams(Var Params: TCreateParams);
Begin
{ Вызываем родительский обработчик, чтобы он сделал все процедуры по созданию объекта класса }
inherited CreateParams(Params);
{ Изменяем стиль }
With Params Do Style:=Style or ES_RIGHT;
End;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Создаём едит на основе нашего класса и кладём его на форму }
With TMySuperEdit.Create(Self) Do Parent:=Self;
end;
Автор:
Song
Взято из
Идея заключается в том, как сделать правое выравнивание текста в TEdit, не прибегая к написанию нового компонента.
Для этого можно воспользоваться канвасом. Так как TEdit не имеет канваса, то сперва мы создадим TControlCanvas а затем, прикрепим TEdit к этому канвасу.
Теперь нам доступны все свойства и методы TControlCanvas, поэтому мы спокойно можем настраивать в нём текст. Ниже приведёна процедура, реализующая всё вышесказанное.
procedure RJustifyEdit(var ThisEdit : TEdit);
var
Left, Width : Integer;
GString : String;
Rgn : TRect;
TheCanvas : TControlCanvas;
begin
TheCanvas := TControlCanvas.Create;
try
TheCanvas.Control := ThisEdit;
GString := ThisEdit.Text;
Rgn := ThisEdit.ClientRect;
TheCanvas.FillRect(Rgn);
Width := TheCanvas.TextWidth(GString);
Left := Rgn.Right - Width - 1;
TheCanvas.TextRect(Rgn, Left, 0, GString);
finally
TheCanvas.Free;
end ;
end;
Взято с Исходников.ru
Как сделать WebBrowser плоским вместо 3D?
Как сделать WebBrowser плоским вместо 3D?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
Следующий пример устанавливает borderStyle:
procedure TForm1.WBDocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
Doc : IHTMLDocument2;
Element : IHTMLElement;
begin
Doc := IHTMLDocument2(TWebBrowser(Sender).Document);
if Doc = nil then Exit;
Element := Doc.body;
if Element = nil then Exit;
case Make_Flat of
TRUE : Element.style.borderStyle := 'none';
FALSE : Element.style.borderStyle := '';
end;
end;
Автор: Donovan J. Edye
Как сделать wipe эффект
Как сделать wipe эффект
unitClockWipe;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls;
type
TPkt = array[0..361] of TPoint;
type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Button1: TButton;
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
procedure ClockWipe(re: TRect; Bmp: TBitmap);
procedure SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
function GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
public
{ Public Declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Canvas.Draw(0, 0, Image1.Picture.Bitmap);
ClockWipe(Image2.Picture.Bitmap.Canvas.ClipRect, Image2.Picture.Bitmap);
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Draw(0, 0, Image1.Picture.Bitmap);
end;
procedure TForm1.ClockWipe(re: TRect; Bmp: TBitmap);
var
radius, winkel, cv: Integer;
cP: TPoint;
Pkt: TPkt;
begin
radius := Round(Sqrt(Sqr((re.right - re.left) div 2) + Sqr((re.bottom - re.top) div 2)));
cP := Point((re.right - re.left) div 2, (re.bottom - re.top) div 2);
Pkt[0] := cP;
for winkel := 0 to 360 do
Pkt[winkel + 1] := GetArcPoint(cP, radius, winkel + 90);
for cv := 0 to 361 do
if (cv - 1) / 20 = (cv - 1) div 20 then
begin
Sleep(50);
SetPolygonRegion(Pkt, cv + 1, Image2.Picture.Bitmap);
end;
end;
procedure TForm1.SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
var
Region: HRGN;
begin
Region := CreatePolygonRGN(Pkt, PktCount, WINDING);
if Region <> 0 then
begin
SelectClipRgn(Canvas.handle, Region);
Canvas.Draw(0, 0, Bmp);
SelectClipRgn(Canvas.handle, 0);
DeleteObject(Region);
end;
end;
function TForm1.GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
begin
result.x := Round(cPoint.x + radius * Cos(winkel * 2 * pi / 360));
result.y := Round(cPoint.y - radius * Sin(winkel * 2 * pi / 360));
end;
end.
Взято с
Delphi Knowledge BaseКак сгенерировать свою ошибку?
Как сгенерировать свою ошибку?
raiseException.Create('Это моя ошибка! Сам что хочу то и пишу здесь!')
Примечание:
в отличие от других объектов, объекты типа Exception или других классов, наследованных от Exception не требуют вызова деструкторов или любых других действий по освобождению памяти посли их создания.Автор Vit
Как шифровать файлы при помощи windows NTFS API?
Как шифровать файлы при помощи windows NTFS API?
{....}
{
Dieser Tip funktioniert ab Windows 2000 (NTFS 5)
Diese 2 Funktionen sind in windows.pas definiert, jedoch sind sie dort
falsch definiert. Deshalb hier die eigene Definition.
}
{
This tip works with Windows 2000 (NTFS 5) and later
These 2 functions are defined in windows.pas, but they're defined wrong. In this
case our own definition.
}
function EncryptFile(lpFilename: PChar): BOOL; stdcall;
external advapi32 name 'EncryptFileA';
function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall;
external advapi32 name 'DecryptFileA';
{....}
procedure TForm1.Button1Click(Sender: TObject);
begin
if not EncryptFile('c:\temp') then
ShowMessage('Cannot encrypt directory.');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if not DecryptFile('c:\temp', 0) then
ShowMessage('Cannot decrypt directory.');
end;
Взято с сайта
Как синхронизировать время на 2х компьютерах?
Как синхронизировать время на 2х компьютерах?
WinExec('nettime \\nts2 /set /yes',SW_HIDE);
Взято с
Как система создаёт объект СОМ
Как система создаёт объект СОМ
Итак, давайте посмотрим как система создает СОМ объект. (Все, что написанно далее про создание СОМ объекта, не является стандартом СOM, а является поддержкой работы COM системой. То есть так поддержка реализованна в Windows. В других системах поддержка COM (если вы ее там найдете) может быть реализована по другому.) Наиболее часто используемая API функция в Windows для создания СОМ объекта это CoCreateInstance (все названия функций Win API для работы с СОМ имеют префикс Со). Выглядит она так:
STDAPI CoCreateInstance(
REFCLSID rclsid,
LPUNKNOWN pUnkOuter,
DWORD dwClsContext,
REFIID riid,
LPVOID * ppv
);
Давайте запишим ее в паскалевском виде, и прокомментируем:
function CoCreateInstance(
const clsid: TCLSID; //Индификатор класса объект которого мы хотим создать (это, как всегда, GUID)
unkOuter: IUnknown; //указатель на интерфейс агрегирующего объекта (агрегирование мы рассматривать пока не будем поэтому он у нас будет nil)
dwClsContext: Longint; //контекст в котором объект должен быть создан объект
const iid: TIID; //индификатор интерфейса который мы хотим получить (это тоже GUID)
out pv //переменная в которую будет записан полученный интерфейс
): HResult; stdcall;
Параметр dwClsContext указывает как должен быть создан объект. Если мы хотим создавать наш калькулятор c помощью CoCreateInstance этот параметр будет равен CLSCTX_INPROC_SERVER, то есть внутрипроцессорный сервер, так как наш объект находиться внутри dll и не может работать как отдельный процесс. Значит создание нашего объекта будет выглядеть примерно так:
var
Calc:ICalc;
begin
CoCreateInstance({GUID нашего класса которого у наc пока нет},nil,CLSCTX_INPROC_SERVER,ICalc,Calc);
...
end;
Итак у нас нет GUID нашего класса. Ну, его придумать не проблема, нажал в Delphi Ctrl+Shift+G и GUID готов (особо крутые программисты могут написать свою программку генерации GUID, которая будет сосотоять из одного вызова API функции СoCreateGUID или UuidCreate). А как система узнает о том, что этот GUID пренадлижит нашему классу? Правильно, пора заглянуть в реестр.Открываем ключ HKEY_CLASSES_ROOT\CLSID и видим длинный список GUID'ов. Именно в этом списке находятся все GUID зарегистрированных COM классов (GUID классов чаще называют CLSID - Class ID).При вызове CoCreateInstance в этом списке ищется тот GUID который равен параметру CLSID и если он находиться, то рассматривается параметр dwClsContext, и в соответсвии с ним ищется следующий подключ:
если dwClsContext=CLSCTX_INPROC_SERVER ищется подключ InprocServer32
если dwClsContext=CLSCTX_INPROC_HANDLER ищется подключ InprocHandler32
если dwClsContext=CLSCTX_LOCAL_SERVER ищется подключ LocalServer32
и если он существует, то значение этого ключа будет указывать путь к модулю в котором находиться исполняемый код класса.
Итак, чтобы зарегестрировать наш класс, нужно создать новый GUID (пусть это будет {2563AE40-AC27-11D6-A5C2-444553540000} ) и создать в реестре новый раздел HKEY_CLASSES_ROOT\CLSID\{2563AE40-AC27-11D6-A5C2-444553540000}, а в нем создать еще один подраздел InprocServer32 и в значение по умолчанию записать путь к нашей dll, у меня это C:\Kir\COM\SymplDll\CalcDll.dll. Отлично, теперь система знает где искать наш класс. Теперь давайте посмотрим как она этот класс создает.
А создает она его так (сейчас мы говорим только о in-proc сервере).Найденная библиотека(dll) с классом загружается в память и в ней вызывается функция DllGetClassObject! Вот основная функция которую наша библиотека должна содержать, и через которую система и создает COM объект. Как она выглядит и что она должна делать? Выглядит она вот так:
function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
а делать она должна то, что делает сейчас наша функция CreateObject - создавать класс.
По сравнению с CreateObject добавляется еще один параметр CLSID, так как библиотека может содержать больше чем один класс, то этот параметр указывает объект какого класса нужно создать. Если параметр CLSID содержит неизвестный нашей библиотеке GUID то функция должна вернуть CLASS_E_CLASSNOTAVAILABLE.
Давайте перепишим наш CreateObject на DllGetClassObject:
function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
var
Calc:MyCalc;
begin
if GUIDToString(CLSID)<>'{2563AE40-AC27-11D6-A5C2-444553540000}' {GUID нашего класса} then
begin
Result:=CLASS_E_CLASSNOTAVAILABLE;
exit;
end;
Calc:=MyCalc.Create;
if not Calc.GetInterface(IID,Obj) then
begin
Result:=E_NOINTERFACE;
Calc.Free;
exit;
end;
Result:=S_OK;
end;
exports
// Не забыть добавить в список экспорта!
DllGetClassObject;
Итак, первой строчкой проверяем, является ли спрашевыемый индификатор класса(CLSID) индификатором нашего класса, который мы недавно придумали, с помощю Delphi, а далее как было раньше, пытаемся записать в переменную Obj указатель на интерфейс того интерфейса, GUID которого был нам передан в качестве параметра IID. Если такой интерфейс нашим классом не поддерживается, освобождаем объект и возвращаем ошибку. Если же все нормально, возвращаем S_OK, а в выходном параметре Obj будет находиться указатель на спрашиваемый интерфейс.
Так же перепишим в тестере процедуру, где мы создаем наш COM калькулятор - это TForm1.FormCreate:
procedure TForm1.FormCreate(Sender: TObject);
begin
ICalcGUID:=StringToGUID('{149D0FC0-43FE-11D6-A1F0-444553540000}');
ICalc2GUID:=StringToGUID('{D79C6DC0-44B9-11D6-A1F0-444553540000}');
flag:=true;
if СoCreateInstance(StringTOGUID('{2563AE40-AC27-11D6-A5C2-444553540000}'),nil,CLSCTX_INPROC_SERVER,ICalcGUID,Calc)=S_OK then
Calc.SetOperands(10,5)
else
begin
ShowMessage('Failed to create Calc');
Close;
end;
end;
Как вы видите, мы не загружаем здесь библиотеку в память, чтобы потом вызвать из нее соответсвующую функцию для создания объекта, а перепоручаем всю эту работу CoCreateInstance.
В качестве индификатора класса мы передаем GUID нашего класса, а в касечтве индификатора интерфейса передаем GUID интерфейса ICalc. Ну а сам указатель на интерфейс должен записаться в переменную Calc.
Ну все. Все готово, теперь все компилируем и запускаем... Объект не создается! CoCreateInstance возвращает REGDB_E_CLASSNOTREG - класс не зарегестрирован. Но на самом деле ошибка не в том, что класс не зарегестрирован. А в чем? Давайте пройдемся пошагово по нашей dll. Поставим брекпойнт на первую линию функции DllGetClassObject. Мы видим, что эта функция вызывается, что CLSID соответсвует GUID нашего класса, что сам объект создается, но что дальше? Метод GetInterface не находит спрашеваемого интерфейса! Посмотрите чему равен параметр IID и вы увидите, что он не равен GUID интерфейса ICalc, который мы передавали CoCreateInstance, а равен он вот такому значению: {00000001-0000-0000-C000-000000000046}. Можно заглянуть в реестр Windows, чтобы узнать, что интерфейс с таким GUID носит название IClassFactory. Что ж, выходит CoCreateInstance просит не тот интерфейс, который мы предаем ей как параметр. Microsoft не скрывает реализацию CoCreateInstance - это, на самом деле, всего лишь вспомогательная функция и делает она следующее (вольный перевод на Delphi):
function CoCreateInstance(const clsid: TCLSID;unkOuter: IUnknown;dwClsContext: Longint; const IID: TIID; out pv): HResult; stdcall;
var
p:IClassFactory;
begin
CoGetClassObject(CLSID, dwClsContext, nil, IClassFactory,p);
Result = p.CreateInstance(unkOuter, IID, pv);
end;
Первой строчкой вызывается API функция CoGetClassObject, параметры у нее точно такие же как у CoCreateInstance, и как раз она является основной функцией - она находит библиотеку с классом и вызывает DllGetClassObject (опять же, это все для in-proc серверов). И как видите, она действительно просит интерфейс IClassFactory. Что бы понять, что делает следующая строчка, нужно рассмотреть еще один офицальный и широко известный интерфейс IClassFactory.
Как сэкономить память в Ваших программах
Как сэкономить память в Ваших программах
Автор: Diego Jones
Совместимость: Delphi 4.x (или выше)
Обычно, когда класс располагается в памяти, то между полями остаются небольшие пространства, несодержащие никакой информации. Оказывается можно избавиться от таких участков памяти и соответственно Ваше приложение будет меньше расходовать оперативной памяти.
Но сначала обратимся к основам типов данных, используемых в Delphi, и детально рассмотрим - сколько байт памяти занимает каждый тип данных:
·boolean, char and byte = 1 байт
·smallInt, word, wordbool = 2 байт
·string, pointers, longint, integer = 4 байт
Теперь давайте посмотрим на объявление класса в нашем исходном коде:
TMyClass = class
private
field1: char;
field2: longint;
field3: boolean;
field4: string;
field5: byte;
field6: integer;
public
procedure proc1;
end;
теперь просуммируем байты, которы занимает каждый тип данных. По идее должно получиться 15 байт, но на самом деле это не так. Реальный размер, занимаемый данным экземпляром класса будет составлять 24 байта, т. е. 4 байта на каждое поле. Почему ? Потому что поумолчанию в Delphi, по правилам оптимизации, каждое поле располагается от предыдущего со сдвигом на 4 байта: field1 занимает 1 байт, поидее поле field2 должно следовать сразу же за field1, но по правилам оптимизации, остаются 3 байта не содержащие никакой информации, а следовательно напрасно потерянные. А если бы field2 был бы длиной в 1 байт или 2 байта, то он был бы помещён сразу же за полем field1, потому что это не нарушает правил оптимизации.
Какой же напрашивается вывод ? А если изменить порядок объявления переменных в классе ? Я просто сгруппировал переменные по их размеру (байтовому): вместе все однобайтовые, соответственно вместе все двухбайтовые и т.д.
Вот так стал выглядеть наш класс:
TMyClass = class
private
field1: char;
field3: boolean;
field5: byte;
field2: longint;
field4: string;
field6: integer;
public
procedure proc1;
end;
С такой организацией классы, его длина стала 16 байт (сэкономили 8 байт на каждом экземпляре данного класса). Конечно же это не большая экономия памяти, но в тех случая, когда класс инициализируется многократно либо класс довольно велик, то такая экономия довольно ощутима.
Взято с Исходников.ru
Как скачать любой URL используя стандартные настройки сети?
Как скачать любой URL используя стандартные настройки сети?
Начиная с Internet Explorer 3, Microsoft поддерживает очень полезные API, Wininet. Эти функции позволяют использовать все возможности IE, такие как настройки прокси, кэширование файлов и т.д.
Ниже приведён пример использования этих функций для скачивания файла с нужного URL. Это может быть любой доступный URL, ftp://, http://, gopher://, и т.д.
Более подробную информацию об этих функция можно посмотреть в MSDN - Win32 Internet API Functions.
function DownloadFile(const Url: string): string;
var
NetHandle: HINTERNET;
UrlHandle: HINTERNET;
Buffer: array[0..1024] of char;
BytesRead: cardinal;
begin
Result := '';
NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if Assigned(NetHandle) then
begin
UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
if Assigned(UrlHandle) then
{ UrlHandle правильный? Начинаем загрузку }
begin
FillChar(Buffer, SizeOf(Buffer), 0);
repeat
Result := Result + Buffer;
FillChar(Buffer, SizeOf(Buffer), 0);
InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
until BytesRead = 0;
InternetCloseHandle(UrlHandle);
end
else
begin
{ UrlHandle неправильный. Генерируем исключительную ситуацию. }
raise Exception.CreateFmt('Cannot open URL %s', [Url]);
end;
InternetCloseHandle(NetHandle);
end
else
{ NetHandle недопустимый. Генерируем исключительную ситуацию }
raise Exception.Create('Unable to initialize Wininet');
end;
Взято с Исходников.ru
Как скопировать данные между БД?
Как скопировать данные между БД?
Такая возможность присуствует в IB 4.0, 4.1 (утилита QLI) однако отсутствует в IB 4.2 и 5.x. В простейшем случае можно обойтись утилитами DATAPUMP или Database Desktop. Также большое количество подобных утилит есть на www.ibase.ru/download.htm. В конце-концов, можно достаточно быстро самому написать программу копирования данных.
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оставитель: Дмитрий Кузьменко
Как скопировать директорию?
Как скопировать директорию?
Использовать ShFileOperation
procedure TForm1.Button2Click(Sender: TObject);
var OpStruc: TSHFileOpStruct;
frombuf, tobuf: Array [0..128] of Char;
begin FillChar( frombuf, Sizeof(frombuf), 0 );
FillChar( tobuf, Sizeof(tobuf), 0 );
StrPCopy( frombuf, 'd:\brief\*.*' );
StrPCopy( tobuf, 'd:\temp\brief' );
with OpStruc do begin
Wnd := Handle;
wFunc := FO_COPY;
pFrom := @frombuf;
pTo := @tobuf;
fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted := False;
hNameMappings := Nil;
lpszProgressTitle := Nil;
end;
ShFileOperation( OpStruc );
end;
Взято с сайта
Как скопировать файл в Windows clipboard?
Как скопировать файл в Windows clipboard?
uses
ShlObj, ClipBrd;
procedure CopyFilesToClipboard(FileList: string);
var
DropFiles: PDropFiles;
hGlobal: THandle;
iLen: Integer;
begin
iLen := Length(FileList) + 2;
FileList := FileList + #0#0;
hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
SizeOf(TDropFiles) + iLen);
if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');
begin
DropFiles := GlobalLock(hGlobal);
DropFiles^.pFiles := SizeOf(TDropFiles);
Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);
GlobalUnlock(hGlobal);
Clipboard.SetAsHandle(CF_HDROP, hGlobal);
end;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat');
end;
{
Separate the files with a #0.
Dateien mit einem #0 trennen.
}
Взято с сайта
Как скопировать содержимое одного RichEdit в другой?
Как скопировать содержимое одного RichEdit в другой?
TMemoryStream это самый простой инструмент взаимодействия между всеми VCL компонентами:
procedure TForm1.Button1Click(Sender: TObject);
var
MemoryStream:TMemoryStream;
begin
MemoryStream:=TMemoryStream.Create;
try
RichEdit1.Lines.SaveToStream(MemoryStream);
MemoryStream.Seek(0,soFromBeginning);
RichEdit2.Lines.LoadFromStream(MemoryStream);
finally
MemoryStream.Free;
end;
end;
Взято с Исходников.ru
Как скопировать содержимое строки в буфер обмена?
Как скопировать содержимое строки в буфер обмена?
procedureCopyStringToClipboard(s: string);
var
hg: THandle;
P: PChar;
begin
hg:=GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1);
P:=GlobalLock(hg);
StrPCopy(P, s);
GlobalUnlock(hg);
OpenClipboard(Application.Handle);
SetClipboardData(CF_TEXT, hg);
CloseClipboard;
GlobalFree(hg);
end;
Взято с
Как скопировать страницу?
Как скопировать страницу?
{... }
var
After: OleVariant;
Sh: _Worksheet;
begin
Sh := Excel.Worksheets['Sheet1'] as _Worksheet;
After := Excel.Workbooks[1].Sheets[3];
Sh.Copy(EmptyParam, After, lcid);
{ ... }
Взято с
Delphi Knowledge BaseКак скопировать структуру таблицы?
Как скопировать структуру таблицы?
{
As we know, Paradox Tables consist in a table file and some corresponding index files
there are many way to copy them:
1. Using TBatchMover (at DataAccess Pallete) with Mode : BatCopy
But you can't copy the tables corresponding index files, TBatchMove just
copies the structure and data.
2. Using FileCopy
But you can't copy the tables corresponding index files automatically,
you should define each files
.. and many more
The Simple way is:
Put two TTables on your form, name it as tbSource and tbTarget.
Then, put this procedure under implementation area
}
type
TForm1 = class(TForm)
tbSource: TTable;
tbTarget: TTable;
// ...
end;
implementation
procedure TForm1.Button1Click(Sender: TObject);
begin
tbSource.TableName := 'Source.DB'; // The name of your tables which you want to copy from
tbTarget.TableName := 'Target.DB'; // The name of your tables which you will to copy to
// You Can set the tbSource.DataBaseName to an existing path/Alias
// where you store your DB
// You Can set the tbTarget.DataBaseName to an existing path/Alias
// where you want to store the duplicate DB
tbSource.StoreDefs := True;
tbTarget.StoreDefs := True;
tbSource.FieldDefs.Update;
tbSource.IndexDefs.Update;
tbTarget.FieldDefs := tbSource.FieldDefs;
tbTarget.IndexDefs := tbSource.IndexDefs;
tbTarget.CreateTable;
//Actually you can set these code up to only 5 lines :)
end;
End.
Взято с сайта
Как скопировать таблицу из одной базы данных в другую?
Как скопировать таблицу из одной базы данных в другую?
f I am not wrong you have an Access db with multiple tables and you want to copy one of these tables into another Access db. For this case i would do the next:
1.Create database TrasportDB.mdb - use ADOX.
2. Copy table from source table into TransportDB.mdb with Select * Into [TransportTable] in "FullPath\TransportDB.mdb" From SourceTable.
3. Deliver TransportDB.mdb on destination computer.
4. Copy table from TransportTable into DestTable with Select * Into [DestTable] From [TransportTable] in "FullPath\TransportDB.mdb".
FullPath is the path to TransportDB.mdb and is different on source and dest computers.
This way you will use native access methods that should be more reliable and faster than using ADO methods. If you need to perform more complete tasks you should use replication from Microsoft Jet and Replication objects (import this typelib).
Взято с
Delphi Knowledge BaseКак скрыть часики в панели задач?
Как скрыть часики в панели задач?
Убираем часики:
procedure TForm1.Button1Click(Sender: TObject);
var hn: HWnd;
begin
hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil); //die Uhr
if hn <> 0 then
ShowWindow(hn, SW_HIDE); //Bye,bye,Baby
end;
Снова показываем:
procedure TForm1.Button2Click(Sender: TObject);
var hn: HWnd;
begin
hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil);
if hn <> 0 then
ShowWindow(hn, SW_SHOW); //Hello, again
end;
Взято с Исходников.ru
Как скрыть кнопку [х] в заголовке окна?
Как скрыть кнопку [х] в заголовке окна?
Автор: Fernando Silva
Пример показывает, как при инициализации формы происходит поиск нашего окна, а затем вычисление местоположения нужной нам кнопки в заголовке окна.
procedure TForm1.FormCreate(Sender: TObject);
var
hwndHandle: THANDLE;
hMenuHandle: HMENU;
iPos: Integer;
begin
hwndHandle := FindWindow(nil, PChar(Caption));
if (hwndHandle <> 0) then
begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
begin
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
iPos := GetMenuItemCount(hMenuHandle);
Dec(iPos);
{ Надо быть уверенным, что нет ошибки т.к. -1 указывает на ошибку }
if iPos > -1 then
DeleteMenu(hMenuHandle, iPos, MF_BYPOSITION);
end;
end;
end;
Взято с Исходников.ru
Как скрыть контекстное меню TWebbrowser?
Как скрыть контекстное меню TWebbrowser?
var
HookID: THandle;
function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
var
szClassName: array[0..255] of Char;
const
ie_name = 'Internet Explorer_Server';
begin
case nCode < 0 of
True:
Result := CallNextHookEx(HookID, nCode, wParam, lParam)
else
case wParam of
WM_RBUTTONDOWN,
WM_RBUTTONUP:
begin
GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName, SizeOf(szClassName));
if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then
Result := HC_SKIP
else
Result := CallNextHookEx(HookID, nCode, wParam, lParam);
end
else
Result := CallNextHookEx(HookID, nCode, wParam, lParam);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId());
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if HookID <> 0 then
UnHookWindowsHookEx(HookID);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('http://www.google.com');
end;
Взято с сайта
Как скрыть / показать иконки на рабочем столе?
Как скрыть / показать иконки на рабочем столе?
procedure TForm1.Button1Click(Sender: TObject);
begin
// скрыть иконки
ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
// показать иконки
ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW);
end;
procedure ShowDesktop(const YesNo : boolean);
var h : THandle;
begin
h := FindWindow('ProgMan', nil);
h := GetWindow(h, GW_CHILD);
if YesNo = True then
ShowWindow(h, SW_SHOW)
else
ShowWindow(h, SW_HIDE);
end;
{Использование:}
{Скрыть иконки на рабочем столе}
ShowDesktop(False);
{Показать иконки на рабочем столе}
ShowDesktop(true);
Взято с Исходников.ru
Как скрыть программу от Alt - Tab
Как скрыть программу от Alt - Tab
procedureTForm1.Button1Click(Sender: TObject);
begin
ShowWindow(Handle, SW_HIDE);
ShowWindow(Application.Handle, SW_HIDE);
end;
Автор:
SongwithApplication do
begin
ShowWindow(Handle, SW_HIDE);
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
end; {With}
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
Автор:
StavrosВзято из
Как скрыть своё приложение?
Как скрыть своё приложение?
Если Вы хотет, чтобы Ваша программа не появлялась на панели задач, но форма была видна, то воспользуйтесь следующей командой:
ShowWindow (Application.handle, SW_HIDE);
Данная команда в основном используется в приложениях, которае активируются через иконку в трее.
Взято с Исходников.ru
Как скрыть свойства объекта?
Как скрыть свойства объекта?
В иерархии VCL в большинстве случаев существует уровень объектов-"предшественников" (TCustomXXXX), в которых многие свойства скрыты. Для унаследованных от таких "предшественников" объектов можно "открывать" на выбор те или иные свойства. А как можно скрыть свойства, которые объявлены в published-области от Object Inspector'а, но при этом оставить возможность доступа во время работы программы? Решение состоит в объявлении свойства "по новой" в public-области. В примере скрытым будет у объекта TMyControl свойство Height.
TMyControl = class(TWinControl)
protected
procedure SetHeight(Value: Integer);
function GetHeight: Integer;
public
property Height: Integer read GetHeight write SetHeight;
end;
procedure TMyControl.SetHeight(Value: Integer);
begin
inherited Height := Value;
end;
function TMyControl.GetHeight;
begin
Result := inherited Height;
end;
Как скрыть TaskBar?
Как скрыть TaskBar?
//Спрятать
procedure TForm1.Button1Click(Sender: TObject);
var
hTaskBar : THandle;
begin
hTaskbar := FindWindow('Shell_TrayWnd', Nil);
ShowWindow(hTaskBar, SW_HIDE);
end;
//Показать
procedure TForm1.Button2Click(Sender: TObject);
var
hTaskBar : THandle;
begin
hTaskbar := FindWindow('Shell_TrayWnd', Nil);
ShowWindow(hTaskBar, SW_SHOWNORMAL);
end;
Взято с Исходников.ru
Как сменить обои на рабочем столе?
Как сменить обои на рабочем столе?
В принципе, все настройки на фоновый рисунок хранятся в реестре. Поэтому надо сначала скопировать картинку в какое-нибудь место (лучше в каталог Виндов) на случай удаления или переноса исходного файла. Информация по обоям хранится в разделе HKEY_CURRENT_USER\Controi Panel\Desktop в параметрах TileWallpaper (если 1 - рисунок размножен, 0 - в центре), Wallpaper - путь к файлу обоев (gif, bmp, jpg), WallpaperStyle - если 2, то обои будут растянуты (отсутствует в 95 винде).
ПОсле установки всех занчений обновляешь рабочий стои и наслаждаешься эффектом.
Автор ответа: Garik
Взято с Vingrad.ru
Что-то там перемудрено, можно проще:
varWallpaper : string;
begin
Wallpaper := 'C:\windows\ACD Wallpaper.bmp';
SystemParametersInfo (SPI_SETDESKWALLPAPER, 0, PChar(Wallpaper), SPIF_SENDCHANGE)
end;
Автор p0s0l
Как сменить обои в Windows 95/NT?
Как сменить обои в Windows 95/NT?
program wallpapr;
uses Registry, WinProcs;
procedure SetWallpaper(sWallpaperBMPPath:String;bTile:boolean);
var
reg : TRegIniFile;
begin
// Изменяем ключи реестра
// HKEY_CURRENT_USER
// Control Panel\Desktop
// TileWallpaper (REG_SZ)
// Wallpaper (REG_SZ)
reg := TRegIniFile.Create('Control Panel\Desktop' );
with reg do begin
WriteString( '', 'Wallpaper',
sWallpaperBMPPath );
if( bTile )then
begin
WriteString('', 'TileWallpaper', '1' );
end else begin
WriteString('', 'TileWallpaper', '0' );
end;
end;
reg.Free;
// Оповещаем всех о том, что мы
// изменили системные настройки
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil,
{Эта строка - продолжение предыдущей}SPIF_SENDWININICHANGE );
end;
// пример установки WallPaper по центру рабочего стола
SetWallpaper('c:\winnt\winnt.bmp', False );
//Эту строчку надо написать где-то в программе.
Взято с Исходников.ru
var
Reg: TRegIniFile;
begin
Reg := TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\mybmp.bmp');
Reg.WriteString('desktop', 'TileWallpaper', '1');
Reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end
Взято с Исходников.ru
Как сменить пароль для таблицы Paradox?
Как сменить пароль для таблицы Paradox?
Нет способа сделать это в пределах Delphi VCL. Кажется, это довольно серьезное упущение. Однако, есть возможность сделать это напрямую через Borland Database Engine через интерфейс предоставляемый модулями DBIPROCS и DBITYPES. Нужно использовать DbiDoRestructure.
Copyright © 1996 Epsylon Technologies
Взято из
FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349Как сменить пароль (master password) для таблицы Paradox
Как сменить пароль (master password) для таблицы Paradox
var
db: TDatabase;
Desc: CRTblDesc;
begin
db := PriceTable.OpenDatabase;
FillChar( Desc, SizeOf( Desc ), #0 );
StrCopy( Desc.szTblName, PChar( PriceTable.TableName ) );
StrCopy( Desc.szTblType, szParadox );
StrCopy( Desc.szPassword, 'password' );
Desc.bProtected := TRUE;
Check( DbiDoRestructure( db.Handle, 1, @Desc, nil, nil, nil, FALSE ) );
end;
Автор: Nomadic
Взято из
Как снять выделение в StringGrid?
Как снять выделение в StringGrid?
Если Вы хотете избавиться от выделенных ячеек TStringGrid, которые не имеют фокуса либо используются только для отображения данных, то попробуйте воспользоваться следующей небольшой процедурой.
procedure TForm1.GridClean(Sender: TObject);
var hGridRect: TGridRect;
begin
hGridRect.Top := -1;
hGridRect.Left := -1;
hGridRect.Right := -1;
hGridRect.Bottom := -1;
(Sender as TStringgrid).Selection := hGridRect;
end;
Следующий код можно использовать например в событии грида OnExit:
var MyGrid: TStringGrid;
...
GridClean(MyGrid);
Взято с Исходников.ru
Как сохранить исходник HTML из TWebBrowser.Document на диск?
Как сохранить исходник HTML из TWebBrowser.Document на диск?
TWebBrowser.Document включает в себя IPersistStreamInit который содержит метод Save(). Всё, что нам нужно знать, это как использовать данный метод с объектом, который включён в IStream. Для этого мы просто воспользуемся TStreamAdapter.
Обратите внимание, что интерфейсы IPersistStreamInit и IStream объявлены внутри ActiveX unit.
Итак, вот так это выглядит.
procedure TForm1.SaveHTMLSourceToFile(const FileName: string;
WB: TWebBrowser);
var
PersistStream: IPersistStreamInit;
FileStream: TFileStream;
Stream: IStream;
SaveResult: HRESULT;
begin
PersistStream := WB.Document as IPersistStreamInit;
FileStream := TFileStream.Create(FileName, fmCreate);
try
Stream := TStreamAdapter.Create(FileStream, soReference) as IStream;
SaveResult := PersistStream.Save(Stream, True);
if FAILED(SaveResult) then
MessageBox(Handle, 'Fail to save HTML source', 'Error', 0);
finally
{ В ответ на уничтожение объекта TFileStream, передаём
soReference в конструктор TStreamAdapter. }
FileStream.Free;
end;
end;
pocedure TForm1.Button1Click(Sender: TObject);
begin
if SaveDialog1.Execute then
SaveHTMLSourceToFile(SaveDialog1.FileName, WebBrowser1);
end;
А как сохранить вместе с исходником все файлы (.CSS, JPG, GIF Etc..) ?
try
WebBrowser1.ExecWB(4, 0);
except
on E: Exception do msError:=true;
end;
Взято с Исходников.ru