Г-н Посол
Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.
Репутация: 58
Всего: 112
|
Как сделать плавное закрытие окна ? Работает в 2k/XP: | Код | procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
AnimateWindow(Handle, 500, AW_HIDE or AW_BLEND);
end; |
DelphiPool Добавлено @ 01:36 Как назначить событие на увеличение/уменьшение TSpinEdit с помощью стрелочек ? У TSpinEdit.Button есть дополнительные события, которые не показаны в инспекторе объектов, например, OnUpClick и OnDownClick... | Код | unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, Spin;
type
TForm1 = class(TForm)
SpinEdit1: TSpinEdit;
procedure FormCreate(Sender: TObject);
public
procedure OnButtonUpClick(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
SpinEdit1.Button.OnUpClick := OnButtonUpClick;
end;
procedure TForm1.OnButtonUpClick(Sender: TObject);
begin
MessageDlg('Up Button was clicked.', mtInformation,
[mbOk], 0);
end;
end.
|
Delphicorner.f9.co.uk Добавлено @ 01:36 Как установить фокус на документе в TWebBrowser ? WebBrowser1.SetFocus ставит фокус на компонент TWebBrowser, а это не всегда то, что нужно. Если нужно поставить фокус на документ в TWebBrowser'е (чтобы, например, кнопки вверх/вниз скроллировали документ, а не ставили фокус на другой компонент), то можно использовать этот код: | Код | uses ActiveX;
with WebBrowser1 do
if Document <> nil then
with Application as IOleobject do
DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle,
GetClientRect); |
Delphi3000 Добавлено @ 01:39 Как определить, работает ли программа в виртуальной машине ? Для VMWare: | Код |
////////////////////////////////////////////////////////////////////////////////
//
// Simple VMware check on i386
//
// Note: There are plenty ways to detect VMware. This short version bases
// on the fact that VMware intercepts IN instructions to port 0x5658 with
// an magic value of 0x564D5868 in EAX. However, this is *NOT* officially
// documented (used by VMware tools to communicate with the host via VM).
//
// Because this might change in future versions - you should look out for
// additional checks (e.g. hardware device IDs, BIOS informations, etc.).
// Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS
// Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi).
//
function IsVMwarePresent(): LongBool; stdcall; // platform;
begin
Result := False;
{$IFDEF CPU386}
try
asm
mov eax, 564D5868h
mov ebx, 00000000h
mov ecx, 0000000Ah
mov edx, 00005658h
in eax, dx
cmp ebx, 564D5868h
jne @@exit
mov Result, True
@@exit:
end;
except
Result := False;
end;
{$ENDIF}
end;
|
Для Connectrix's Virtual PC: | Код |
{
This function can be used to determine whether your program is
running from within Connectrix's Virtual PC
}
function running_inside_vpc: boolean; assembler;
asm
push ebp
mov ecx, offset @@exception_handler
mov ebp, esp
push ebx
push ecx
push dword ptr fs:[0]
mov dword ptr fs:[0], esp
mov ebx, 0 // flag
mov eax, 1 // VPC function number
// call VPC
db 00Fh, 03Fh, 007h, 00Bh
mov eax, dword ptr ss:[esp]
mov dword ptr fs:[0], eax
add esp, 8
test ebx, ebx
setz al
lea esp, dword ptr ss:[ebp-4]
mov ebx, dword ptr ss:[esp]
mov ebp, dword ptr ss:[esp+4]
add esp, 8
jmp @@ret
@@exception_handler:
mov ecx, [esp+0Ch]
mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running
add dword ptr [ecx+0B8h], 4 // -> skip past the detection code
xor eax, eax // exception is handled
ret
@@ret:
end; |
SwissDelphiCenter Добавлено @ 01:40 Трассировка пути до определенного IP адреса (как tracert.exe в Windows) Пример использования модуля: | Код |
procedure TForm1.Button1Click(Sender: TObject);
var RT : TTraceRoute;
begin
RT := TTraceRoute.Create;
RT.Trace('192.168.5.12', ListBox1.Items);
RT.Free;
end; |
В ListBox1 выведется путь в таком формате: IP;TIME;TTL;STATUS Сам модуль: | Код | unit TraceRt;
interface
// ===========================================================================
// TRACEROUTE Class
// Mike Heydon Dec 2003
//
// Method
// Trace(IpAddress : string; ResultList : TStrings)
// Returns semi-colon delimited list of ip routes to target
// format .. IP ADDRESS; PING TIME MS; TIME TO LIVE; STATUS
//
// Properties
// IcmpTimeOut : integer (Default = 5000ms)
// IcmpMaxHops : integer (Default = 40)
// ===========================================================================
uses Forms, Windows, Classes, SysUtils, IdIcmpClient;
type
TTraceRoute = class(TObject)
protected
procedure ProcessResponse(Status : TReplyStatus);
procedure AddRoute(AResponseTime : DWORD;
AStatus: TReplyStatus; const AInfo: string );
private
FIcmpTimeOut,
FIcmpMaxHops : integer;
FResults : TStringList;
FICMP : TIdIcmpClient;
FPingStart : cardinal;
FCurrentTTL : integer;
procedure PingTarget;
public
constructor Create;
procedure Trace(const AIpAddress : string; AResultList : TStrings);
property IcmpTimeOut : integer read FIcmpTimeOut write FIcmpTimeOut;
property IcmpMaxHops : integer read FIcmpMaxHops write FIcmpMaxHops;
end;
// ---------------------------------------------------------------------------
implementation
// ========================================
// Create the class and set defaults
// ========================================
constructor TTraceRoute.Create;
begin
IcmpTimeOut := 5000;
IcmpMaxHops := 40;
end;
// =============================================
// Use Indy component to ping hops to target
// =============================================
procedure TTraceRoute.PingTarget;
var wOldMode : DWORD;
begin
Application.ProcessMessages;
inc(FCurrentTTL);
if FCurrentTTL < FIcmpMaxHops then begin
FICMP.TTL := FCurrentTTL;
FICMP.ReceiveTimeout := FIcmpTimeOut;
FPingStart := GetTickCount;
wOldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
FICMP.Ping;
ProcessResponse(FICMP.ReplyStatus);
except
FResults.Add('0.0.0.0;0;0;ERROR');
end;
SetErrorMode(wOldMode);
end
else
FResults.Add('0.0.0.0;0;0;MAX HOPS EXCEEDED');
end;
// ============================================================
// Add the ping reply status data to the returned stringlist
// ============================================================
procedure TTraceRoute.AddRoute(AResponseTime : DWORD;
AStatus: TReplyStatus;
const AInfo: string );
begin
FResults.Add(AStatus.FromIPAddress + ';' +
IntToStr(GetTickCount - AResponseTime) + ';' +
IntToStr(AStatus.TimeToLive) + ';' + AInfo);
end;
// ============================================================
// Process the ping reply status record and add to stringlist
// ============================================================
procedure TTraceRoute.ProcessResponse(Status : TReplyStatus);
begin
case Status.ReplyStatusType of
// Last Leg - Terminate Trace
rsECHO : AddRoute(FPingStart,Status,'OK');
// More Hops to go - Continue Pinging
rsErrorTTLExceeded : begin
AddRoute(FPingStart,Status,'OK');
PingTarget;
end;
// Error conditions - Terminate Trace
rsTimeOut : AddRoute(FPingStart,Status,'TIMEOUT');
rsErrorUnreachable : AddRoute(FPingStart,Status,'UNREACHABLE');
rsError : AddRoute(FPingStart,Status,'ERROR');
end;
end;
// ======================================================
// Trace route to target IP address
// Results returned in semi-colon delimited stringlist
// IP; TIME MS; TIME TO LIVE; STATUS
// ======================================================
procedure TTraceRoute.Trace(const AIpAddress : string;
AResultList : TStrings);
begin
FICMP := TIdIcmpClient.Create(nil);
FICMP.Host := AIpAddress;
FResults := TStringList(AResultList);
FResults.Clear;
FCurrentTTL := 0;
PingTarget;
FICMP.Free;
end;
{eof}
end. |
Delhpi3000 Добавлено @ 01:41 Предпросмотр/печать TRichEdit Чтобы вывести Rich Edit на любой канвас, нужно использовать стандартное сообщение EM_FORMATRANGE. lParam пареметр этого сообщения содержит указатель на структуру TFormatRange. Перед посылкой сообщения нужно заполнить эту структуру: hdc - контекст устройства, на который будет выводиться Rich Edit hdcTarget - контекст устройства, в соответствии с которым будет производиться форматирование текста rc - область, в которую будет выводиться Rich Edit. Единицы измерения - твипсы (twips). Twips = 1/1440 дюйма. rcPage - полная область вывода устройства (в твипсах) chrg - указывает диапазон выводимого текста chrg.cpMin и chrg.cpMax - позиции символов, определяющие кусок текста (не включая сами cpMin и cpMax)... | Код | function PrintRTFToBitmap(ARichEdit : TRichEdit; ABitmap : TBitmap) : Longint;
var
range : TFormatRange;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
// Rendering to the same DC we are measuring.
Range.hdc := ABitmap.Canvas.handle;
Range.hdcTarget := ABitmap.Canvas.Handle;
// Set up the page.
Range.rc.left := 0;
Range.rc.top := 0;
Range.rc.right := ABitmap.Width * 1440 div Screen.PixelsPerInch;
Range.rc.Bottom := ABitmap.Height * 1440 div Screen.PixelsPerInch;
// Default the range of text to print as the entire document.
Range.chrg.cpMax := -1;
Range.chrg.cpMin := 0;
// format the text
Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
// Free cached information
SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0);
end; |
Следующий пример покажет, как вывести Rich Edit не только на любой канвас, но и также, как вывести только определённый кусок текста... | Код | function PrintToCanvas(ACanvas : TCanvas; FromChar, ToChar : integer;
ARichEdit : TRichEdit; AWidth, AHeight : integer) : Longint;
var
Range : TFormatRange;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
Range.hdc := ACanvas.handle;
Range.hdcTarget := ACanvas.Handle;
Range.rc.left := 0;
Range.rc.top := 0;
Range.rc.right := AWidth * 1440 div Screen.PixelsPerInch;
Range.rc.Bottom := AHeight * 1440 div Screen.PixelsPerInch;
Range.chrg.cpMax := ToChar;
Range.chrg.cpMin := FromChar;
Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0);
end; |
А как вывести Rich-текст с фоновым рисунком ? Рисуем по-отдельности фоновый рисунок и содержимое TRichEdit, а потом их соединяем... | Код | procedure TForm1.Button2Click(Sender: TObject);
var Bmp : TBitmap;
begin
Bmp := TBitmap.Create;
bmp.Width := 300;
bmp.Height := 300;
PrintToCanvas(bmp.Canvas,2,5,RichEdit1,300,300);
BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
bmp.Canvas.Handle, 0, 0, srcAND);
Image1.Repaint;
bmp.Free;
end; |
DelphiPages Добавлено @ 01:42 Как узнать IP клиента и IP сервера для активного RAS-подключения ? | Код | uses Ras, RasError;
type
TRASIP = record
dwSize: DWORD;
dwError: DWORD;
szIpAddress: packed array[0..RAS_MaxIpAddress] of AnsiChar;
szServerIpAddress: packed array[0..RAS_MaxIpAddress] of AnsiChar;
end;
procedure GetDialUpIpAddress(var server, client: string);
var
RASPppIp: TRASIP;
lpcp: DWORD;
ConnClientIP: array[0..RAS_MaxIpAddress] of Char;
ConnServerIP: array[0..RAS_MaxIpAddress] of Char;
Entries: PRasConn;
BufSize, NumberOfEntries, Res: DWORD;
RasConnHandle: THRasConn;
begin
New(Entries);
BufSize := Sizeof(Entries^);
ZeroMemory(Entries, BufSize);
Entries^.dwSize := Sizeof(Entries^);
Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
if Res = ERROR_BUFFER_TOO_SMALL then
begin
ReallocMem(Entries, BufSize);
ZeroMemory(Entries, BufSize);
Entries^.dwSize := Sizeof(Entries^);
Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
end;
try
if (Res = 0) and (NumberOfEntries > 0) then RasConnHandle := Entries.hrasconn else exit
finally
FreeMem(Entries);
end;
FillChar(RASPppIp, SizeOf(RASPppIp), 0);
RASPppIp.dwSize := SizeOf(RASPppIp);
lpcp := RASPppIp.dwSize;
if RasGetProjectionInfo(RasConnHandle,
RASP_PppIp, @RasPppIp, lpcp) = 0 then
begin
Move(RASPppIp.szServerIpAddress,
ConnServerIP,
SizeOf(ConnServerIP));
Server := ConnServerIP;
Move(RASPppIp.szIpAddress,
ConnClientIP,
SizeOf(ConnClientIP));
client := ConnClientIP;
end;
end; |
Delphi3000 Добавлено @ 01:43 Как узнать частоту обновления монитора ? | Код | function GetDisplayFrequency: Integer;
var
DeviceMode: TDeviceMode;
begin
EnumDisplaySettings(nil, Cardinal(-1), DeviceMode);
Result := DeviceMode.dmDisplayFrequency;
end; |
Delphi3000 Добавлено @ 01:44 Как заблокировать доступ к дисководу ? В этом примере при нажатии на Button1 дисковод заблокируется, а при нажатии ОК - разблокируется... | Код | const
FILE_DEVICE_FILE_SYSTEM: Integer = $00000009;
METHOD_BUFFERED: Integer = $00000000;
FILE_ANY_ACCESS: Integer = $00000000;
function CTL_CODE(DeviceType, FunctionNo, Method, Access: Integer): Integer;
begin
Result := (DeviceType shl 16) or (Access shl 14) or (FunctionNo shl 2) or (Method);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LHandle: THandle;
BytesReturned: Cardinal;
MsgBuf: PChar;
FSCTL_LOCK_VOLUME: Integer;
begin
FSCTL_LOCK_VOLUME := CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 6,
METHOD_BUFFERED, FILE_ANY_ACCESS);
LHandle := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ
or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or
FILE_FLAG_DELETE_ON_CLOSE, 0);
if LHandle <> 0 then
begin
if DeviceIOControl(LHandle, FSCTL_LOCK_VOLUME, nil, 0, nil, 0, BytesReturned, nil) then
ShowMessage('Дисковод заблокирован. Нажмите ОК для разблокирования.')
else
begin
if FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or
FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError(), 0, @MsgBuf, 0, nil) > 0 then
begin
ShowMessage('Ошибка DeviceIOControl: ' + MsgBuf);
LocalFree(Cardinal(MsgBuf));
end
else
ShowMessage('Ошибка при вызове DeviceIOControl!');
end;
CloseHandle(LHandle);
end
else
ShowMessage('Ошибка при вызове CreateFile!');
end; |
DelphiPool Добавлено @ 01:45 Antivirus API Microsoft Antivirus API позволяет создавать приложения для сканирования документов MS Office перед их открытием (а также сканирование закачек IE, содержащих код). | Код | unit msoav;
interface
uses Windows, SysUtils, ActiveX, ComObj, Classes;
const
IID_IOfficeAntiVirus : TGUID = '{56FFCC30-D398-11d0-B2AE-00A0C908FA49}';
//DEFINE_GUID(IID_IOfficeAntiVirus,
//0x56ffcc30, 0xd398, 0x11d0, 0xb2, 0xae, 0x0, 0xa0, 0xc9, 0x8, 0xfa, 0x49);
CATID_MSOfficeAntiVirus : TGUID = '{56FFCC30-D398-11d0-B2AE-00A0C908FA49}';
//DEFINE_GUID(CATID_MSOfficeAntiVirus,
//0x56ffcc30, 0xd398, 0x11d0, 0xb2, 0xae, 0x0, 0xa0, 0xc9, 0x8, 0xfa, 0x49);
type
TInfoStruct = record
fIsFile : boolean;
fIsReadOnly : boolean;
fIsInstalled : boolean;
fIsHTTPDownload : boolean;
end;
//Contains information about the file to be scanned.
{
* cbSize - Integer value that specifies the size of an MSOAVINFO structure.
* hWnd - Handle to the parent window of the Microsoft® Office 2000 application.
* pwzFullPath - Address of a wide character string that contains the full
path of the file about to be opened.
* lpStg - Address of the OLE storage location of the file about to be opened.
* pwzHostName - Address of a wide character string that contains the host
application name for the antivirus scanner user interface.
* pwzOrigURL - Address of a wide character string that contains the URL of the
origin of a downloaded file.
}
TMsoavinfo = record
cbSize : integer;
info : ULONG;
wnd : HWND;
FullPath : Pointer;
pwzHostName : PWChar;
pwzOrigURL : PWChar;
end;
//This is the interface an antivirus scanner uses to interact with a host application.
IOfficeAntiVirus = interface(IUnknown)
['{56FFCC30-D398-11d0-B2AE-00A0C908FA49}']
function Scan(pmsoavinfo : PChar) : HResult; stdcall;
end;
function TestBit(const Value: Cardinal; const Bit: byte): Boolean;
procedure GetRegisteredAntiviruses(ProgIDs: TStrings);
implementation
function TestBit(const Value: Cardinal; const Bit: byte): Boolean;
begin
Result := (Value and (1 shl (Bit mod 32))) <> 0;
end;
procedure GetRegisteredAntiviruses(ProgIDs: TStrings);
var
CatInformation: ICatInformation;
Enum: IEnumGUID;
CLSID: TGUID;
nFetched: Cardinal;
CatId: TGUID;
begin
CatInformation := CreateComObject(CLSID_StdComponentCategoryMgr) as ICatInformation;
CatId := CATID_MSOfficeAntiVirus;
OleCheck(CatInformation.EnumClassesOfCategories(1, @CatId, 0, nil, Enum));
ProgIDs.BeginUpdate;
try
ProgIDs.Clear;
while (Enum.Next(1, CLSID, nFetched) = S_OK) do begin
ProgIDs.Add(GuidToString(clsid));
end;
finally
ProgIDs.EndUpdate;
end;
end;
end.
Now I will show a small example how to use IOfficeAntiVirus interface to implement own antivirus program for Microsoft Office.
library msoavtest;
uses
ComServ,
msoav,
umsoavtest;
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;
begin
end.
unit umsoavtest;
interface
uses
Windows, ActiveX, ComObj, ShlObj, Dialogs, msoav;
type
TMSOTest = class(TComObject, IOfficeAntiVirus)
protected
function Scan(pmsoavinfo : PChar) : HResult; stdcall;
end;
const
Class_MsoTest: TGUID = '{F56BE781-C8BE-11D7-8601-00E0184D1E9D}';
implementation
uses ComServ, SysUtils, ShellApi, Registry;
procedure UpdateCat(Register: Boolean; const ClassID: string);
const
SCatImplBaseKey = 'CLSID\%s\Implemented Categories';
SCatImplKey = SCatImplBaseKey + '\%s';
var
CatReg: ICatRegister;
Rslt: HResult;
CatInfo: TCATEGORYINFO;
Description: string;
begin
Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
CLSCTX_INPROC_SERVER, ICatRegister, CatReg);
if Succeeded(Rslt) then
begin
if Register then
begin
CatInfo.catid := CATID_MSOfficeAntiVirus;
CatInfo.lcid := $0409;
StringToWideChar('', CatInfo.szDescription,
Length('') + 1);
OleCheck(CatReg.RegisterCategories(1, @CatInfo));
OleCheck(CatReg.RegisterClassImplCategories(StringToGUID(ClassID), 1, @CATID_MSOfficeAntiVirus));
end else
begin
OleCheck(CatReg.UnRegisterClassImplCategories(StringToGUID(ClassID), 1, @CATID_MSOfficeAntiVirus));
DeleteRegKey(Format(SCatImplBaseKey, [ClassID]));
end;
end else
begin
if Register then
begin
CreateRegKey('Component Categories\' + GUIDToString(CATID_MSOfficeAntiVirus), '409', '');
CreateRegKey(Format(SCatImplKey, [ClassID, GUIDToString(CATID_MSOfficeAntiVirus)]), '', '');
end else
begin
DeleteRegKey(Format(SCatImplKey, [ClassID, GUIDToString(CATID_MSOfficeAntiVirus)]));
DeleteRegKey(Format(SCatImplBaseKey, [ClassID]));
end;
end;
if Register then
begin
Description := GetRegStringValue('CLSID\' + ClassID, '');
CreateRegKey('AppID\' + ClassID, '', Description);
CreateRegKey('CLSID\' + ClassID, 'AppID', ClassID);
end else
DeleteRegKey('AppID\' + ClassID);
end;
{ TMSOTest }
function TMSOTest.Scan(pmsoavinfo: PChar): HResult;
var
Info : TMsoavinfo;
Struct : TInfoStruct;
p : pointer;
begin
p := pointer(pmsoavinfo);
if not Assigned(p) then
begin
//no information available
Result := S_OK;
Exit;
end;
Move(P^, Info, SizeOf(Tmsoavinfo));
if Info.cbSize <> SizeOf(Tmsoavinfo) then
begin
//wrong size of the structure
Result := S_OK;
Exit;
end;
Struct.fIsFile := TestBit(Info.Info, 0);
Struct.fIsReadOnly := TestBit(Info.Info, 1);
Struct.fIsInstalled := TestBit(Info.Info, 2);
Struct.fIsHTTPDownload := TestBit(Info.Info, 3);
if struct.fIsFile then
begin
MessageDlg(PWChar(Info.FullPath), mtWarning, [mbOK], 0);
end;
Result := S_OK;
end;
type
TMSOAvFactory = class(TComObjectFactory)
public
procedure UpdateRegistry(Register: Boolean); override;
end;
procedure TMSOAVFactory.UpdateRegistry(Register: Boolean);
var
ClassID: string;
begin
ClassID := GUIDToString(Class_MsoTest);
if Register then
begin
inherited UpdateRegistry(Register);
UpdateCat(true, ClassID);
end
else
begin
UpdateCat(false, ClassID);
inherited UpdateRegistry(Register);
end;
end;
initialization
TComObjectFactory.Create(ComServer, TMsoTest, Class_MsoTest,
'MsoTest', '', ciMultiInstance, tmApartment);
end. |
Delphi3000 --------------------
С уважением, г-н Посол. |
Пришло время создавать новую версию DRKB, Нужна помощь! 
Загрузка ...
*щёлк*
