Как получить список инсталлированных програм?
Как получить список инсталлированных програм?
uses
Registry;
procedure TForm1.Button1Click(Sender: TObject);
const
UNINST_PATH = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall';
var
Reg: TRegistry;
SubKeys: TStringList;
ListItem: TlistItem;
i: integer;
sDisplayName, sUninstallString: string;
begin
{
ListView1.ViewStyle := vsReport;
ListView1.Columns.add;
ListView1.Columns.add;
ListView1.Columns[0].caption := 'DisplayName';
ListView1.Columns[1].caption := 'UninstallString';
ListView1.Columns[0].Width := 300;
ListView1.Columns[1].Width := 300;
}
Reg := TRegistry.Create;
with Reg do
try
with ListView1.Items do
try
BeginUpdate;
Clear;
RootKey := HKEY_LOCAL_MACHINE;
if OpenKeyReadOnly(UNINST_PATH) then
begin
SubKeys := TStringList.Create;
try
GetKeyNames(SubKeys);
CloseKey;
for i := 0 to subKeys.Count - 1 do
if OpenKeyReadOnly(Format('%s\%s', [UNINST_PATH, SubKeys[i]])) then
try
sDisplayName := ReadString('DisplayName');
sUninstallString := ReadString('UninstallString');
if sDisplayName <> '' then
begin
ListItem := Add;
ListItem.Caption := sDisplayName;
ListItem.subitems.Add(sUninstallString);
end;
finally
CloseKey;
end;
finally
SubKeys.Free;
end;
end;
finally
ListView1.AlphaSort;
EndUpdate;
end;
finally
CloseKey;
Free;
end;
end;
Взято с сайта
Как получить список папок Outlook?
Как получить список папок Outlook?
uses
ComObj;
procedure RetrieveOutlookFolders(tvFolders: TTreeView);
procedure LoadFolder(ParentNode: TTreeNode; Folder: OleVariant);
var
i: Integer;
Node: TTreeNode;
begin
for i := 1 to Folder.Count do
begin
Node := tvFolders.Items.AddChild(ParentNode, Folder.Item[i].Name);
LoadFolder(Node, Folder.Item[i].Folders);
end;
end;
var
outlook, NameSpace: OLEVariant;
begin
outlook := CreateOleObject('Outlook.Application');
NameSpace := outlook.GetNameSpace('MAPI');
LoadFolder(nil, NameSpace.Folders);
outlook := Unassigned;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RetrieveOutlookFolders(TreeView1);
end;
Взято с сайта
Как получить список процессов?
Как получить список процессов?
function IsRunning( sName : string ) : boolean;
var
han : THandle;
ProcStruct : PROCESSENTRY32; // from "tlhelp32" in uses clause
sID : string;
begin
Result := false;
// Get a snapshot of the system
han := CreateToolhelp32Snapshot( TH32CS_SNAPALL, 0 );
if han = 0 then
exit;
// Loop thru the processes until we find it or hit the end
ProcStruct.dwSize := sizeof( PROCESSENTRY32 );
if Process32First( han, ProcStruct ) then
begin
repeat
sID := ExtractFileName( ProcStruct.szExeFile );
// Check only against the portion of the name supplied, ignoring case
if uppercase( copy( sId, 1, length( sName ) ) ) = uppercase( sName ) then
begin
// Report we found it
Result := true;
Break;
end;
until not Process32Next( han, ProcStruct );
end;
// clean-up
CloseHandle( han );
end;
Взято с Исходников.ru
Как получить список таблиц?
Как получить список таблиц?
A list of user tables can be retrieved by querying system table rdb$relations.
The example below shows how to do this - it inserts the table names sorted alphabetically into a ListBox (lbSourceTables).
begin
ibcSourceList.SQL.Clear;
ibcSourceList.SQL.Add('select rdb$relation_name from rdb$relations');
ibcSourceList.SQL.Add('where rdb$system_flag = 0');
ibcSourceList.SQL.Add('order by rdb$relation_name');
ibcSourceList.Open;
while not ibcSourceList.Eof do
begin
lbSourceTables.Items.Add(ibcSourceList.Fields[0].AsString);
ibcSourceList.Next;
end;
ibcSourceList.Close;
end;
Взято с
Delphi Knowledge BaseКак получить список таблиц в базе Access?
Как получить список таблиц в базе Access?
t:Tstringlist;
...
ADOConnection.GetTableNames(t)
Автор:
VitВзято из
Как получить список установленных модемов в Win95/98?
Как получить список установленных модемов в Win95/98?
unit PortInfo;
interface
uses Windows, SysUtils, Classes, Registry;
function EnumModems: TStrings;
implementation
function EnumModems: TStrings;
var
R: TRegistry;
s: ShortString;
N: TStringList;
i: integer;
j: integer;
begin
Result := TStringList.Create;
R := TRegistry.Create;
try
with R do
begin
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
if HasSubKeys then
begin
N := TStringList.Create;
try
GetKeyNames(N);
for i := 0 to N.Count - 1 do
begin
closekey; { + }
openkey('\System\CurrentControlSet\Services\Class\Modem', false); { + }
OpenKey(N[i], False);
s := ReadString('AttachedTo');
for j := 1 to 4 do
if Pos(Chr(j + Ord('0')), s) > 0 then
Break;
Result.AddObject(ReadString('DriverDesc'), TObject(j));
CloseKey;
end;
finally
N.Free;
end;
end;
end;
finally
R.Free;
end;
end;
end.
Взято с сайта
Как получить средний цвет между двумя цветами?
Как получить средний цвет между двумя цветами?
functionGetColorBetween(StartColor, EndColor: TColor; Pointvalue, Von, Bis:
Extended): TColor;
var
F: Extended;
r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
function CalcColorBytes(fb1, fb2: Byte): Byte;
begin
result := fb1;
if fb1 < fb2 then
Result := FB1 + Trunc(F * (fb2 - fb1));
if fb1 > fb2 then
Result := FB1 - Trunc(F * (fb1 - fb2));
end;
begin
if Pointvalue <= Von then
begin
result := StartColor;
exit;
end;
if Pointvalue >= Bis then
begin
result := EndColor;
exit;
end;
F := (Pointvalue - von) / (Bis - Von);
asm
mov EAX, Startcolor
cmp EAX, EndColor
je @@exit
mov r1, AL
shr EAX,8
mov g1, AL
shr Eax,8
mov b1, AL
mov Eax, Endcolor
mov r2, AL
shr EAX,8
mov g2, AL
shr EAX,8
mov b2, AL
push ebp
mov al, r1
mov dl, r2
call CalcColorBytes
pop ecx
push ebp
Mov r3, al
mov dL, g2
mov al, g1
call CalcColorBytes
pop ecx
push ebp
mov g3, Al
mov dL, B2
mov Al, B1
call CalcColorBytes
pop ecx
mov b3, al
XOR EAX,EAX
mov AL, B3
SHL EAX,8
mov AL, G3
SHL EAX,8
mov AL, R3
@@Exit:
mov @result, eax
end;
end;
//------------------------------------------------------------------------------
// Function for getting mixed color from two given colors, with a relative
// distance from two colors determined by Position value inside
// MinPosition..MaxPosition range
// Author: Dmitri Papichev (c) 2001
// License type: Freeware
//------------------------------------------------------------------------------
function GetMixedColor(const StartColor,
EndColor: TColor;
const MinPosition,
Position,
MaxPosition: integer): TColor;
var
Fraction: double;
R, G, B,
R0, G0, B0,
R1, G1, B1: byte;
begin
{process Position out of range situation}
if (MaxPosition < MinPosition) then
begin
raise Exception.Create
('GetMixedColor: MaxPosition is less then MinPosition');
end; {if}
{if Position is outside MinPosition..MaxPosition range, the closest boundary
is effectively substituted through the adjustment of Fraction}
Fraction :=
Min(1, Max(0, (Position - MinPosition) / (MaxPosition - MinPosition)));
{extract the intensity values}
R0 := GetRValue(StartColor);
G0 := GetGValue(StartColor);
B0 := GetBValue(StartColor);
R1 := GetRValue(EndColor);
G1 := GetGValue(EndColor);
B1 := GetBValue(EndColor);
{calculate the resulting intensity values}
R := R0 + Round((R1 - R0) * Fraction);
G := G0 + Round((G1 - G0) * Fraction);
B := B0 + Round((B1 - B0) * Fraction);
{combine intensities in a resulting color}
Result := RGB(R, G, B);
end; {--GetMixedColor--}
Взято с
Delphi Knowledge BaseКак получить статус принтера?
Как получить статус принтера?
function TestPrinterStatus(LPTPort: Word): Byte;
var
Status: byte;
CheckLPT: word;
begin
Status := 0;
if (LPTPort >= 1) and (LPTPort <= 3) then
begin
CheckLPT := LPTPort - 1;
asm
mov dx, CheckLPT;
mov al, 0;
mov ah, 2;
int 17h;
mov &Status, ah;
end;
end;
Result := Status;
end;
{
Pass in the LPT port number you want to check & get the following back:
01h - Timeout
08h - I/O Error
10h - Printer selected
20h - Out of paper
40h - Printer acknowledgement
80h - Printer not busy (0 if busy)
Note:
This function doesn't work under NT, it gives an access violation
from the DOS interrupt call.
}
Взято с сайта
Как получить строковое значение перечисляемого типа?
Как получить строковое значение перечисляемого типа?
procedure GetEnumNameList(Pti: PTypeInfo; AList:
TStrings; X: Integer);
{(**********************************************************
Will return in AList string version of an
enumerated type less the first X characters .
eg X = 4
and
type
eXORBuySell = (
XOR_BUY,
XOR_SELL
);
GetEnumNameList(TypeInfo(eXORBuySell), ComboBox1.Items, 4);
Now ComboBox1.Items[0] = 'BUY'
and ComboBox1.Items[1] = 'SELL'
************************************************************)}
var
I: Integer;
begin
AList.Clear;
with GetTypeData(pti)^ do
for I := MinValue to MaxValue do
AList.Add(Copy(GetEnumName(pti, I), X + 1, 255));
end;
Взято с сайта
Как получить строковый путь узла TTreeView?
Как получить строковый путь узла TTreeView?
![](image/977_1.jpg)
{*---------------------------------------------
Parent Text
---------------------------------------------*}
function SrNodeTree(pTreeNode: TTreeNode; var sRuta: string): string;
begin
sRuta := pTreeNode.Text + ' > ' + sRuta;
if pTreeNode.Level = 0 then Result := sRuta
else
Result := SrNodeTree(pTreeNode.Parent, sRuta);
end;
{*---------------------------------------------
Click an Item
---------------------------------------------*}
procedure TForm1.TreeView1Click(Sender: TObject);
var
sPath: string;
begin
label1.Caption := SrNodeTree(TreeView1.Selected, sPath);
end;
Взято с сайта
Как получить текущее время?
Как получить текущее время?
InterBase supports four DATE literals. They are: 'today', 'yesterday', 'tomorrow' and 'now'
Use it with a cast as shown in the example below.
insertinto mytable values(cast('now' as DATE), 'Test')
Взято с
Delphi Knowledge BaseКак получить текущую дату?
Как получить текущую дату?
//make the SQL dependent on type of DBMS
if AppLibrary.Database.DriverName = 'ORACLE' then
SQL.Add('and entry_date < SYSDATE')
else
SQL.Add('and entry_date < "TODAY"');
end;
Взято с
Delphi Knowledge BaseКак получить TextRange страницы без фреймов?
Как получить TextRange страницы без фреймов?
HTML_Doc := WebBrowser1.Document As IHTMLDocument2;
Window := HTML_Doc.parentWindow As IHTMLWindow2;
Body := HTML_Doc.get_body As IHTMLBodyElement;
Range := oBody.createTextRange;
Можно еще так:
var
a:IHTMLTxtRange;
a:=IHTMLDocument2(webbrowser1.Document).selection.createRange as IHTMLTxtRange;
Автор ответа: Good Man
Взято с Vingrad.ru
Как получить UNC путь к файлу?
Как получить UNC путь к файлу?
functionGetUNCName(PathStr: string): string;
var
bufSize: DWord;
buf: TUniversalNameInfo;
msg: string;
begin
bufSize := SizeOf(TUniversalNameInfo);
if (WNetGetUniversalName(PChar(PathStr), UNIVERSAL_NAME_INFO_LEVEL,
buf, bufSize) > 0) then
case GetLastError of
ERROR_BAD_DEVICE: msg := 'ERROR_BAD_DEVICE';
ERROR_CONNECTION_UNAVAIL: msg := 'ERROR_CONNECTION_UNAVAIL';
ERROR_EXTENDED_ERROR: msg := 'ERROR_EXTENDED_ERROR';
ERROR_MORE_DATA: msg := 'ERROR_MORE_DATA';
ERROR_NOT_SUPPORTED: msg := 'ERROR_NOT_SUPPORTED';
ERROR_NO_NET_OR_BAD_PATH: msg := 'ERROR_NO_NET_OR_BAD_PATH';
ERROR_NO_NETWORK: msg := 'ERROR_NO_NETWORK';
ERROR_NOT_CONNECTED: msg := 'ERROR_NOT_CONNECTED';
end
else
msg := buf.lpUniversalName;
Result := msg;
end;
Работает только на NT/2000/XP
Взято с
Delphi Knowledge BaseКак получить / установить приоритет процесса?
Как получить / установить приоритет процесса?
Const
ppIdle : Integer = -1;
ppNormal : Integer = 0;
ppHigh : Integer = 1;
ppRealTime : Integer = 2;
Function SetProcessPriority( Priority : Integer ) : Integer;
Var
H : THandle;
Begin
Result := ppNormal;
H := GetCurrentProcess();
If ( Priority = ppIdle ) Then
SetPriorityClass( H, IDLE_PRIORITY_CLASS )
Else If ( Priority = ppNormal ) Then
SetPriorityClass( H, NORMAL_PRIORITY_CLASS )
Else If ( Priority = ppHigh ) Then
SetPriorityClass( H, HIGH_PRIORITY_CLASS )
Else If ( Priority = ppRealTime ) Then
SetPriorityClass( H, REALTIME_PRIORITY_CLASS );
Case GetPriorityClass( H ) Of
IDLE_PRIORITY_CLASS : Result := ppIdle;
NORMAL_PRIORITY_CLASS : Result := ppNormal;
HIGH_PRIORITY_CLASS : Result := ppHigh;
REALTIME_PRIORITY_CLASS : Result := ppRealTime;
End;
End;
Function GetProcessPriority : Integer;
Var
H : THandle;
Begin
Result := ppNormal;
H := GetCurrentProcess();
Case GetPriorityClass( H ) Of
IDLE_PRIORITY_CLASS : Result := ppIdle;
NORMAL_PRIORITY_CLASS : Result := ppNormal;
HIGH_PRIORITY_CLASS : Result := ppHigh;
REALTIME_PRIORITY_CLASS : Result := ppRealTime;
End;
End;
Как использовать:
Function SetProcessPriority( Priority : Integer ) : Integer;
для установки приоритета Вашего приложения, либо:
Function GetProcessPriority : Integer;
для получения приоритета.
Взято с Исходников.ru
Как получить версию моей DLL?
Как получить версию моей DLL?
procedure GetFileVersion(FileName: string; var Major1, Major2,
Minor1, Minor2: Integer);
var
Info: Pointer;
InfoSize: DWORD;
FileInfo: PVSFixedFileInfo;
FileInfoSize: DWORD;
Tmp: DWORD;
begin
InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
if InfoSize = 0 then
//Файл не содержит информации о версии
else
begin
GetMem(Info, InfoSize);
try
GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info);
VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize);
Major1 := FileInfo.dwFileVersionMS shr 16;
Major2 := FileInfo.dwFileVersionMS and $FFFF;
Minor1 := FileInfo.dwFileVersionLS shr 16;
Minor2 := FileInfo.dwFileVersionLS and $FFFF;
finally
FreeMem(Info, FileInfoSize);
end;
end;
end;
Взято с Исходников.ru
Как получить версию Windows?
Как получить версию Windows?
Type TOSVersion=(osUnknown, osUnknown9x, osUnknownNT, osWin95, osWin98, osWin98SE, osWinME, osWinNT, osWin2000, osXP);
function GetOSVersion : TOSVersion;
var osVerInfo : TOSVersionInfo;
majorVer, minorVer : Integer;
begin
result := OsUnknown;
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
majorVer := osVerInfo.dwMajorVersion;
minorVer := osVerInfo.dwMinorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT :
Case majorVer of
4:result := OsWinNT;
5:if minorVer=0 then result := OsWin2000
else
if minorVer=1 then result := OsXP else result := osUnknownNT;
else result := osUnknownNT;
end; {Case majorVer of}
VER_PLATFORM_WIN32_WINDOWS :
case majorVer of
4: Case minorVer of
0:result := OsWin95;
10: if osVerInfo.szCSDVersion[1] = 'A' then result := OsWin98SE else result := OsWin98;
90: result := OsWinME;
else result := osUnknown9x;
end;{Case minorVer of}
else result := osUnknown9x;
end{case majorVer of}
else result := OsUnknown;
end;{case osVerInfo.dwPlatformId of}
end;{if GetVersionEx(osVerInfo) then}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
case GetOSVersion of
osUnknown: Showmessage('Unknown');
osWin95: Showmessage('Win95');
osWin98: Showmessage('Win98');
osWin98SE: Showmessage('Win98SE');
osWinME: Showmessage('WinME');
osWinNT: Showmessage('WinNT');
osWin2000: Showmessage('Win2000');
osXP: Showmessage('XP');
end;
end;
Как получить версию Windows?
procedure TForm1.WinVer;
var WinV: Word;
begin
WinV := GetVersion AND $0000FFFF;
Edit6.Text := IntToStr(Lo(WinV))+'.'+IntToStr(Hi(WinV));
end;
Функция выдает следующее - 4.10
Как можно таким же простым способом получить полную версию - 4.10.222
Автор ответа: inko
Взято с Vingrad.ru
Как получить версию Windows?
Вот еще один пример. Мне он нравиться больше всего. Я его обычно использую в своих программах. Он гибкий и предоставляет максимум информации.
{Объявление процедур и констант}
function GetWindowsVersion1: string;
function WhatWindowsIsInstalled : String;
const
VER_NT_WORKSTATION = 0;
VER_NT_DOMAIN_CONTROLLER = 1;
VER_NT_SERVER = 2;
VER_SUITE_SMALLBUSINESS = 1;
VER_SUITE_ENTERPRISE = 2;
VER_SUITE_BACKOFFICE = 4;
VER_SUITE_COMMUNICATIONS = 8;
VER_SUITE_TERMINAL = $10;
VER_SUITE_SMALLBUSINESS_RESTRICTED = $20;
VER_SUITE_EMBEDDEDNT = $40;
VER_SUITE_DATACENTER = $80;
VER_SUITE_SINGLEUSERTS = $100;
VER_SUITE_PERSONAL = $200;
VER_SUITE_BLADE = $400;
type
TOsVersionInfoExA = packed record
old : TOsVersionInfoA;
wServicePackMajor : Word;
wServicePackMinor : Word;
{
wSuiteMask
Набор битовых флагов, определяющих компоненты Windows
VER_SUITE_BACKOFFICE Установлен компонент Microsoft BackOffice.
VER_SUITE_BLADE Установлен компонент Windows .NET Web Server.
VER_SUITE_DATACENTER Установлена Windows 2000 или компонент Windows .NET
Datacenter Server
VER_SUITE_ENTERPRISE Установлена Windows 2000 Advanced Server или компонент
Windows .NET Enterprise Server.
VER_SUITE_PERSONAL Установлена Windows XP Home Edition.
VER_SUITE_SMALLBUSINESS Установлен Microsoft Small Business Server.
VER_SUITE_SMALLBUSINESS_RESTRICTED Установлен Microsoft Small Business
Server с ограничительной лицензией для клиентов
VER_SUITE_TERMINAL Установлен компонент Terminal Services.
}
wSuiteMask : Word;
{wProductType Дополнительная информация о типе операционной системы
VER_NT_WORKSTATION Операционная система Windows NT 4.0 Workstation,
Windows 2000 Professional,
Windows XP Home Edition, или
Windows XP Professional.
VER_NT_DOMAIN_CONTROLLER Операционная система является контроллером домена.
VER_NT_SERVER Операционная система является сервером.
}
wProductType : Byte;
wReserved : Byte;
end;
...
{Реализация}
function WhatWindowsIsInstalled : String;
var VerInfo : TOsVersionInfoExA;
begin
FillChar(VerInfo, sizeof(VerInfo), 0);
VerInfo.old.dwOSVersionInfoSize := Sizeof(TOsVersionInfoExA);
if NOT GetVersionExA(VerInfo.old) then
begin
VerInfo.old.dwOSVersionInfoSize := Sizeof(TOsVersionInfoA);
GetVersionExA(VerInfo.old);
end;
case VerInfo.old.dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS:
if (Verinfo.old.dwMajorVersion = 4) AND
(Verinfo.old.dwBuildNumber = 950) then Result := 'Windows 95' else
if (Verinfo.old.dwMajorVersion = 4) AND
(Verinfo.old.dwMinorVersion = 10) AND
(Verinfo.old.dwBuildNumber = 1998) then Result := 'Windows 98' else
if (Verinfo.old.dwMinorVersion = 90) then Result := 'Windows Me';
VER_PLATFORM_WIN32_NT:
if Verinfo.old.dwMajorVersion = 3 then Result := 'Windows NT 3.51' else
if Verinfo.old.dwMajorVersion = 4 then Result := 'Windows NT 4.0' else
if Verinfo.old.dwMajorVersion = 5 then
if Verinfo.old.dwMinorVersion = 0 then Result := 'Windows 2000' else
if Verinfo.old.dwMinorVersion = 1 then Result := 'Windows XP';
VER_PLATFORM_WIN32s: Result := 'Win32s';
end;
end;
function GetWindowsVersion1: string;
{$IFDEF WIN32}
const sWindowsVersion = '%.3d';
var
Ver: TOsVersionInfo;
Platform: string[4];
begin
Ver.dwOSVersionInfoSize := SizeOf(Ver);
GetVersionEx(Ver);
with Ver do begin
case dwPlatformId of
VER_PLATFORM_WIN32s: Platform := '32s';
VER_PLATFORM_WIN32_WINDOWS:
begin
dwBuildNumber := dwBuildNumber and $0000FFFF;
if (dwMajorVersion > 4) or ((dwMajorVersion = 4) and (dwMinorVersion >= 10)) then Platform := '98'
else Platform := '95';
end;
VER_PLATFORM_WIN32_NT: Platform := 'NT';
end;
Result := Trim(Format(sWindowsVersion, [dwBuildNumber]));
end;
end;
{$ELSE}
const
sWindowsVersion = 'Windows%s %d.%d';
sNT: array[Boolean] of string[3] = ('', ' NT');
var
Ver: Longint;
begin
Ver := GetVersion;
Result := Format(sWindowsVersion, [sNT[not Boolean(HiByte(LoWord(Ver)))],
LoByte(LoWord(Ver)), HiByte(LoWord(Ver))]);
end;
{$ENDIF WIN32}
Пример вызова
Label1.Caption := WhatWindowsIsInstalled+' (Build '+GetWindowsVersion1+')';
Автор Pegas
Взято с Vingrad.ru
Как получить весь размер системной памяти?
Как получить весь размер системной памяти?
function GetMemoryTotalPhys : DWord;
var
memStatus: TMemoryStatus;
begin
memStatus.dwLength := sizeOf ( memStatus );
GlobalMemoryStatus ( memStatus );
Result := memStatus.dwTotalPhys;
end;
Взято с Исходников.ru
Как получить закэшированные пароли в Win9x?
Как получить закэшированные пароли в Win9x?
program getpass;
........
type
...
ListBox: TListBox;
procedure getpasswords;
.......
end;
const Count: Integer = 0;
function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; stdcall;
implementation
{$R *.DFM}
function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; external mpr name 'WNetEnumCachedPasswords';
type
PWinPassword = ^TWinPassword;
TWinPassword = record
EntrySize: Word;
ResourceSize: Word;
PasswordSize: Word;
EntryIndex: Byte;
EntryType: Byte;
PasswordC: Char;
end;
var
WinPassword: TWinPassword;
function AddPassword(WinPassword: PWinPassword; dw: DWord): LongBool; stdcall;
var
Password: String;
PC: Array[0..$FF] of Char;
begin
inc(Count);
Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize);
PC[WinPassword.ResourceSize] := #0;
CharToOem(PC, PC);
Password := StrPas(PC);
Move(WinPassword.PasswordC, PC, WinPassword.PasswordSize + WinPassword.ResourceSize);
Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize);
PC[WinPassword.PasswordSize] := #0;
CharToOem(PC, PC);
Password := Password + ': ' + StrPas(PC);
Form1.ListBox.Items.Add(Password);
Result := True;
end;
procedure tform1.getpasswords;
var error: string;
begin
if WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then
begin
error := 'Can not load passwords: User is not loged on.';
end
else if Count = 0 then
error := 'No passwords found...'
end;
Взято с Исходников.ru
Как получить значение свойства в виде варианта по тексту имени свойства?
Как получить значение свойства в виде варианта по тексту имени свойства?
unitMorePropInfo;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TFrmMorePropInfo = class(TForm)
Button1: TButton;
Button2: TButton;
ListBox1: TListBox;
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FrmMorePropInfo: TFrmMorePropInfo;
implementation
{$R *.DFM}
uses
TypInfo;
procedure GetPropertyValues(AObj: TObject; AValues: TStrings);
var
count: integer;
data: PTypeData;
default: string;
i: integer;
info: PTypeInfo;
propList: PPropList;
propInfo: PPropInfo;
propName: string;
value: variant;
begin
info := AObj.ClassInfo;
data := GetTypeData(info);
GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
try
count := GetPropList(info, tkAny, propList);
for i := 0 to count - 1 do
begin
propName := propList^[i]^.Name;
propInfo := GetPropInfo(info, propName);
if propInfo <> nil then
begin
case propInfo^.PropType^.Kind of
tkClass, tkMethod:
value := '$' + IntToHex(GetOrdProp(AObj, propInfo), 8);
tkFloat:
value := GetFloatProp(AObj, propInfo);
tkInteger:
value := GetOrdProp(AObj, propInfo);
tkString, tkLString, tkWString:
value := GetStrProp(AObj, propInfo);
tkEnumeration:
value := GetEnumProp(AObj, propInfo);
else
value := '???';
end;
if propInfo.default = longint($80000000) then
default := 'none'
else
default := IntToStr(propInfo.default);
AValues.Add(Format('%s: %s [default: %s]', [propName, value, default]));
{$80000000 apparently indicates "no default"}
end;
end;
finally
FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
end;
end;
procedure TFrmMorePropInfo.Button2Click(Sender: TObject);
var
count: integer;
data: PTypeData;
i: integer;
info: PTypeInfo;
propList: PPropList;
propInfo: PPropInfo;
propName: string;
propVal: variant;
tmpS: string;
begin
info := Button2.ClassInfo;
data := GetTypeData(info);
GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
try
count := GetPropList(info, tkAny, propList);
ListBox1.Clear;
for i := 0 to count - 1 do
begin
propName := propList^[i]^.Name;
propInfo := GetPropInfo(info, propName);
if propInfo <> nil then
begin
case propInfo^.PropType^.Kind of
tkClass, tkMethod:
propVal := '$' + IntToHex(GetOrdProp(Button2, propInfo), 8);
tkFloat:
propVal := GetFloatProp(Button2, propInfo);
tkInteger:
propVal := GetOrdProp(Button2, propInfo);
tkString, tkLString, tkWString:
propVal := GetStrProp(Button2, propInfo);
tkEnumeration:
propVal := GetEnumProp(Button2, propInfo);
else
propVal := '...';
end;
tmpS := propVal;
ListBox1.Items.Add(Format('%s: %s [default: %s]', [propName, tmpS, '$'
+ IntToHex(propInfo.default, 8)]));
{$80000000 apparently indicates "no default"}
end;
end;
finally
FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
end;
end;
end.
Tip by Ralph Friedman
Взято из
Как получитьописание кода, полученного GetLastError?
Как получитьописание кода, полученного GetLastError?
Функция RTL SysErrorMessage(GetLastError).
procedure TForm1.Button1Click(Sender: TObject);
begin
{Cause a Windows system error message to be logged}
ShowMessage(IntToStr(lStrLen(nil)));
ShowMessage(SysErrorMessage(GetLastError));
end;
Как пользоваться командой шела - MinimizeAll?
Как пользоваться командой шела - MinimizeAll?
Для этого надо импортировать Microsoft Shell Controls & Automation Type Library.
В меню Project..Import Type Library
Выберите Microsoft Shell Controls & Automation (version 1.0).
Нажмите Install...
На панели компонентов, в закладке ActiveX появится несколько компонентов. Перетащите на форму компонент TShell. После этого, например, можно всё минимизировать:
Shell1.MinimizeAll;
/*********************************************************************
Так же в этом компоненте присутствует давольно много забавных примочек.
*********************************************************************/
procedure TForm1.Shell(sMethod: Integer);
begin
case sMethod of
0:
//Минимизируем все окна на рабочем столе
begin
Shell1.MinimizeAll;
Button1.Tag := Button1.Tag + 1;
end;
1:
//Показываем диалоговое окошко Run
begin
Shell1.FileRun;
Button1.Tag := Button1.Tag + 1;
end;
2:
//Показываем окошко завершения работы Windows
begin
Shell1.ShutdownWindows;
Button1.Tag := Button1.Tag + 1;
end;
3:
//Показываем окно поиска файлов
begin
Shell1.FindFiles;
Button1.Tag := Button1.Tag + 1;
end;
4:
//Отображаем окно настройки времени и даты
begin
Shell1.SetTime;
Button1.Tag := Button1.Tag + 1;
end;
5:
//Показываем диалоговое окошко настройки интернета (Internet Properties)
begin
Shell1.ControlPanelItem('INETCPL.cpl');
Button1.Tag := Button1.Tag + 1;
end;
6:
//Предлагаем пользователю выбрать директорию из Program Files
begin
Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files');
Button1.Tag := Button1.Tag + 1;
end;
7:
//Показываем диалоговое окошко настройки панели задач
begin
Shell1.TrayProperties;
Button1.Tag := Button1.Tag + 1;
end;
8:
//Восстанавливаем все окна на рабочем столе
begin
Shell1.UndoMinimizeAll;
Button1.Tag := 0;
end;
end; {case}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Shell(Button1.Tag);
end;
Взято с Исходников.ru
Как поменять border страницы?
Как поменять border страницы?
{... }
var
Rng: OleVariant;
LeftEdge: Border;
{ ... }
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Weight := xlThick;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Color := clYellow;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Linestyle := xlDouble;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Color := clYellow;
{ ... }
{ ... }
WS.Evaluate('B6, C6, D6, E6, F6').Borders.Item[xlEdgeLeft].Line
style := xlContinuous;
Rng := WS.Range['A1', 'A1'];
Rng.BorderAround(xlContinuous, xlThin, Color := clFuchsia);
LeftEdge := WS.Range['B2', 'B5'].Borders.Item[xlEdgeLeft];
LeftEdge.Linestyle := xlContinuous;
LeftEdge.Weight := 3;
LeftEdge.Color := clLime;
{ ... }
Взято с
Delphi Knowledge BaseКак поменять функции кнопок мышки?
Как поменять функции кнопок мышки?
Begin
//---------
SwapMouseButton(true); // Поменять обратно - SwapMouseButton(false);
//---------
end;
Взято с Исходников.ru
Как поменять иконку и стpокy в заголовке консольного окна?
Как поменять иконку и стpокy в заголовке консольного окна?
procedureTForm1.Button1Click(Sender: TObject);
var
h: HWND;
AIcon: TIcon;
begin
AllocConsole;
SetConsoleTitle(PChar('Console Title'));
Sleep(0);
h := FindWindow(nil, PChar('Console Title'));
AIcon := TIcon.Create;
ImageList1.GetIcon(0, AIcon);
SendMessage(h, WM_SETICON, 1, AIcon.Handle);
AIcon.Free;
end;
Взято с
Как поменять приоритет моего приложения?
Как поменять приоритет моего приложения?
procedureTForm1.Button1Click(Sender: TObject);
var
ProcessID: DWORD;
ProcessHandle: THandle;
ThreadHandle: THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
false, ProcessID);
SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;
Взято с
Как поменять ссылку в тексте?
Как поменять ссылку в тексте?
{... }
Doc := Word.ActiveDocument;
for x := 1 to Doc.Hyperlinks.Count do
begin
Doc.Hyperlinks.Item(x).Address;
end;
{ ... }
Взято с
Delphi Knowledge BaseКак поместить битмап в метафайл
Как поместить битмап в метафайл
Следующий пример демонстрирует рисование битмапа в метафайле.
procedure TForm1.Button1Click(Sender: TObject);
var
m : TmetaFile;
mc : TmetaFileCanvas;
b : tbitmap;
begin
m := TMetaFile.Create;
b := TBitmap.create;
b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
m.Height := b.Height;
m.Width := b.Width;
mc := TMetafileCanvas.Create(m, 0);
mc.Draw(0, 0, b);
mc.Free;
b.Free;
m.SaveToFile('C:\SomePath\Test.emf');
m.Free;
Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;
Взято с Исходников.ru
Как поместить ComboBox в ячейку StringGrid?
Как поместить ComboBox в ячейку StringGrid?
Следующий пример демонстрирует всплывающий ComboBox в качестве местного редактора для компонента TStringGrid:
procedure TForm1.FormCreate(Sender: TObject);
begin
{Высоту у combobox не получится установить, поэтому мы будем}
{подгонять размер у грида под размер combobox!}
StringGrid1.DefaultRowHeight := ComboBox1.Height;
{Скрываем combobox}
ComboBox1.Visible := False;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
{Получаем выбранный элемент из ComboBox и помещаем его в грид}
StringGrid1.Cells[StringGrid1.Col,
StringGrid1.Row] :=
ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False;
StringGrid1.SetFocus;
end;
procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
{Получаем выбранный элемент из ComboBox и помещаем его в грид}
StringGrid1.Cells[StringGrid1.Col,
StringGrid1.Row] :=
ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False;
StringGrid1.SetFocus;
end;
procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col,
Row: Integer; var CanSelect: Boolean);
var
R: TRect;
begin
if ((Col = 3) AND
(Row <> 0)) then begin
{Размер и расположение combobox подгоняем под ячейку}
R := StringGrid1.CellRect(Col, Row);
R.Left := R.Left + StringGrid1.Left;
R.Right := R.Right + StringGrid1.Left;
R.Top := R.Top + StringGrid1.Top;
R.Bottom := R.Bottom + StringGrid1.Top;
ComboBox1.Left := R.Left + 1;
ComboBox1.Top := R.Top + 1;
ComboBox1.Width := (R.Right + 1) - R.Left;
ComboBox1.Height := (R.Bottom + 1) - R.Top;
{Показываем combobox}
ComboBox1.Visible := True;
ComboBox1.SetFocus;
end;
CanSelect := True;
end;
Взято с Исходников.ru
Как поместить данные в RichEdit контрол?
Как поместить данные в RichEdit контрол?
unit dbrich;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, DB, DBTables, Menus, ExtCtrls, Mask, Buttons, DBCtrls;
//Замечание: вызывать Tablex.Edit необходимо перед изменением свойства paragraph
type
TDBRichEdit = class(TRichEdit)
private
FDataLink: TFieldDataLink;
FAutoDisplay: Boolean;
FFocused: Boolean;
FMemoLoaded: Boolean;
FPaintControl: TPaintControl;
procedure DataChange(Sender: TObject);
procedure EditingChange(Sender: TObject);
function GetDataField: string;
function GetDataSource: TDataSource;
function GetField: TField;
function GetReadOnly: Boolean;
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure SetReadOnly(Value: Boolean);
procedure SetAutoDisplay(Value: Boolean);
procedure SetFocused(Value: Boolean);
procedure UpdateData(Sender: TObject);
procedure WMCut(var Message: TMessage); message WM_CUT;
procedure WMPaste(var Message: TMessage); message WM_PASTE;
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
message WM_LBUTTONDBLCLK;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
protected
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure WndProc(var Message: TMessage); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LoadMemo;
property Field: TField read GetField;
published
property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay
default True;
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property ReadOnly: Boolean read GetReadOnly write SetReadOnly
default False;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls', [TDBRichEdit]);
end;
{Mostly copied from DBMemo}
constructor TDBRichEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
inherited ReadOnly := True;
FAutoDisplay := True;
FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
FDataLink.OnEditingChange := EditingChange;
FDataLink.OnUpdateData := UpdateData;
FPaintControl := TPaintControl.Create(Self, 'EDIT');
end;
destructor TDBRichEdit.Destroy;
begin
FPaintControl.Free;
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TDBRichEdit.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
if FMemoLoaded then
begin
if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
FDataLink.Edit;
end else
Key := 0;
end;
procedure TDBRichEdit.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if FMemoLoaded then
begin
if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
not FDataLink.Field.IsValidChar(Key) then
begin
MessageBeep(0);
Key := #0;
end;
case Key of
^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
FDataLink.Edit;
#27:
FDataLink.Reset;
end;
end else
begin
if Key = #13 then LoadMemo;
Key := #0;
end;
end;
procedure TDBRichEdit.Change;
begin
with FdataLink do
begin
{if Assigned(FdataLink) and (Assigned(DataSource))and
(DataSource.State = dsBrowse) then
Edit; } {make sure edits on Attributes change}
if FMemoLoaded then Modified;
end;
FMemoLoaded := True;
inherited Change;
end;
function TDBRichEdit.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBRichEdit.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
function TDBRichEdit.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;
procedure TDBRichEdit.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;
function TDBRichEdit.GetReadOnly: Boolean;
begin
Result := FDataLink.ReadOnly;
end;
Взято с Исходников.ru
Как поместить иконку в окошко подсказки?
Как поместить иконку в окошко подсказки?
Следующий код помещает главную иконку приложения в окошки подсказок:
unit HintX;
interface
uses
Windows, Messages, Controls;
type
TIconHintX = class(THintWindow)
protected
procedure Paint; override;
public
function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
end;
implementation
uses Forms;
{ TIconHintX }
{-Вычисляем новый размер окошка подсказки для помещения в него иконки:-}
function TIconHintX.CalcHintRect(MaxWidth: Integer; const AHint: string;
AData: Pointer): TRect;
begin
Result := inherited CalcHintRect(MaxWidth, AHint, AData); Result.Right := (Length(AHint) * 5) + Application.Icon.Width;
Result.Bottom := (Application.Icon.Height) * 2;
end;
procedure TIconHintX.Paint;
const
MARGIN = 5;
begin
inherited;
Canvas.Draw(MARGIN, MARGIN * 5, Application.Icon);
SendMessage(Handle, WM_NCPAINT, 0, 0); //рисуем рамку окошка подсказки
end;
initialization
//связываем наш новый класс с классом окошка подсказки установленным поумолчанию:
HintWindowClass := TIconHintX;
end.
Чтобы увидеть это в действии, всё, что надо сделать, это поместить этот юнит список USES Вашего приложения
Взято с Исходников.ru
Как поместить JPEG-картинку в exe-файл и потом загрузить ее?
Как поместить JPEG-картинку в exe-файл и потом загрузить ее?
1)Создайте текстовый файл с расширением ".rc".Имя этого файла должно отличаться
от имени файла - пректа или любого модуля проекта.
Файл должен содержать строку вроде: MYJPEG JPEG C: \DownLoad\MY.JPG
где:
"MYJPEG" имя ресурса
"JPEG" пользовательский тип ресурса
"C: \DownLoad\MY.JPG" руть к JPEG файлу.
Пусть например rc - файл называется "foo.rc"
Запустите BRCC32.exe(Borland Resource CommandLine Compiler) - программа находится
в каталоге Bin Delphi / C + +Builder'а - передав ей в качестве параметра полный путь
к rc - файлу.
В нашем примере:
C: \DelphiPath\BIN\BRCC32.EXE C: \ProjectPath\FOO.RC
Вы получите откомпилированный ресурс - файл с расширением ".res".
(в нашем случает foo.res).
Далее добавте ресурс к своему приложению.
{Грузим ресурс}
{$R FOO.RES}
uses Jpeg;
procedure LoadJPEGFromRes(TheJPEG: string; ThePicture: TPicture);
var
ResHandle: THandle;
MemHandle: THandle;
MemStream: TMemoryStream;
ResPtr: PByte;
ResSize: Longint;
JPEGImage: TJPEGImage;
begin
ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
MemHandle := LoadResource(hInstance, ResHandle);
ResPtr := LockResource(MemHandle);
MemStream := TMemoryStream.Create;
JPEGImage := TJPEGImage.Create;
ResSize := SizeOfResource(hInstance, ResHandle);
MemStream.SetSize(ResSize);
MemStream.Write(ResPtr^, ResSize);
FreeResource(MemHandle);
MemStream.Seek(0, 0);
JPEGImage.LoadFromStream(MemStream);
ThePicture.Assign(JPEGImage);
JPEGImage.Free;
MemStream.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
LoadJPEGFromRes('MYJPEG', Image1.Picture);
end;
Как поместить картинки в Combo Box?
Как поместить картинки в Combo Box?
Автор: Allan Carlton
Делается это при помощи стиля ownerdraw, который присутствует в TComboBox. Нас интересуют два свойства этого стиля:
csOwnerDrawFixed - используется, если все битмапы имеют одинаковую высоту
csOwnerDrawVariable - используется для битмапов с разной высотой
После того как стиль будет установлен на один из вышеперечисленных, то можно воспользоваться событием onDrawItem. Это событие возникает каждый раз, когда приложению необходимо нарисовать пункт в выпадающем списке (combo box). Событие определяется следующим образом:
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState)
Если выпадающему списку был присвоен стиль csOwnerDrawFixed, то всё, что надо сделать, это написать процедуру, которая будет рисовать битмап и текст в событии onDrawItem.
Для выпадающего списка со стилем csOwnerDrawVariable необходимо пройти ещё одну дополнительную стадию. Заключается эта стадия в создании обработчика для события onMeasureItem. Это событие вызывается перед DrawItem, для того, чтобы Вы могли установить фактическую высоту для каждого элемента списка. Вот его определение:
procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
Создайте новое приложение
Разместите на форме combobox и imagelist (если Вы используете delphi 1, то Вам прийдётся хранить битмапы каким-то другим способом)
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index:Integer; Rect: TRect; State: TOwnerDrawState);
begin
(* Заполняем прямоугольник *)
combobox1.canvas.fillrect(rect);
(* Рисуем сам битмап *)
imagelist1.Draw(comboBox1.Canvas,rect.left,rect.top,Index);
(* Пишем текст после картинки *)
combobox1.canvas.textout(rect.left+imagelist1.width+2,rect.top,
combobox1.items[index]);
end;
Взято с Исходников.ru
Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?
Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?
) Предполагается, что поле BLOB (например, Pict)
2) в запросе Query.SQL пишется что-то вроде
'select Pict from sometable where somefield=somevalue'
3) запрос открывается
4) делается "присваивание":
Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
или, если известно, что эта картинка - Bitmap, то можно
Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))
А можно воспользоваться компонентом TDBImage.
Зайцев О.В.
Владимиров А.М.
Взято с Исходников.ru
Как поместить картинку в заголовок TListView?
Как поместить картинку в заголовок TListView?
Иногда бывает полезно в заголовке колонки показывать стрелочку, чтобы информировать пользователя, по какой колонке идёт сортировка. Добавьте следующий код в форму:
procedure TForm1.SetColumnImage( List: TListView; Column, Image: Integer;
ShowImage: Boolean);
var
Align,hHeader: integer;
HD: HD_ITEM;
begin
hHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0);
with HD do
begin
case List.Columns[Column].Alignment of
taLeftJustify: Align := HDF_LEFT;
taCenter: Align := HDF_CENTER;
taRightJustify: Align := HDF_RIGHT;
else
Align := HDF_LEFT;
end;
mask := HDI_IMAGE or HDI_FORMAT;
pszText := PChar(List.Columns[Column].Caption);
if ShowImage then
fmt := HDF_STRING or HDF_IMAGE or HDF_BITMAP_ON_RIGHT
else
fmt := HDF_STRING or Align;
iImage := Image;
end;
SendMessage(hHeader, HDM_SETITEM, Column, Integer(@HD));
end;
Картинки берутся из списка SmallImages. Вам надо будет вызвать эту функцию для каждой колонки и установить ShowImage в TRUE для той колонки, которую Вы будете сортировать. Сделать это можно в функции OnColumnClick():
procedure TForm1.ListView1ColumnClick(Sender: TObject;
Column: TListColumn);
var
i : integer;
begin
// Это Ваша собственная функция сортировки
CustomSort( @CustomSortProc, Column.Index );
// Этот цикл отображает иконку в выбранной колонке.
for i := 0 to ListView1.Columns.Count-1 do
SetColumnImage( ListView1, i, 0, i = Column.Index );
end;
Проблема: Изменение размера колонки генерирует сообщение WM_PAINT, которое стирает картинку, поэтому Вам прийдётся переопределить WM_PAINT и вызвать SetColumnImage снова.
Использовался компонент TApplicationEvents в delphi 5.
Взято с Исходников.ru
Как поместить курсор мышки в нужное место на форме?
Как поместить курсор мышки в нужное место на форме?
uses
Windows;
procedure PlaceMyMouse(Sender: TForm; X, Y: word);
var
MyPoint: TPoint;
begin
MyPoint := Sender.ClientToScreen(Point(X, Y));
SetCursorPos(MyPoint.X, MyPoint.Y);
end;
Взято с Исходников.ru
Как поместить маленькие битмапы в TPopUpMenu?
Как поместить маленькие битмапы в TPopUpMenu?
Следующий пример демонстрирует добавление битмапа в пункт PopUpMenu при помощи API функции SetMenuItemBitmaps(). Эта функция имеет следующие параметры: дескриптор всплывающего меню, номер (начиная с нуля) пункта меню в который мы хотим добаить битмап, и два дескриптора битмапов (одна картинка для меню в активном состоянии, а вторая для неактивного состояния).
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
Pop11: TMenuItem;
Pop21: TMenuItem;
Pop31: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
bmUnChecked : TBitmap;
bmChecked : TBitmap;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
bmUnChecked := TBitmap.Create;
bmUnChecked.LoadFromFile(
'C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
bmChecked := TBitmap.Create;
bmChecked.LoadFromFile(
'C:\Program Files\Borland\BitBtns\CHECK.BMP');
{Добавляем битмапы в пункт меню начиная с 1 в PopUpMenu}
SetMenuItemBitmaps(PopUpMenu1.Handle,
1,
MF_BYPOSITION,
BmUnChecked.Handle,
BmChecked.Handle);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
bmUnChecked.Free;
bmChecked.Free;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
pt : TPoint;
begin
pt := ClientToScreen(Point(x, y));
PopUpMenu1.Popup(pt.x, pt.y);
end;
Взято с Исходников.ru
Как поместить окно програмы поверх всех?
Как поместить окно програмы поверх всех?
Если навсегда - то поставить у формы FormStyle свойство в fsStayonTop,
если надо чтобы просто программа была установлена в активное состояние (как будто кликнули на ней на таскбаре) - Application.BringtoFront
Кроме того можно играться API функцией ShowWindow передавая ей Form1.Handle, или Application.Handle и один из кучи параметров - посмотри на нее Help - там много вариантов.
Автор ответа: Vit
Взято с Vingrad.ru
Как поместить приложение в автозапуск Windows?
Как поместить приложение в автозапуск Windows?
Для этого надо добавить ключ в реестр:
procedure SetAutorun(aProgTitle,aCmdLine: string; aRunOnce: boolean );
var
hKey: string;
hReg: TRegIniFile;
begin
if aRunOnce then hKey := 'Once'
else
hKey := '';
hReg := TRegIniFile.Create( '' );
hReg.RootKey := HKEY_LOCAL_MACHINE;
hReg.WriteString('Software\Microsoft\Windows\CurrentVersion\Run'
+ hKey + #0,
aProgTitle,
aCmdLine );
hReg.destroy;
end;
Взято с Исходников.ru
Как поместить ProgressBar в панель StatusBar?
Как поместить ProgressBar в панель StatusBar?
Корректнее было бы самому канву рисовать, но можно и просто вставить - держи функцию для этого - применять вместо стандартного метода Create.
FunctionCreateProgressBar(StatusBar:TStatusBar; index:integer):TProgressBar;
var findleft:integer;
i:integer;
begin
result:=TProgressBar.create(Statusbar);
result.parent:=Statusbar;
result.visible:=true;
result.top:=2;
findleft:=0;
for i:=0 to index-1 do
findleft:=findleft+Statusbar.Panels[i].width+1;
result.left:=findleft;
result.width:=Statusbar.Panels[index].width-4;
result.height:=Statusbar.height-2;
end;
Автор ответа: Vit
Взято с Vingrad.ru
Есть два принципиально разных решения. Первый вариант - это сделать все " вручную" .
Здесь создается Bitmap с текстом (возможно любое изображение). Чтобы нарисовать светлую часть полосы, достаточно скопировать кусок Bitmap на StatusBar, а чтобы нарисовать темную часть полосы, нужно скопировать кусок Bitmap с инвертированием. При этом фон станет темным, а текст светлым. Реализация ясна из самой программы.
Второй вариант более простой в реализации, но и менее функциональный. StatusBar является наследником TWinControl, а следовательно, на нем можно разместить еще какие-то компоненты. Но сделать это можно только динамически (непосредственно из программы). На StatusBar помещается компонент ProgressBar, вначале невидимый. Когда в нем появляется необходимость, его нужно сделать видимым и начать изменять свойство Position.
Из этого примера хорошо видны некоторые достоинства и недостатки объектов.
Если у Вас Delphi3, то строчка pb.Smooth := true; работать не будет. На сайте выложена версия программы с заменой этой строчки. Впрочем, ее можно просто удалить - принципиально это ничего не изменит. Скачать все необходимые для компиляции файлы проекта можно на program.dax.ru.
Способ 1
uses Commctrl;
const
MaxProgress = 50;
var
bm: TBitmap;
// Возвращает прямоугольник нулевой панели:
function GetPanelRect: TRect;
begin
SendMessage(Form1.StatusBar1.Handle, SB_GETRECT, 0,
integer(@result));
InflateRect(result, -1, -1);
end;
// Копирует часть bm на StatusBar
procedure CopyPart(left, right: integer; ACopyMode: TCopyMode);
var bmRect, pnRect: TRect;
begin
bmRect := Rect(left, 0, right, bm.Height - 1);
pnRect := bmRect;
with GetPanelRect do
OffsetRect(pnRect, Left, Top);
with Form1.StatusBar1.Canvas do begin
CopyMode := ACopyMode;
CopyRect(pnRect, bm.Canvas, bmRect);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with StatusBar1.Panels.Add do begin
Width := 100;
Style := psOwnerDraw;
end;
with StatusBar1.Panels.Add do begin
Width := 0;
Text := 'abc';
end;
Timer1.Enabled := false;
Timer1.Interval := 50;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := true;
bm := TBitmap.Create;
with GetPanelRect do begin
bm.Width := Right - Left;
bm.Height := Bottom - Top;
end;
with bm.Canvas do begin
Brush.Color := clSilver;
FillRect(Bounds(0, 0, bm.Width, bm.Height));
TextOut(1, 1, 'Doing smth...');
end;
CopyPart(0, bm.Width - 1, cmSrcCopy); // Вывод текста
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Tag := Timer1.Tag + 1;
if Timer1.Tag > MaxProgress then begin
Timer1.Enabled := false;
Timer1.Tag := 0;
StatusBar1.Repaint; // Очистка StatusBar
end else
// Вывод только что закрашенной части:
CopyPart(trunc((Timer1.Tag - 1) / MaxProgress * bm.Width),
trunc(Timer1.Tag / MaxProgress * bm.Width), cmNotSrcCopy);
end;
procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
var p: integer;
begin
if (Panel.Index = 0) and (Timer1.Tag > 0) then begin
p := round((Rect.Right - Rect.Left) * Timer1.Tag / MaxProgress);
// Вывод закрашенной части:
CopyPart(0, p, cmNotSrcCopy);
// Вывод незакрашенной части:
CopyPart(p + 1, bm.Width - 1, cmSrcCopy);
end;
end;
Способ 2
uses Commctrl;
const
MaxProgress = 50;
var pb: TProgressBar;
function GetPanelRect: TRect;
begin
SendMessage(Form1.StatusBar1.Handle, SB_GETRECT, 0, integer(@result));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with StatusBar1.Panels.Add do begin
Width := 100;
Style := psOwnerDraw;
end;
with StatusBar1.Panels.Add do begin
Width := 0;
Text := 'abc';
end;
Timer1.Enabled := false;
Timer1.Interval := 50;
pb := TProgressBar.Create(StatusBar1);
pb.Visible := false;
pb.Parent := StatusBar1;
pb.BoundsRect := GetPanelRect;
pb.Smooth := true;
pb.Step := 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := true;
pb.Position := 0;
pb.Max := MaxProgress;
pb.Visible := true;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Tag := Timer1.Tag + 1;
if Timer1.Tag > MaxProgress then begin
Timer1.Enabled := false;
Timer1.Tag := 0;
pb.Visible := false;
end else pb.StepIt;
end;
Все советы и замечания, пожалуйста, присылайте на subscribe@program.dax.ru
Даниил Карапетян.
Автор:
StayAtHomeВзято из
Как поместить прозрачную фоновую каринку на компонент CoolBar?
Как поместить прозрачную фоновую каринку на компонент CoolBar?
procedure TForm1.Button1Click(Sender: TObject);
var
Bm1: TBitmap;
Bm2: TBitmap;
begin
Bm1 := TBitmap.Create;
Bm2 := TBitmap.Create;
Bm1.LoadFromFile('c:\download\test.bmp');
Bm2.Width := Bm1.Width;
Bm2.Height := Bm1.Height;
bm2.Canvas.Brush.Color := CoolBar1.Color;
bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
bm1.Free;
CoolBar1.Bitmap.Assign(bm2);
bm2.Free;
end;
Как поместить прозрачный текст на Canvas TBitmap
Как поместить прозрачный текст на Canvas TBitmap
Автор: Олег Кулабухов
procedureTForm1.Button1Click(Sender: TObject);
var
OldBkMode: integer;
begin
Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, TRANSPARENT);
Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, OldBkMode);
end;
Взято из
Как поместить TCheckBox внутри TRichEdit?
Как поместить TCheckBox внутри TRichEdit?
Для использования следующего примера, необходимо создать новую форму, перетащить на неё TRichEdit (RichEdit1) и создать checkbox (acb) в событии FormCreate().
procedure TForm1.FormCreate(Sender: TObject);
var
Acb: TCheckBox;
begin
RichEdit1.Left := 20;
Acb := TCheckBox.Create(RichEdit1);
Acb.Left := 30;
Acb.Top := 30;
Acb.Caption := 'my checkbox';
Acb.Parent := RichEdit1;
end;
Взято с Исходников.ru
Как поместить TMenuItem справа у формы?
Как поместить TMenuItem справа у формы?
Допустим, у Вас есть TMainMenu MainMenu1 и HelpMenuItem в конце панели меню (Menubar). Если Вызвать следующий обработчик события OnCreate, то HelpMenuItem сместится вправо.
uses
Windows;
procedure TForm1.FormCreate(Sender: TObject);
begin
ModifyMenu(MainMenu1.Handle, 0, mf_ByPosition or mf_Popup
or mf_Help, HelpMenuItem1.Handle, '&Help');
end;
Взято с Исходников.ru
Как поместить в буфер файл с помощью File Mapping?
Как поместить в буфер файл с помощью File Mapping?
1.
В файлике Delphi5\Demos\Resxplor\exeimage.pas ищи слово CreateFileMapping
2.
идея простая открываешь файл .. (или создаешь)
создаешь Mapping ... CreateFileMapping
отображаешь Mapping в свой процесс MapViewOfFile
и всё
var
SharedHandle: THandle;
FileView: Pointer;
MyFile: HFILE;
begin
MyFile := OpenFile('c:\1.txt', // pointer to filename
..., // pointer to buffer for file information
... // action and attributes
);
SharedHandle := CreateFileMapping(MyFile, nil, PAGE_READWRITE, 0,
size {размер файла}, PChar('MyFile'));
FileView := MapViewOfFile(SharedHandle, FILE_MAP_WRITE, 0, 0, size {размер файла});
...
...
...
...
// потом
UnmapViewOfFile(FileView);
Взято с Vingrad.ru
Как посчитать факториал?
Как посчитать факториал?
{
The factorial of a positive integer is defined as:
n! = n*(n-1)*(n-2)*(n-3)*...*2*1
1! = 1
0! = 1
Example: 5! = 5*4*3*2*1
}
// Iterative Solution:
function FacIterative(n: Word): Longint;
var
f: LongInt;
i: Integer;
begin
f := 1;
for i := 2 to n do f := f * i;
Result := f;
end;
// Recursive Solution:
function FacRecursive(n: Word): LongInt;
begin
if n > 1 then
Result := n * FacRecursive(n-1)
else
Result := 1;
end;
Взято с сайта
Как посчитать возраст человека?
Как посчитать возраст человека?
function CalculateAge(Birthday, CurrentDate: TDate): Integer;
var
Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;
begin
DecodeDate(Birthday, Year, Month, Day);
DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);
if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
begin
Result := 0;
end
else
begin
Result := CurrentYear - Year;
if (Month > CurrentMonth) then
Dec(Result)
else
begin
if Month = CurrentMonth then
if (Day > CurrentDay) then
Dec(Result);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'), Date)]);
end;
Взято с сайта
Как послать нажатие клавиши в какое-нибудь окно?
Как послать нажатие клавиши в какое-нибудь окно?
Эта процедура посылает сообщение о нажатии клавиши.
procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean);
type TShiftKeyInfo = record
shift: Byte;
vkey: Byte;
end;
byteset = set of 0..7;
const shiftkeys: array[1..3] of TShiftKeyInfo = ((shift: Ord(ssCtrl);
vkey: VK_CONTROL), (shift: Ord(ssShift); vkey: VK_SHIFT), (shift: Ord(ssAlt); vkey: VK_MENU));
var flag: DWORD;
bShift: ByteSet absolute shift;
i: Integer;
begin
for i := 1 to 3 do
if shiftkeys[i].shift in bShift then keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), 0, 0);
if specialkey then
flag := KEYEVENTF_EXTENDEDKEY
else
flag := 0;
keybd_event(key, MapvirtualKey(key, 0), flag, 0);
flag := flag or KEYEVENTF_KEYUP;
keybd_event(key, MapvirtualKey(key, 0), flag, 0);
for i := 3 downto 1 do
if shiftkeys[i].shift in bShift then keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), KEYEVENTF_KEYUP, 0);
end;
Чтобы воспользоваться этой процедурой надо предварительно найти и активизировать нужное окно:
SetForegroundWindow(FindWindow(PChar(WindowClassName), PChar(WindowCaption)));
PS. не забудьте поставить задержки типа Sleep(100) после активизации окна и между посылаемыми клавишами, не то окно может не успевать реагировать на клавиши...
Автор ответа: Vit
Взято с Vingrad.ru
Как послать нажатие кнопки мыши в окно?
Как послать нажатие кнопки мыши в окно?
WM_LBUTTONDOWN
WM_RBUTTONDOWN
Автор ответа: Song
Взято с Vingrad.ru
Я решил проверить точку нажатия мышки таким вот образом:
...
SetForegroundWindow(WindowUO);
mouse_event(MOUSEEVENTF_MOVE,400,400,0,0);
...
и получилось, что мышка перемещалась не в те координаты(относительно разрешения монитора (800 на 600)) которые я задумал(в не зависимости от местоположения мышки она перемещалась строго по одному направлению на одинаковое расстояние), причем я сделал еще один вариант - dx=100, dy=100, но тогда перемещение мышки произошло в другую сторону(в сторону x=0 y=0 монитора)!
Подскажите плз в чем дело?
Автор ответа: Spawn
Взято с Vingrad.ru
Mouse_event программирует не абсолюьные, а относительные координаты.
Чтобы не думалось, просто сначала установите курсор в нужную позицию - SetCursorPos(), а потом делайте клик - Mouse_event()
Автор ответа: Song
Взято с Vingrad.ru
Как послать широковещательный UDP пакет?
Как послать широковещательный UDP пакет?
procedure TMainForm.FormCreate(Sender: TObject);
var Init:TWSAData;
SockOpt:BOOL;
Sock:TSocket;
Target:TSockAddrIn;
begin
WSAStartup($101,Init);
Sock:=Socket(PF_INET,SOCK_DGRAM,IPPROTO_UDP);
SockOpt:=TRUE;
SetSockOpt(Sock,SOL_SOCKET,SO_BROADCAST,PChar(@SockOpt),SizeOf(SockOpt)) ;
Target.sin_port:=htons(8167);//номер порта
Target.sin_addr.S_addr:=INADDR_BROADCAST;
Target.sa_family:=AF_INET;
SendTo(Sock,Data,DataBytes,0,Target,SizeOf(Target));
WSACleanup;
end;
Взято с Исходников.ru