Как открыть HTML-файл в стандартном браузере?
Как открыть HTML-файл в стандартном браузере?
//-------------------------------------------------------------
// HTMLView - пример, показывающий, как открыть HTM/HTML файл в браузере,
// установленном поумолчанию.
// Пример использует Win32API функцию ShellExecute с параметром 'open',
// которая заставляет систему найти в реестре приложение, связанное
// с расширением HTM/HTML.
//-------------------------------------------------------------
unit HTMLUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ShellAPI;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
Button1: TButton;
Button2: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1 : TForm1;
HTMLFile : Array[0..79] of Char;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
If OpenDialog1.Execute then
begin
// получаем имя выбранного файла
StrPCopy(HTMLFile, OpenDialog1.FileName);
// разрешаем пользователю открывать (т.е. просматривать) его в браузере
Button2.Enabled := True;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
// запускаем функцию ShellExecute с параметром 'open'
ShellExecute(Handle, 'open', HTMLFile, nil, nil, SW_SHOWNORMAL);
end;
end.
Взято с Исходников.ru
Как открыть меню кнопки Пуск?
Как открыть меню кнопки Пуск?
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(Self.Handle, WM_SYSCOMMAND, SC_TASKLIST, 0);
end;
Взято с Исходников.ru
Как открыть окно настройки даты и времени Windows?
Как открыть окно настройки даты и времени Windows?
Shellexecute(handle, 'Open', 'Rundll32.exe', 'shell32.dll,Control_RunDLL TIMEDATE.CPL', Pchar(Getsystemdir), 0);
Автор ответа: Vit
Взято с Vingrad.ru
Как открыть первую ветвь TreeView?
Как открыть первую ветвь TreeView?
Как программным путем открыть первую ветвь и в ней выделить первый элемент?
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.Items[0].Expand(False);
TreeView1.Items[0].Selected:=true;
TreeView1.SetFocus;
end;
Автор ответа: Vit
Взято с Vingrad.ru
Как отлаживать консольные приложения?
Как отлаживать консольные приложения?
As with Delphi you can use Kylix to write console applications even though many
people think that's not important. ;-)
When you start a console program in the Delphi Debugger it automatically opens
a console window ("DOS command prompt") where you can see the output of e.g.
the writeln command.
Kylix doesn't do that automatically and if you don't look hard enough you might
think it is impossible to debug console applications with it.
But if you open the run / parameters dialog you will find an entry called
"Use Launcher Application" that is prefilled with xconsole. Just tick this
option and there you go.
Взято с сайта
Как отличить нажат правый или левый SHIFT?
Как отличить нажат правый или левый SHIFT?
if ((Word(GetKeyState(VK_LSHIFT)) and $8000) <> 0) then
begin
end;
if ((Word(GetKeyState(VK_RSHIFT)) and $8000) <> 0) then
begin
end;
работает под Win NT/2000, но не работает под Win95.
Автор ответа: CHERRY
Взято с Vingrad.ru
В 95 катит следующее:
RSHIFT = 36h
LSHIFT = 2Ah
asm
in al, 60h
cmp al, 36h
jne @@exit
mov tt,1
@@exit:
end;
if tt = 1 then ShowMessage ('Right Shift');
Автор ответа: Baa
Взято с Vingrad.ru
Как отловить CLX форму?
Как отловить CLX форму?
{
Capturing a CLX form is easy, once you know.
It took me a little time to find out, so I'm giving the knowledge to help others :
}
type
TFormCapturable = class(TForm)
public
procedure PrintOne;
end;
var
FormCapturable: TFormCapturable;
implementation
uses
Qt;
procedure TFormCapturable.PrintOne;
var
aBitmap : TBitmap;
aWinHandle : QWidgetH;
aWinId : Cardinal;
x, y, w, h : integer;
begin
// create a new bitmap to hold the captured screen
aBitMap := TBitmap.Create;
try
// get a handle on the desktop
aWinHandle := QApplication_desktop;
// get the Id from the desktop handle
aWinId := QWidget_winId( aWinHandle);
// get the position and size of the windows
x := Self.Left;
y := Self.Top;
w := Self.Width;
h := Self.Height;
// capture the window into the bitmap's pixmap
QPixmap_grabWindow( aBitmap.Handle, aWinId, x, y, w, h);
// save the bitmap
aBitMap.SaveToFile( 'c:\temp\test.bmp');
finally
// don't forget to kill the bitmap after use.
FreeAndNil( aBitMap);
end;
end;
Взято с сайта
Как отловить изменение раскладки клавиатуры?
Как отловить изменение раскладки клавиатуры?
Автор: InSAn
Нужно ловить сообщение WM_INPUTLANGCHANGEREQUEST
Взято с Исходников.ru
Как отловить ошибку?
Как отловить ошибку?
Try
{здесь вы пишите код в котором может произойти ошибка}
Except
{здесь вы пишите код который выполнится если ошибка произойдёт, если ошибки не будет то этот код не выполняется}
End
Вот как будет выполнятся код:
[Line 1]
Try
[Line 2]
[Line 3]
[Line 4]
Except
[Line 5]
End
[Line 6]
Допустим что [Line x] это строка какого-то Вашего кода. Предположим что при выполнении [Line 3] произошла ошибка, тогда программа будет выполнять строки:
1-2-3(ошибка!)-5-6
Если ошибки нет то будут выполнятся следующие линии кода:
1-2-3-4-6
Если надо чтобы ошибка произошла, но перед этим Вы хотите выполнить некие свои действия, то организовать это можно следующим способом:
Try
{здесь вы пишите код в котором может произойти ошибка}
Except
{здесь вы пишите код который выполнится если ошибка произойдёт, если ошибки не будет то этот код не выполняется}
raise;// вызвать вновь ту же ошибку
End
Автор Vit
Как отловить правый Enter (NumPad)?
Как отловить правый Enter (NumPad)?
Автор: Full ( http://full.hotmail.ru/ )
Для этого можно воспользоваться функцией GetHeapStatus:
procedure TForm1.WMKeyDown(var Message: TWMKeyDown);
begin
inherited;
case Message.CharCode of
VK_RETURN:
begin // ENTER pressed
if (Message.KeyData and $1000000 <> 0) then
begin
{ ENTER on numeric keypad }
end
else
begin
{ ENTER on the standard keyboard }
end;
end;
end;
end;
Взято с Исходников.ru
Как отловить смену фокуса для всех контролов?
Как отловить смену фокуса для всех контролов?
procedure TForm1.ActiveControlChange(Sender: TObject);
begin
Caption := TScreen(Sender).ActiveForm.ActiveControl.Name;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.OnActiveControlChange := ActiveControlChange;
end;
Прислал p0s0l
Как отобразить hint в TLabel?
Как отобразить hint в TLabel?
На форме лежат TEdit, TCheckBox и TLabel. Я бы хотел, чтобы при наведении на TEdit или TCheckBox в TLabel отображалась "подсказка". Т.е. своего рода hint, но только отображаемый в TLabel. Как такое можно сотворить?
Такое поведение Hint в VCL предусмотренно:
procedure TForm1.DisplayHint(Sender: TObject);
begin
Label1.caption := GetLongHint(Application.Hint);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnHint := DisplayHint;
end;
Теперь все хинты будут показываться на метке.
Автор ответа: Vit
Взято с Vingrad.ru
Как отобразить выбранную строку DBGrid различными цветами?
Как отобразить выбранную строку DBGrid различными цветами?
Если Вы хотите раскрасить выбранную строку DBGrid, но не хотите использовать опцию dgRowSelect, так как хотели бы редактировать данные, то можно воспользоваться следующей технологией в событии DBGrid.OnDrawColumnCell:
type
TCustomDBGridCracker = class(TCustomDBGrid);
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
with Cracker(Sender) do
if DataLink.ActiveRecord = Row - 1 then
Canvas.Brush.Color := clRed
else
Canvas.Brush.Color := clWhite;
DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
Взято с Исходников.ru
Как отправить бинарные данные из CGI приложения?
Как отправить бинарные данные из CGI приложения?
Не для кого не секрет, как просто можно получать данные различного типа из CGI приложения. Однако, иногда необходимо, чтобы данные сохранялись в виде файла с определённым именем, типа "Test.ZIP". Для этого необходимо добавить в заголовок HTTP пункт "Content-Disposition".
В Delphi для этого используется свойство CustomHeaders. В это TStrings свойство можно добавлять пункты в виде "name=value" - так как HTTP синтакс name:value здесь не используется.
Пример:
procedure TWebModule1.WebModule1CHECKSTATUSAction(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var s : TFileStream;
begin
s := nil;
if request.query='download' then
try
response.Title := 'Download Test.ZIP';
response.CustomHeaders.Add('Content-Disposition=filename=Test.zip');
response.ContentType := 'application/zip';
s := TFileStream.Create(fmOpenRead+fmShareDenyNone,'Test.zip');
response.contentstream := s;
response.sendresponse;
finally
s.Free;
end;
end;
Взято с Исходников.ru
Как отправить Email?
Как отправить Email?
Cущствуют следующие возможности:
1) - не позволяет автоматизировать работу, не позволяет постать письмо с аттачментом, но исключительно удобно в окнах About.
2) - несколько устаревший способ, но вполне работоспособный
3) - там все просто, однако посыка не напрямую, требуется наличие SMTP сервера, например сервера провайдера.
4) - там тоже все просто, но нужно наличие установленного и полностью подключенного Outlook
5) и отсылать email напрямую, минуя любые сервера. Для Дельфи6/Дельфи7/Kylix3 можно использовать компоненты Indy (входят в поставку Дельфи) - пример внизу, а так же можно использовать для любых версий Delphi/Kylix компоненты из пакета ICS - Internet component suite.
Автор ответа Vit
Взято с Vingrad.ru
Как отправить сообщение сразу всем элементам управления формы?
Как отправить сообщение сразу всем элементам управления формы?
Можно использовать Screen.Forms[i].BroadCast(msg); где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается.
Как отправить вебформу на сервер?
Как отправить вебформу на сервер?
Как отправить вебформу на сервер при помощи TClientSocket (напрямую и через прокси)
{
Copyright (c) 1999 by E.J.Molendijk
Присоедините следующие события к Вашему ClientSocket:
procedure T...Form.ClientSocket1Write;
procedure T...Form.ClientSocket1Read;
procedure T...Form.ClientSocket1Disconnect;
procedure T...Form.ClientSocket1Error;
Так же пример показывает, как направлять передачу через прокси-сервер.
Для отправки на вебсервер используется следующий формат:
Напрямую: 'POST ' + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
Через проксю: 'POST http://' Webserver + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
}
Const
WebServer = 'www.somehost.com';
WebPort = 80;
PostAddr = '/cgi-bin/form';
{ Следующие переменные используются только для вебсервера: }
ProxyServer ='proxy.somewhere.com';
ProxyPort = 3128;
// В заголовке post необходимы некоторые данные
HTTP_Data =
'Content-Type: application/x-www-form-urlencoded'#10+
'User-Agent: Delphi/5.0 ()'#10+ { Отрекламируем Delphi 5! }
'Host: somewhere.com'#10+
'Connection: Keep-Alive'#10;
type
T...Form = class(TForm)
...
private
{ Private declarations }
HTTP_POST : String;
FContent : String;
FResult : String; // Эта переменная будет содержать ответ сервера
public
{ Public declarations }
end;
{ Эти функции сделают некоторое url-кодирование }
{ Например. 'John Smith' => 'John+Smith' }
function HTTPTran(St : String) : String;
var i : Integer;
begin
Result:='';
for i:=1 to length(St) do
if St[i] in ['a'..'z','A'..'Z','0','1'..'9'] then
Result:=Result+St[i]
else if St[i]=' ' then
Result:=Result+'+'
else
Result:=Result+'%'+IntToHex(Byte(St[i]),2);
end;
procedure T...Form.ClientSocket1Write(Sender: TObject;
Socket: TCustomWinSocket);
begin
// Постим данные
Socket.SendText(HTTP_POST+FContent);
end;
procedure T...Form.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
begin
// Получаем результат
FResult:=FResult+Socket.ReceiveText;
end;
procedure T...Form.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
// ЗДЕСЬ МОЖНО ОБРАБОТАТЬ FResult //
end;
procedure T...Form.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
ErrorCode := 0; // Игнорируем ошибки
end;
{
А эта подпрограмма, которую можно использовать для постинга данных формы.
}
procedure T...Form.PostTheForm;
begin
// Очищаем результаты
FResult:='';
// Вы можете ввести поля формы, которые необходимы
// Вот некоторые примеры:
FContent:=
'Name='+ HTTPTran('John Smith') +'&'+
'Address='+ HTTPTran('1 Waystreet') +'&'+
'Email='+ HTTPTran('jsmith@somewhere.com') +'&'+
'B1=Submit'+
#10;
// Вычисляем длину содержимого
FContent:=
'Content-Length: '+IntToStr(Length(FContent))+#10+#10+FContent;
{-- Начало прокси ---}
{ если Вы используете прокси, то раскоментируйте этот код
ClientSocket1.Host := ProxyServer;
ClientSocket1.Port := ProxyPort;
HTTP_POST := 'POST http://'+WebServer+PostAddr+' HTTP/1.0'#10;
{--- Конец прокси ---}
{--- Начало соединения напрямую --- }
{ удалите этот код, еслы Вы будете использовать прокси }
ClientSocket1.Host := WebServer;
ClientSocket1.Port := WebPort;
HTTP_POST := 'POST '+PostAddr+' HTTP/1.0'#10;
{--- Конец соединения напрямую ---}
// Соединяем заголовок
HTTP_Post := HTTP_Post + HTTP_Data;
// Пытаемся открыть соединение
ClientSocket1.Open;
end;
Взято с Исходников.ru
Как отследить изменения дисплея?
Как отследить изменения дисплея?
Для этого необходимо создать обработчик для перехвата сообщения WM_DISPLAYCHANGE. Применяется это в тех случаях, если Ваше приложение зависит от разрешения экрана (например, приложение работает с графикой).
Дале следует пример обработчика сообщения:
type
TForm1 = class(TForm)
Button1: TButton;
private
procedure WMDisplayChange(var Message: TMessage); message WM_DISPLAYCHANGE;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMDisplayChange(var Message: TMessage);
begin
{Do Something here}
inherited;
end;
Взято с Исходников.ru
Как отследить выход мыши за пределы формы?
Как отследить выход мыши за пределы формы?
Можно через события OnMouseEnter/OnMouseLeave:
TYourObject = class(TAnyControl)
...
private
FMouseInPos : Boolean;
procedure CMMouseEnter(var AMsg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var AMsg: TMessage); message CM_MOUSELEAVE;
...
end;
implementation
procedure TYourObject.CMMouseEnter(var AMsg: TMessage);
begin
FMouseInPos := True;
Refresh;
end;
procedure TYourObject.CMMouseLeave(var AMsg: TMessage);
begin
FMouseInPos := False;
Refresh;
end;
Затем считывать параметр FMouseInPos.
Взято с сайта
Как отследить завершение работы в приложении?
Как отследить завершение работы в приложении?
Нужно отследить момент завершения Windows, и, если пользователь собирается выключить компьютер - программа должна вывести диалог запроса. Если пользователь нажимает кнопку YES - разрешаем выключение, если NO - отменяем. С помощью VCL компонентов это делается элементарно:
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
//Спрашиваем пользователя, если инициировано завершение работы.
if MessageDlg('Вы уверены?', mtConfirmation, mbYesNoCancel, 0) = mrYes
then CanClose := true //Разрешаем завершение работы.
else CanClose := false; //Nе разрешаем завершение работы.
end;
Автор ответа: Mazenrat
Взято с Vingrad.ru
Пример отслеживания завершения приложения написанного на чистом API:
program kvd;
uses
Windows,
Messages;
var
hWnd: THandle;
WndClass: TWndClass;
Msg: TMsg;
function WindowProc(hWnd: THandle; uMsg, wParam, lParam: Integer): Integer;
stdcall;
begin
Result:=0;
case uMsg of
WM_QUERYENDSESSION:
Result := integer(false);
WM_DESTROY:
PostQuitMessage(0);
else
Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
end;
end;
begin
FillChar(WndClass, SizeOf(WndClass), 0);
with WndClass do begin
hInstance := SysInit.hInstance;
lpszClassName := 'dd';
lpfnWndProc := @WindowProc;
end;
RegisterClass(WndClass);
hWnd := CreateWindow('dd', '', 0, 0, 0, 0, 0, 0, 0, hInstance, NIL);
if hWnd = 0 then
Exit;
ShowWindow(hWnd, SW_HIDE);
while GetMessage(Msg, 0, 0, 0) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
Автор ответа: Fantasist
Взято с Vingrad.ru
Как отслеживать изменение файла?
Как отслеживать изменение файла?
FindFirstChangeNotification, FindNextChangeNotification, FindCloseChangeNotification вместе с WaitForSingleObject
Автор ответа: Baa
Взято с Vingrad.ru
Как паковать базу данных?
Как паковать базу данных?
Using D6 Pro, Access XP and Jet 4.0 Sp6 - how can I compact Access files?
Answer:
This does it:
procedureTMainForm.ActionCompactAccessDBExecute(Sender: TObject);
var
JetEngine: Variant;
TempName: string;
aAccess: string;
stAccessDB: string;
SaveCursor: TCursor;
begin
stAccessDB := 'Provider = Microsoft.Jet.OLEDB.4.0;' +
'Data Source = %s;Jet OLEDB: Engine type = ';
stAccessDB := stAccessDB + '5'; {5 for Access 2000 and 4 for Access 97}
OpenDialog1.InitialDir := oSoftConfig.ApplicationPath + 'Data\';
OpenDialog1.Filter := 'MS Access (r) (*.mdb)|*.mdb';
if OpenDialog1.execute and (uppercase(ExtractFileExt
(OpenDialog1.FileName)) = '.MDB') then
begin
if MessageDlg('This process can take several minutes. Please wait till the end ' +
#13 + #10 + 'of it. Do you want to proceed? Press No to exit.', mtInformation,
[mbYes, mbNo], 0) = mrNo then
exit;
SaveCursor := screen.cursor;
screen.cursor := crHourGlass;
aAccess := OpenDialog1.FileName;
TempName := ChangeFileExt(aAccess, '.$$$');
DeleteFile(PChar(TempName));
JetEngine := CreateOleObject('JRO.JetEngine');
try
JetEngine.CompactDatabase(Format(stAccessDB, [aAccess]),
Format(stAccessDB, [TempName]));
DeleteFile(PChar(aAccess));
RenameFile(TempName, aAccess);
finally
JetEngine := Unassigned;
screen.cursor := SaveCursor;
end;
end;
end;
Important Notes:
1.1. Include the JRO_TLB unit in your uses clause.
2.2. Nobody should use or open the database during compacting.
3.3. If the compiler gives you an error on the JRO_TLB unit follow these steps:
·Using the Delphi IDE go to Project ? Import Type Library.
·Scroll down until you reach "Microsoft Jet and Replication Objects 2.1 Library".
·Click on Install button.
·Recompile a gain.
How to compact and repair MS Access 2000 (Jet Engine 4) during run time using Delphi 5?
Answer:
Usually the size of MS Access keep growing fast by time because of it's internal caching and temporary buffering, which in over whole effect the performance, space required for storing, and backing-up (if needed). The solution is to compact it from Access menus (Tools ? Database Utilities ? Compact and Repair Database) or to do that from inside your Delphi application.
function CompactAndRepair(sOldMDB: string; sNewMDB: string): Boolean;
const
sProvider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
var
oJetEng: JetEngine;
begin
sOldMDB := sProvider + 'Data Source=' + sOldMDB;
sNewMDB := sProvider + 'Data Source=' + sNewMDB;
try
oJetEng := CoJetEngine.Create;
oJetEng.CompactDatabase(sOldMDB, sNewMDB);
oJetEng := nil;
Result := True;
except
oJetEng := nil;
Result := False;
end;
end;
Example :
if CompactAndRepair('e:\Old.mdb', 'e:\New.mdb') then
ShowMessage('Successfully')
else
ShowMessage('Error…');
Important Notes:
1.1. Include the JRO_TLB unit in your uses clause.
2.2. Nobody should use or open the database during compacting.
3.3. If the compiler gives you an error on the JRO_TLB unit follow these steps:
·Using the Delphi IDE go to Project ? Import Type Library.
·Scroll down until you reach "Microsoft Jet and Replication Objects 2.1 Library".
·Click on Install button.
·Recompile a gain.
Взято с
Delphi Knowledge Baseprocedure CompactDatabase_JRO(DatabaseName:string;DestDatabaseName:string='';Password:string='');
const
Provider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
var
TempName : array[0..MAX_PATH] of Char; // имя временного файла
TempPath : string; // путь до него
Name : string;
Src,Dest : WideString;
V : Variant;
begin
try
Src := Provider + 'Data Source=' + DatabaseName;
if DestDatabaseName<>'' then
Name:=DestDatabaseName
else begin
// выходная база не указана - используем временный файл
// получаем путь для временного файла
TempPath:=ExtractFilePath(DatabaseName);
if TempPath='' Then TempPath:=GetCurrentDir;
//получаем имя временного файла
GetTempFileName(PChar(TempPath),'mdb',0,TempName);
Name:=StrPas(TempName);
end;
DeleteFile(PChar(Name));// этого файла не должно существовать :))
Dest := Provider + 'Data Source=' + Name;
if Password<>'' then begin
Src := Src + ';Jet OLEDB:Database Password=' + Password;
Dest := Dest + ';Jet OLEDB:Database Password=' + Password;
end;
V:=CreateOleObject('jro.JetEngine');
try
V.CompactDatabase(Src,Dest);// сжимаем
finally
V:=0;
end;
if DestDatabaseName='' then begin // т.к. выходная база не указана
DeleteFile(PChar(DatabaseName)); //то удаляем не упакованную базу
RenameFile(Name,DatabaseName); // и переименовываем упакованную базу
end;
except
// выдаем сообщение об исключительной ситуации
on E: Exception do ShowMessage(e.message);
end;
end;
Использование:
CompactDatabase_JRO('C:\MyDataBase\base.mdb','','123');
Автор:
ZEEВзято из
Как паковать таблицу?
Как паковать таблицу?
functiondgPackParadoxTable(Tbl: TTable; Db: TDatabase): DBIResult;
{Packs a Paradox table by calling the BDE DbiDoRestructure function. The TTable passed as the first parameter must be closed. The TDatabase passed as the second parameter must be connected.}
var
TblDesc: CRTblDesc;
begin
Result := DBIERR_NA;
FillChar(TblDesc, SizeOf(CRTblDesc), 0);
StrPCopy(TblDesc.szTblName, Tbl.TableName);
TblDesc.bPack := True;
Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil, False);
end;
Взято с
Delphi Knowledge Baseuses
DbiProcs;
with Table do
begin
OldState := Active;
Close;
Exclusive := True;
Open;
DbiPackTable(DBHandle, Handle, nil, nil, True);
{^ здесь можно добавить check()}
Close;
Exclusive := False;
Active := OldState;
{ при желании можно сохранить закладку }
end;
Nomadic
Взято из
Как передать картинку по сети через ServerSocket?
Как передать картинку по сети через ServerSocket?
Да без проблем. Звиняйте, что на сях, но, тем не менее, на Борланд сях.
Со стороны, откуда посылаем (у нас это клиент), пишем:
TFileStream* str = new TFileStream("M:\\MyFile.jpg",fmOpenRead);
//ИЛИ, если мы работаем без сохранения (тогда не создается файл)
TMemoryStream* str = new TMemoryStream ();
str->Position = 0;
Image1->Picture->Bitmap->SaveToStream(str);
//и, наконец, шлем на сервер битмап
str->Position = 0;
ClientSocket1->Socket->SendStream(str);
Обратите внимание, не забывайте перед каждой операцией с потоком устанавливать позицию в 0!!! Иначе получим не то, что хотелось бы
Ну а со стороны приема (у нас это, соответственно, серверсокет), в событии приема пишем:
int ibLen = ServerSocket1->Socket->ReceiveLength();
char* buf= new char[ibLen+1];
TMemoryStream* str = new TMemoryStream();
str->Position = 0;
ServerSocket1->Socket->ReceiveBuf((void*)buf,ibLen);
str->WriteBuffer((void*)buf,ibLen);
str->Position = 0;
Image1->Picture->Bitmap->LoadFromStream(str);
//или
str->SaveToFile("M:\\MyFile.jpg");
Ну и ессно, как говорит Bigbrother, сделал дело - вызови деструктор! То есть почистить за собой надо, не знаю как в Паскале, но в сях мне надо удалить str и buf.
Автор ответа: TwoK
Взято с Vingrad.ru
Как передать массив как параметр?
Как передать массив как параметр?
Передача параметров в дельфи:
Type Ta=array of something;
Var a:Ta;
Procedure Proc(a:Ta); - внутри процедуры создаётся копия массива, внутри процедуры работа осуществляется только с копией данных
Procedure Proc(var a:Ta); - внутри процедуры код работает именно с переменной а и её содержимым
Procedure Proc(const a:Ta); - внутри процедуры запрещено изменять данные переменной а
Procedure Proc(out a:Ta); - при входе в процедуру массив рассматривается как пустой, но после выполнения процедуры можно получить значения
Автор Vit
Взято с Vingrad.ru
Как передать при создании нити (Tthread) ей некоторое значение?
Как передать при создании нити (Tthread) ей некоторое значение?
К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как?
Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим образом.
В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно пользоваться данными, переданными ей при его создании.
Например:
......
TYourThread = class(TTHread)
private
FFileName: String;
protected
procedure Execute; overrided;
public
constructor Create(CreateSuspennded: Boolean;
const AFileName: String);
end;
.....
constructor TYourThread.Create(CreateSuspennded: Boolean;
const AFileName: String);
begin
inherited Create(CreateSuspennded);
FFIleName := AFileName;
end;
procedure TYourThread.Execute;
begin
try
....
if FFileName = ...
....
except
....
end;
end;
....
TYourForm = class(TForm)
....
private
YourThread: TYourThread;
procedure LaunchYourThread(const AFileName: String);
procedure YourTreadTerminate(Sender: TObject);
....
end;
....
procedure TYourForm.LaunchYourThread(
const AFileName: String);
begin
YourThread := TYourThread.Create(True, AFileName);
YourThread.Onterminate := YourTreadTerminate;
YourThread.Resume
end;
....
procedure TYourForm.YourTreadTerminate(Sender: TObject);
begin
....
end;
....
end.
Источник:
Как передать UserName и Password в удаленный модуль данных?
Как передать UserName и Password в удаленный модуль данных?
В Удаленный Модуль Данных бросьте компонент TDatabase, затем добавьте процедуру автоматизации (пункт главного меню Edit | Add To Interface) для Login.
Убедитесь, что свойство HandleShared компонента TDatabase установлено в True.
procedureLogin(UserName, Password: WideString);
begin
{ DB = TDatabase }
{ Something unique between clients }
DB.DatabaseName := UserName + 'DB';
DB.Params.Values['USER NAME'] := UserName;
DB.Params.Values['PASSWORD'] := Password;
DB.Open;
end;
После того, как Вы создали этот метод автоматизации, Вы можете вызывать его с помощью:
RemoteServer1.AppServer.Login('USERNAME','PASSWORD');
Взято из
Как переделать TLabel в URL
Как переделать TLabel в URL
By Kevin Lange (klange@partslink.com)
Приложение содержит ссылку, которая позволяет запускать Браузер и сразу перейти по указанному в ссылке адресу. Процесс создания URL заключается в переделке компоненты TLabel в URL.
Следующие 3 шага показывают как переделать TLabel в URL.
Шаг 1 Установите в свойствах шрифта подчёркивание и цвет ссылки.
Шаг 2 Установите свойства курсора. Когда мышка попадает на URL, то курсор должен превращаться в ручку.
Шаг 3 Записываем событие OnClick для ссылки. Когда пользователь нажимает на ссылку, то запускается браузер, который автоматически переходит на заданный адрес. Однако этого мало! Нужно будет добавить в приложение ещё одну строчку
Та самая строчка:
ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL);
Внимание: функция ShellExecute содержится в ShellAPI, поэтому вам прийдётся включить его в проект.
Пример приложения
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ShellAPI;
type
TForm1 = class(TForm)
URLLabel: TLabel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure URLLabelClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.URLLabelClick(Sender: TObject);
Const
URL : String = 'http://www.sources.ru';
begin
ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL);
end;
end.
Взято с Исходников.ru
Как перехватить Ctrl-V в компоненте TMemo?
Как перехватить Ctrl-V в компоненте TMemo?
Следующий пример демонстрирует, как перехватить комбинацию Ctrl-V в компоненте TMemo и поместить в него свой текст вместо того, который в буфере обмена.
Пример:
uses ClipBrd;
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if ((Key = ord('V')) and (ssCtrl in Shift)) then begin
if Clipboard.HasFormat(CF_TEXT) then
ClipBoard.Clear;
Memo1.SelText := 'Delphi is RAD!';
key := 0;
end;
end;
Взято с Исходников.ru
Как перехватить клавишу табуляции (Tab) в TEdit?
Как перехватить клавишу табуляции (Tab) в TEdit?
Это можно давольно легко сделать переопределив на форме процедуру CMDialogKey. Чтобы посмотреть как это работает, поместите на форму Edit и введите следующий код:
procedure CMDialogKey(Var Msg: TWMKey);
message CM_DIALOGKEY;
...
procedure TForma.CMDialogKey(Var Msg: TWMKEY);
begin
if (ActiveControl is TEdit) and
(Msg.Charcode = VK_TAB) then
begin
ShowMessage('Нажата клавиша TAB?');
end;
inherited;
end;
Взято с Исходников.ru
Как перехватить нажатие TAB?
Как перехватить нажатие TAB?
private
Procedure CMDialogKey(Var Msg: TWMKey); message CM_DIALOGKEY;
.....
procedure TForm1.CMDialogKey(var Msg: TWMKey);
begin
//здесь Ваш код
Msg.Result := 0
end;
Автор ответа: Vit
Взято с Vingrad.ru
Как перехватить нажатия функциональных клавиш и стрелок?
Как перехватить нажатия функциональных клавиш и стрелок?
Автор: Arx ( http://arxoft.tora.ru )
Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_RIGHT then
Form1.Caption := 'Right';
if Key = VK_F1 then
Form1.Caption := 'F1';
end;
Взято с Исходников.ru
Как перехватить события в неклиентской области формы?
Как перехватить события в неклиентской области формы?
Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите
WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей
неклиенстской области окна (рамка и заголовок).
Пример:
unitUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
private
{Private declarations}
procedure WMNCMOUSEMOVE(var Message: TMessage);
message WM_NCMOUSEMOVE;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
var
s : string;
begin
case Message.wParam of
HTERROR:
s:= 'HTERROR';
HTTRANSPARENT:
s:= 'HTTRANSPARENT';
HTNOWHERE:
s:= 'HTNOWHERE';
HTCLIENT:
s:= 'HTCLIENT';
HTCAPTION:
s:= 'HTCAPTION';
HTSYSMENU:
s:= 'HTSYSMENU';
HTSIZE:
s:= 'HTSIZE';
HTMENU:
s:= 'HTMENU';
HTHSCROLL:
s:= 'HTHSCROLL';
HTVSCROLL:
s:= 'HTVSCROLL';
HTMINBUTTON:
s:= 'HTMINBUTTON';
HTMAXBUTTON:
s:= 'HTMAXBUTTON';
HTLEFT:
s:= 'HTLEFT';
HTRIGHT:
s:= 'HTRIGHT';
HTTOP:
s := 'HTTOP';
HTTOPLEFT:
s:= 'HTTOPLEFT';
HTTOPRIGHT:
s:= 'HTTOPRIGHT';
HTBOTTOM:
s:= 'HTBOTTOM';
HTBOTTOMLEFT:
s:= 'HTBOTTOMLEFT';
HTBOTTOMRIGHT:
s:= 'HTBOTTOMRIGHT';
HTBORDER:
s:= 'HTBORDER';
HTOBJECT:
s:= 'HTOBJECT';
HTCLOSE:
s:= 'HTCLOSE';
HTHELP:
s:= 'HTHELP';
else s:= '';
end;
Form1.Caption := s;
Message.Result := 0;
end;
end.
Взято из
DELPHI VCL FAQ
Перевод с английского Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для
Как перехватить сообщение об ошибке?
Как перехватить сообщение об ошибке?
Try
{здесь вы пишите код в котором может произойти ошибка}
Except
on e:Exception do Shwomessage(e.message);
End
Автор Vit
Как перехватить сообщения скроллирования в TScrollBox?
Как перехватить сообщения скроллирования в TScrollBox?
Следующий пример перхватывает сообщения скроллирования в компоненте TScrollBox, тем самым синхронизируя два скролбара. Если один из скролбаров изменяет своё положение, то значение второго скролбара изменяется на такую же величину. Сообщения скролирования перехватываются путём сабклассинга оконной процедуры (WinProc) у скролбара.
Пример:
type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;
{Объявляем переменную для хранения подменённой оконной процедуры}
var
OldWindowProc : Pointer;
function NewWindowProc(WindowHandle : hWnd;
TheMessage : WParameter;
ParamW : WParameter;
ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var
TheRangeMin : integer;
TheRangeMax : integer;
TheRange : integer;
begin
if TheMessage = WM_VSCROLL then begin
{Получаем минимальное и максимальное значения scroll box}
GetScrollRange(WindowHandle,
SB_HORZ,
TheRangeMin,
TheRangeMax);
{Получаем вертикальную позицию scroll box}
TheRange := GetScrollPos(WindowHandle,
SB_VERT);
{Проверим, чтобы не выйти за диапазон}
if TheRange < TheRangeMin then
TheRange := TheRangeMin else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Устанавливаем горизонтальный scroll bar}
SetScrollPos(WindowHandle,
SB_HORZ,
TheRange,
true);
end;
if TheMessage = WM_HSCROLL then begin
{Получаем мин. и макс. диапазон горизонтального scroll box}
GetScrollRange(WindowHandle,
SB_VERT,
TheRangeMin,
TheRangeMax);
{Получаем позицию горизонтального scroll box}
TheRange := GetScrollPos(WindowHandle,
SB_HORZ);
{Проверим, чтобы не выйти за диапазон}
if TheRange < TheRangeMin then
TheRange := TheRangeMin else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Устанавливаем вертикальный scroll bar}
SetScrollPos(WindowHandle,
SB_VERT,
TheRange,
true);
end;
{ Вызываем старую оконную процедуру }
{ чтобы обработались сообщения. }
NewWindowProc := CallWindowProc(OldWindowProc,
WindowHandle,
TheMessage,
ParamW,
ParamL);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Устанавливаем новую оконную процедуру для контрола }
{ и запоминаем старую оконную процедуру. }
OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Возвращаем обратно старую оконную процедуру. }
SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(OldWindowProc));
end;
Взято с Исходников.ru
Как перехватывать горячие клавиши в StringGrid?
Как перехватывать горячие клавиши в StringGrid?
Следующий пример демонстрирует перехват сообщения CM_DIALOGCHAR на уровне формы. Это даст нам возможность реагировать на диалоговые комбинации клавишь только, если нажата клавиша Alt, не давая тем самым отработать стандартному обработчику.
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure StringGrid1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
procedure CMDialogChar(var Message: TCMDialogChar);
message CM_DIALOGCHAR;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.Caption := 'E&xit';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm1.StringGrid1KeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
ShowMessage('Grid keypress = ' + Char(Key));
Key := 0;
end;
procedure TForm1.CMDialogChar(var Message: TCMDialogChar);
begin
if ssAlt in KeyDataToShiftState(Message.KeyData) then
inherited;
end;
Взято с Исходников.ru
Как перехватывать kernel-signals?
Как перехватывать kernel-signals?
program TestSignals;
{$APPTYPE CONSOLE}
uses
Libc;
var
bTerminate: Boolean;
procedure SignalProc(SigNum: Integer); cdecl;
begin
case SigNum of
SIGQUIT:
begin
WriteLn('signal SIGQUIT');
bTerminate := true;
end;
SIGUSR1: WriteLn('signal SIGUSR1');
else
WriteLn('not handled signal');
end;
signal(SigNum, SignalProc); // catch the signal again
end;
begin
bTerminate := false;
signal(SIGQUIT, SignalProc); // catch the signal SIGQUIT to procedure SignalProc
signal(SIGUSR1, SignalProc); // catch the signal SIGUSR1 to procedure SignalProc
repeat
sleep(1);
until bTerminate;
end.
Взято с сайта
Как перехватывать события, посланные другим приложениям?
Как перехватывать события, посланные другим приложениям?
Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook).
Например, такая ловушка может отслеживать все события,
связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.
Для ловушки нужна функция, которая, после установки ловушки
при помощи SetWindowsHookEx, будет вызываться при каждом нужном событии.
Эта функция получает всю информацию о событии. UnhookWindowsHookEx уничтожает ловушку.
Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой.
CheckBox1 показывает состояние левой клавиши мыши,
CheckBox2 показывает состояние правой клавиши мыши,
а CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.
var
HookHandle: hHook;
function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall;
var
msg: PEVENTMSG;
begin
if Code >= 0 then begin
result := 0;
msg := Pointer(LParam);
with Form1 do
case msg.message of
WM_MOUSEMOVE: Caption := IntToStr(msg.ParamL) + #32 + IntToStr(msg.ParamH);
WM_LBUTTONDOWN: CheckBox1.Checked := true;
WM_LBUTTONUP: CheckBox1.Checked := false;
WM_RBUTTONDOWN: CheckBox2.Checked := true;
WM_RBUTTONUP: CheckBox2.Checked := false;
WM_KEYUP: CheckBox3.Checked := false;
WM_KEYDOWN: CheckBox3.Checked := true;
end;
end else
result := CallNextHookEx(HookHandle, code, WParam, LParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.FormStyle := fsStayOnTop;
CheckBox1.Enabled := false;
CheckBox1.Caption := 'left button';
CheckBox2.Enabled := false;
CheckBox2.Caption := 'right button';
CheckBox3.Enabled := false;
CheckBox3.Caption := 'keyboard';
HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if HookHandle <> 0 then
UnhookWindowsHookEx(HookHandle);
end;
Всего доброго,
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru
Как перекинуть все данные из одной базы данных в другую?
Как перекинуть все данные из одной базы данных в другую?
Есть такая утилита, к делфям в комплекте идет. DataPump называется. Перекинет тебе все, что надо, индексы создаст.
Взято из
Как перемещать строки и колонки в StringGrid?
Как перемещать строки и колонки в StringGrid?
Пользователь может перемещать строки и колонки StringGrid при помощи мышки. Можно ли это сделать программно? В описании TCustomGrid можно увидеть методы MoveColumn и MoveRow, однако они скрыты в TStringGrid. Но нам ничего не мешает просабклассить TStringGrid и объявить эти методы как public:
type
TStringGridX = class(TStringGrid)
public
procedure MoveColumn(FromIndex, ToIndex: Longint);
procedure MoveRow(FromIndex, ToIndex: Longint);
end;
Чтобы воспользоваться этими методами, достаточно вызвать соответствующий метод предка:
procedure TStringGridX.MoveColumn(FromIndex, ToIndex: Integer);
begin
inherited;
end;
procedure TStringGridX.MoveRow(FromIndex, ToIndex: Integer);
begin
inherited;
end;
Этот компонент не нужно регистрировать в палитре компонентов. Просто используйте потомка TStringGrid или любого TCustomGrid, и вызывайте его методы:
procedure TForm1.Button1Click(Sender: TObject);
begin
TStringGridX(StringGrid1).MoveColumn(1, 3);
end;
Взято с Исходников.ru
Примечание от Vit: код можно написать значительно компактнее:
type TFake = class(TStringGrid);
...
procedure TForm1.Button1Click(Sender: TObject);
begin
TFake(StringGrid1).MoveColumn(1, 3);
end;
Как переместить каретку TMemo в нужную строку?
Как переместить каретку TMemo в нужную строку?
Function SetCaretPosition(memo:TMemo; x,y:integer);
var i:integer;
begin
i := SendMessage(memo.Handle, EM_LINEINDEX, y, 0) + x;
SendMessage(memo1.Handle, EM_SETSEL, i, i);
end;
или
type TFake=class(TCustomMemo);
....
TFake(MyMemo).SetCaretPos()
Автор ответа: Vit
Взято с Vingrad.ru
Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?
Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?
Автор: Nomadic
Resync([rmExact, rmCenter] );
Взято из
Как пересоздать индексы?
Как пересоздать индексы?
procedureTForm1.Button4Click(Sender: TObject);
var
aExclusive, aActive: Boolean;
begin
with Table1 do
begin
aActive := Active;
Close;
aExclusive := Exclusive;
Exclusive := True;
Open;
Check(DbiRegenIndexes(Table1.Handle));
Close;
Exclusive := aExclusive;
Active := aActive;
Check(DbiSaveChanges(Table1.Handle));
end;
end;
As when calling any BDE API function, the BDE API wrapper unit BDE (for Delphi 1, the units DbiTypes, DbiErrs, and DbiProcs) must be referenced in the Uses section of the unit from which the call is to be made. The BDE API function DbiSaveChanges, used here, forces any data changes in memory buffer to be written to disk at that point.
Another way to handle this situation -- if you know at design-time all the indexes that will exist for the table -- would be to iterate through the items in the TIndexDefs object of the TTable component, delete each index (DeleteIndex method), and then add all needed indexes back (AddIndex method).
procedure TForm1.Button3Click(Sender: TObject);
var
aName: string;
i: Byte;
aExclusive, aActive: Boolean;
begin
with Table1 do
begin
aActive := Active;
Close;
aExclusive := Exclusive;
Exclusive := True;
IndexDefs.Update;
i := IndexDefs.Count;
while i > 0 do
begin
aName := IndexDefs.Items[i - 1].Name;
DeleteIndex(aName);
Dec(i);
end;
AddIndex('', 'MainField', [ixPrimary]);
AddIndex('Field1', 'Field1', []);
AddIndex('Field2', 'Field2', []);
IndexDefs.Update;
Exclusive := aExclusive;
Active := aActive;
Check(DbiSaveChanges(Table1.Handle));
end;
end;
Взято с
Delphi Knowledge BaseКак перетащить целую колонку из Stringgrid в Listbox?
Как перетащить целую колонку из Stringgrid в Listbox?
После того, как поместите 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
Как перетаскивать (Drag and Drop) выделенный текст между компонентами Memo?
Как перетаскивать (Drag and Drop) выделенный текст между компонентами Memo?
Данный способ позволяет не погружаясь глубоко в создание компонент осуществить операцию "drag and drop" выделенного текста.
Создайте новый компонент (TMyMemo), наследовав его от TMemo. И объявите его следующим образом:
type
TMyMemo = class(TMemo)
private
FLastSelStart : Integer;
FLastSelLength : Integer;
procedure WMLButtonDown(var Message: TWMLButtonDown);
message WM_LBUTTONDOWN;
published
property LastSelStart : Integer read FLastSelStart
write FLastSelStart;
property LastSelLength : Integer read FLastSelLength
write FLastSelLength;
end;
Добавьте обработчик WMLButtonDown:
procedure TMyMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
Ch : Integer;
begin
if SelLength > 0 then begin
Ch := LoWord(Perform(EM_CHARFROMPOS,0,
MakeLParam(Message.XPos,Message.YPos)));
LastSelStart := SelStart;
LastSelLength := SelLength;
if (Ch >= SelStart) and (Ch <= SelStart+SelLength-1) then
BeginDrag(True)
else
inherited;
end
else
inherited;
end;
Теперь установите этот компонент в package, создайте новый проект в Delphi и поместите на форму два TMyMemo. Для обоих компонент необходимо создать обработчики событий OnDragOver, которые должны выглядеть следующим образом:
procedure TForm1.MyMemo1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source is TMyMemo;
end;
Так же для них необходимо сделать обработчики событий OnDragDrop:
procedure TForm1.MyMemo1DragDrop(Sender, Source: TObject;
X, Y: Integer);
var
Dst, Src : TMyMemo;
Ch : Integer;
Temp : String;
begin
Dst := Sender as TMyMemo;
Src := Source as TMyMemo;
Ch := LoWord(Dst.Perform(EM_CHARFROMPOS,0,MakeLParam(X,Y)));
if (Src = Dst) and (Ch >= Src.LastSelStart) and
(Ch <= Src.LastSelStart+Src.LastSelLength-1) then
Exit;
Dst.Text := Copy(Dst.Text,1,Ch)+Src.SelText+
Copy(Dst.Text,Ch+1,Length(Dst.Text)-Ch);
Temp := Src.Text;
Delete(Temp,Src.LastSelStart+1,Src.LastSelLength);
Src.Text := Temp;
end;
Запустите приложение, поместите в поля memo какой-нибудь текст, и посмотрите что произойдёт, если перетащить текст между полями.
Взято с Исходников.ru
Как перетаскивать файлы?
Как перетаскивать файлы?
как принимать "перетаскиваемые" файлы.
При получении программой файлов, окну посылается сообщение WM_DROPFILES.
При помощи функции DragQueryFile можно определить количество и имена файлов.
При помощи функции DragQueryPoint можно определить координату мыши в тот момент,
когда пользователь "отпустил" файлы.
Эта программа открывает все "перетащенные" в нее файлы.
Причем, если пользователь перетащил файлы в PageControl1, то в PageControl1 эти файлы и откроются.
...
public
procedure WMDropFiles(var Msg: TWMDropFiles);
message WM_DROPFILES;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses ShellAPI, stdctrls;
procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
HF: THandle;
s: array [0..1023] of char;
i, FileCount: integer;
p: TPoint;
ts: TTabSheet;
memo: TMemo;
begin
HF := Msg.Drop;
FileCount := DragQueryFile(HF, $FFFFFFFF, nil, 0);
for i := 0 to FileCount - 1 do begin
DragQueryFile(HF, i, s, sizeof(s));
ts := TTabSheet.Create(nil);
DragQueryPoint(HF, p);
if PtInRect(PageControl1.BoundsRect, p)
then ts.PageControl := PageControl1
else ts.PageControl := PageControl2;
ts.Caption := ExtractFileName(s);
memo := TMemo.Create(nil);
memo.Parent := ts;
memo.Align := alClient;
memo.Lines.LoadFromFile(s);
end;
DragFinish(HF);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
PageControl1.Align := alLeft;
PageControl2.Align := alClient;
DragAcceptFiles(Form1.Handle, true);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, false);
end;
Всего доброго,
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru
{ На эту форму можно бросить файл (например из проводника)
и он будет открыт }
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs,StdCtrls,
ShellAPI {обязательно!};
type
TForm1 = class(TForm)
Memo1: TMemo;
FileNameLabel: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
protected
{Это и есть самая главная процедура}
procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMDropFiles(var Msg: TMessage);
var
Filename: array[0 .. 256] of Char;
Count : integer;
begin
{ Получаем количество файлов (просто пример) }
nCount := DragQueryFile( msg.WParam, $FFFFFFFF,
acFileName, cnMaxFileNameLen);
{ Получаем имя первого файла }
DragQueryFile( THandle(Msg.WParam),
0, { это номер файла }
Filename,SizeOf(Filename) ) ;
{ Открываем его }
with FileNameLabel do begin
Caption := LowerCase(StrPas(FileName));
Memo1.Lines.LoadfromFile(Caption);
end;
{ Отдаем сообщение о завершении процесса }
DragFinish(THandle(Msg.WParam));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Говорим Windows, что на нас можно бросать файлы }
DragAcceptFiles(Handle, True);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Закрываем за собой дверь золотым ключиком}
DragAcceptFiles(Handle, False);
end;
end.
Источник:
Как перетаскивать компоненты в Run-Time?
Как перетаскивать компоненты в Run-Time?
Возьмите форму, бросьте на нее панель, на onMouseDown панели прицепите код:
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Panel1.Perform(WM_SYSCOMMAND, $F012, 0);
end;
Теперь в run-time панель можно таскать как в дизайне...
Взято с Vingrad.ru
Как перевести монитор в режим stand-by?
Как перевести монитор в режим stand-by?
Автор: Kecvin S. Gallagher
Если монитор поддерживает режим Stand by, то его можно программно перевести в этот режим. Данная возможность доступна на Windows95 и выше.
Чтобы перевести монитор в режим Stand by:
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0) ;
Чтобы вывести его из этого режима:
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1) ;
А теперь более полный пример кода:
На новую форму поместите кнопку, таймер и ListBox.
Timer (use Object Inspector):
Enabled := False
Interval := 15000
Добавьте следующее событие таймеру:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
ListBox1.Items.Add(FormatDateTime('h:mm:ss AM/PM',Time)) ;
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1);
end;
Command Button:
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Add('--> ' + FormatDateTime('h:mm:ss AM/PM',Time)) ;
Timer1.Enabled := not Timer1.Enabled ;
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0) ;
end;
После запуска откомпилированного приложения и нажатия на кнопку, экран погаснет на 15 секунд.
ЗАМЕЧАНИЕ: Удостоверьтесь, что во первых компьютер поддерживает режимы энергосбережения, а вовторых, эти функции не запрещены на данном компьютере.
Взято с Исходников.ru
Как перезагрузить Explorer?
Как перезагрузить Explorer?
HWND hwndShell;
hwndShell = FindWindow ("Progman", NULL);
PostMessage (hwndShell, WM_QUIT, 0, 0L);
ShellExecute (0, "open", "Explorer", NULL, NULL, SW_SHOWNORMAL);
Как писать консольные приложения в Delphi?
Как писать консольные приложения в Delphi?
Автор: Alex G. Fedorov
Все настоящие программисты делятся на три категории: на тех, кто пишет программы, завершающиеся по нажатию F10, Alt-F4, Alt-X. Все остальные принципы деления надуманны.
Статья представляет собой изучение создания консольного приложения в Delphi. Прежде чем начать вникать в подробности, необходимо уточнить, что консольные приложения это особый вид Windows приложений - с одной стороны он имеет полный доступ к функциям Win API, с другой - не имеет графического интерфейса и выполняется в текстовом режиме.
Простая консольная программа
На момент написания статьи (1997г.), в Delphi не было возможности автоматически создавать консольные приложения (возможно на сегодняшний день этот недостаток устранён), поэтому мы создадим пустой файл и поместим в него следующий код:
program ConPrg;
{$APPTYPE CONSOLE}
begin
end.
Затем сохраним этот файл с расширением .dpr - в данном случае conprg.dpr. Далее, его можно загрузить в Delphi (File|Open) и приступить к добавлению кода.
Обратите внимание:
Если Вы запустите вышеприведённую программу, то она немедленно завершится, так как в ней нет никакого рабочего кода.
Для начала, в неё можно добавить строчку readln:
program ConPrg;
{$APPTYPE CONSOLE}
begin
readln
end.
Вы увидите пустое текстовое окошко, которое закроется, если нажать клавишу Enter.
Идём дальше
Как упоминалось раньше, Вы можете использовать почти любую функцию Win32 API из консольного приложения. Такое приложение очень удобно ещё и тем, что о пользовательском интерфейсе можно вообще не думать, а для вывода информации использовать только пару функций Write/Writeln. Примеров применения консольных приложений великое множество: это и различного вида утилиты, и тестовые программы для проверки работы функций API и т.д. Мы не будет погружаться в примеры того как использовать определённые API, а поговорим только о Консольных API (Console API).
Консольные API (Console API)
Microsoft предоставляет определённый набор функций, которые очень даже полезны при создании консольных приложений. Для начала скажу, что существует по крайней мере два дескриптора (handles), которые связаны с консольным окном. Один для ввода, второй для вывода. Ниже приводятся две небольшие функции, которые показывают, как получить эти дескрипторы.
//-----------------------------------------
// Получение дескриптора для консольного ввода
//-----------------------------------------
function GetConInputHandle : THandle;
begin
Result := GetStdHandle(STD_INPUT_HANDLE)
end;
//-----------------------------------------
// Получение дескриптора для консольного вывода
//-----------------------------------------
function GetConOutputHandle : THandle;
begin
Result := GetStdHandle(STD_OUTPUT_HANDLE)
end;
Так же, лучше сразу создать свои функции для таких простых операций как позиционирование курсора, очистки экрана и отображение/скрытие курсора (так как в консольных API они немножко громозки и запутаны). Вот как они выглядят:
//-----------------------------------------
// Установка курсора в координаты X, Y
//-----------------------------------------
procedure GotoXY(X, Y: Word);
begin
Coord.X := X;
Coord.Y := Y;
SetConsoleCursorPosition(ConHandle, Coord);
end;
//-----------------------------------------
// Очистка экрана - заполнение его пробелами
//-----------------------------------------
procedure Cls;
begin
Coord.X := 0;
Coord.Y := 0;
FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW);
GotoXY(0, 0);
end;
//--------------------------------------
// Показываем/Скрываем курсор
//--------------------------------------
procedure ShowCursor(Show: Bool);
begin
CCI.bVisible := Show;
SetConsoleCursorInfo(ConHandle, CCI);
end;
Как Вы успели заметить, мы воспользовались четырьмя функциями консольного API: GetStdHandle, SetConsoleCursorPosition, FillConsoleOutputCharacter, SetConsoleCursorInfo. Иногда может возникнуть задача определения размера консольного окна по вертикали и по горизонтали. Для этого мы создадим две переменные: MaxX и MaxY, типа WORD:
//--------------------------------------
// Инициализация глобальных переменных
//--------------------------------------
procedure Init;
begin
// Получаем дескриптор вывода (output)
ConHandle := GetConOutputHandle;
// Получаем максимальные размеры окна
Coord := GetLargestConsoleWindowSize(ConHandle);
MaxX := Coord.X;
MaxY := Coord.Y;
end;
Мы даже можем сделать "цикл обработки сообщений" (message loop) - для тех, кто только начинает программировать в Delphi - цикл обработки сообщений необходимо делать, если приложение создаётся в чистом API - при этом необходимы как минимум три составляющие: WinMain, message loop и window proc.
Ниже приведён код "цикла обработки сообщений":
SetConsoleCtrlHandler(@ConProc, False);
Cls;
//
// "Цикл обработки сообщений"
//
Continue := True;
while Continue do
begin
ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
case IBuff.EventType of
KEY_EVENT :
begin
// Проверяем клавишу ESC и завершаем программу
if ((IBuff.KeyEvent.bKeyDown = True) and
(IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
Continue := False;
end;
_MOUSE_EVENT :
begin
with IBuff.MouseEvent.dwMousePosition do
StatusLine(Format('%d, %d', [X, Y]));
end;
end;
end {While}
Так же можно добавить "обработчик событий" и перехватывать такие комбинации клавиш как Ctrl+C и Ctrl+Break:
//-----------------------------------------------------
// Обработчик консольных событий
//-----------------------------------------------------
function ConProc(CtrlType: DWord): Bool; stdcall; far;
var
S: string;
begin
case CtrlType of
CTRL_C_EVENT: S := 'CTRL_C_EVENT';
CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
else
S := 'UNKNOWN_EVENT';
end;
MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
Result := True;
end;
Чтобы посмотреть всё это в действии, я сделал небольшую демонстрационную программу, которая содержит подпрограммы, приведённые выше, а так же некоторые другие возможности. Далее приведён полный исходный код этого приложения. Наслаждайтесь!
{
[]-----------------------------------------------------------[]
CON001 - Show various Console API functions. Checked with Win95
version 1.01
by Alex G. Fedorov, May-July, 1997
alexfedorov@geocities.com
09-Jul-97 some minor corrections (shown in comments)
[]-----------------------------------------------------------[]
}
program Con001;
{$APPTYPE CONSOLE}
uses
Windows, SysUtils;
const
// Некоторые стандартные цвета
YellowOnBlue = FOREGROUND_GREEN or FOREGROUND_RED or
FOREGROUND_INTENSITY or BACKGROUND_BLUE;
WhiteOnBlue = FOREGROUND_BLUE or FOREGROUND_GREEN or
FOREGROUND_RED or FOREGROUND_INTENSITY or
BACKGROUND_BLUE;
RedOnWhite = FOREGROUND_RED or FOREGROUND_INTENSITY or
BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE
or BACKGROUND_INTENSITY;
WhiteOnRed = BACKGROUND_RED or BACKGROUND_INTENSITY or
FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE
or FOREGROUND_INTENSITY;
var
ConHandle: THandle; // Дескриптор консольного окна
Coord: TCoord; // Для хранения/установки позиции экрана
MaxX, MaxY: Word; // Для хранения максимальных размеров окна
CCI: TConsoleCursorInfo;
NOAW: LongInt; // Для хранения результатов некоторых функций
//-----------------------------------------
// Получение дескриптора для консольного ввода
//-----------------------------------------
function GetConInputHandle : THandle;
begin
Result := GetStdHandle(STD_INPUT_HANDLE)
end;
//-----------------------------------------
// Получение дескриптора для консольного вывода
//-----------------------------------------
function GetConOutputHandle : THandle;
begin
Result := GetStdHandle(STD_OUTPUT_HANDLE)
end;
//-----------------------------------------
// Установка курсора в координаты X, Y
//-----------------------------------------
procedure GotoXY(X, Y : Word);
begin
Coord.X := X;
Coord.Y := Y;
SetConsoleCursorPosition(ConHandle, Coord);
end;
//-----------------------------------------
// Очистка экрана - заполнение его пробелами
//-----------------------------------------
procedure Cls;
begin
Coord.X := 0;
Coord.Y := 0;
FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW);
GotoXY(0, 0);
end;
//--------------------------------------
// Показываем/Скрываем курсор
//--------------------------------------
procedure ShowCursor(Show : Bool);
begin
CCI.bVisible := Show;
SetConsoleCursorInfo(ConHandle, CCI);
end;
//--------------------------------------
// Инициализация глобальных переменных
//--------------------------------------
procedure Init;
begin
// Получаем дескриптор вывода (output)
ConHandle := GetConOutputHandle;
// Получаем максимальные размеры окна
Coord := GetLargestConsoleWindowSize(ConHandle);
MaxX := Coord.X;
MaxY := Coord.Y;
end;
//---------------------------------------
// рисуем строку статуса ("status line")
//---------------------------------------
procedure StatusLine(S : string);
begin
Coord.X := 0; Coord.Y := 0;
WriteConsoleOutputCharacter(ConHandle, PChar(S), Length(S)+1, Coord, NOAW);
FillConsoleOutputAttribute (ConHandle, WhiteOnRed, Length(S), Coord, NOAW);
end;
//-----------------------------------------------------
// Консольный обработчик событий
//-----------------------------------------------------
function ConProc(CtrlType : DWord) : Bool; stdcall; far;
var
S: string;
begin
case CtrlType of
CTRL_C_EVENT: S := 'CTRL_C_EVENT';
CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
else
S := 'UNKNOWN_EVENT';
end;
MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
Result := True;
end;
{
[]-----------------------------------------------------------[]
Основная программа - показывает использование некоторых подпрограмм
а так же некоторых функций консольного API
[]-----------------------------------------------------------[]
}
var
R: TSmallRect;
Color: Word;
OSVer: TOSVersionInfo;
IBuff: TInputRecord;
IEvent: DWord;
Continue: Bool;
begin
// Инициализация глобальных переменных
Init;
// Расположение окна на экране
{!! 1.01 !!}
with R do
begin
Left := 10;
Top := 10;
Right := 40;
Bottom := 40;
end
{!! 1.01 !!}
SetConsoleWindowInfo(ConHandle, False, R);
// Устанавливаем обработчик событий
SetConsoleCtrlHandler(@ConProc, True);
// Проверяем обработчик событий
GenerateConsoleCtrlEvent(CTRL_C_EVENT, 0);
// Изменяем заголовок окна
SetConsoleTitle('Console Demo');
// Прячем курсор
ShowCursor(False);
Coord.X := 0; Coord.Y := 0;
// Устанавливаем белый текст на синем фоне
Color := WhiteOnBlue;
FillConsoleOutputAttribute(ConHandle, Color, MaxX * MaxY, Coord, NOAW);
// Console Code Page API is not supported under Win95 - only GetConsoleCP
Writeln('Console Code Page = ', GetConsoleCP);
Writeln('Max X=', MaxX,' Max Y=', MaxY);
Readln; // ожидаем ввода пользователя
Cls; // очищаем экран
ShowCursor(True); // показываем курсор
// Use some Win32API stuff
OSVer.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(OSVer);
with OSVer do
begin
Writeln('dwMajorVersion = ', dwMajorVersion);
Writeln('dwMinorVersion = ', dwMinorVersion);
Writeln('dwBuildNumber = ', dwBuildNumber);
Writeln('dwPlatformID = ', dwPlatformID);
end;
// ожидаем ввода пользователя
Readln;
// Удаляем обработчик событий
SetConsoleCtrlHandler(@ConProc, False);
Cls;
// "Цикл обработки сообщений"
Continue := True;
while Continue do
begin
ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
case IBuff.EventType of
KEY_EVENT :
begin
// Проверяем клавишу ESC и завершаем программу
if ((IBuff.KeyEvent.bKeyDown = True) and
(IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
Continue := False;
end;
_MOUSE_EVENT :
begin
with IBuff.MouseEvent.dwMousePosition do
StatusLine(Format('%d, %d', [X, Y]));
end;
end;
end {While}
end.
Взято с
