Как по Alias узнать физический путь к базе данных?
Как по Alias узнать физический путь к базе данных?
functionGetAliasDir(alias: PChar): PChar;
var
s: TStringList;
i: integer;
t: string;
res: array[0..255] of char;
begin
res := '';
if Session.IsAlias(alias) then
begin {Check if alias exists}
s := TStringList.Create;
try
Session.GetAliasParams(Alias, s);
t := '';
if s.count > 0 then
begin
i := 0;
while (i < s.count) and (Copy(s.Strings[i], 1, 5) <> 'PATH=') do
inc(i);
if (i < s.count) and (Copy(s.Strings[i], 1, 5) = 'PATH =') then
begin
t := Copy(s.Strings[i], 6, Length(s.Strings[i]) - 4);
if t[length(t)] <> '\' then
t := t + '\';
end;
end;
StrPCopy(res, t);
except
StrPCopy(res, '');
end;
s.Free;
end;
result := res;
end;
Взято с
Delphi Knowledge BaseКак по имени Базы Данных получить ссылку на компоненет TDataBase?
Как по имени Базы Данных получить ссылку на компоненет TDataBase?
Автор: Max Rezanov
var
db : TDataBase;
begin
db := Session.FindDatabase(FDataBaseName);
db.StartTransaction;
Взято с Исходников.ru
Как по IP адресу получить HostName (и обратно)
Как по IP адресу получить HostName (и обратно)
functionTGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;
const AddressStrMaxLen = 256;
var len : DWORD;
ptr : PChar;
pHE : PHostEnt;
addr : TSockAddr;
buf : Array [0..AddressStrMaxLen-1] of Char;
begin
if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is
not defined',WSAHOST_NOT_FOUND);
len := SizeOf(TSockAddr);
if getpeername(FSocket,addr,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');
case addr.sin_family of
AF_INET: // TCP/IP
begin
pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),
AF_INET );
if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:
gethostbyaddr()');
FPeerNodeName := pHE^.h_name;
if FNet.NodeByName(FPeerNodeName)=nil then
begin
ptr := StrScan(pHE^.h_name,'.');
if ptr<>nil then FPeerNodeName :=
Copy(pHE^.h_name,1,ptr-pHE^.h_name);
end;
end;
else
len := AddressStrMaxLen;
if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');
ptr := StrRScan(buf,':');
if ptr<>nil then len := ptr-buf;
FPeerNodeName := Copy(buf,1,len);
end;
Result :=
FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR
aiseError]);
end; {TGenericNetTask.GetPeerOrigin}
Alex Konshin
mailto:alexk@msmt.spb.su"
(2:5030/217)
------------------------------------------------------------------------------------------------------
Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?
CODE
unit BetterTreeView;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, CommCtrl;
type
TTVNewEditCancelEvent = procedure( Sender: TObject;
Node: TTreeNode; var Delete: Boolean) of object;
TBetterTreeView = class(TTreeView)
protected
FIsEditingNew: Boolean;
FOnEditCancel: TTVChangedEvent;
FOnNewEditCancel: TTVNewEditCancelEvent;
procedure Edit(const Item: TTVItem); override;
public
function NewChildAndEdit(Node: TTreeNode; const S: String)
: TTreeNode;
published
property IsEditingNew: Boolean read FIsEditingNew;
property OnEditCancel: TTVChangedEvent
read FOnEditCancel write FOnEditCancel;
property OnNewEditCancel: TTVNewEditCancelEvent
read FOnNewEditCancel write FOnNewEditCancel;
end;
implementation
procedure TBetterTreeView.Edit(const Item: TTVItem);
var
Node: TTreeNode;
Action: Boolean;
begin
with Item do begin
{ Get the node }
if (state and TVIF_PARAM) 0 then
Node := Pointer(lParam)
else
Node := Items.GetNode(hItem);
if pszText = nil then begin
if FIsEditingNew then begin
Action := True;
if Assigned(FOnNewEditCancel) then
FOnNewEditCancel(Self, Node, Action);
if Action then
Node.Destroy
end
else
if Assigned(FOnEditCancel) then
FOnEditCancel(Self, Node);
end
else
inherited;
end;
FIsEditingNew := False;
end;
function TBetterTreeView.NewChildAndEdit
(Node: TTreeNode; const S: String): TTreeNode;
begin
SetFocus;
Result := Items.AddChild(Node, S);
FIsEditingNew := True;
Node.Expand(False);
Result.EditText;
SetFocus;
end;
end.
Автор:
StayAtHomeВзято из
Как подсчитать количество слов в строке?
Как подсчитать количество слов в строке?
functionSeps(As_Arg: Char): Boolean;
begin
Seps := As_Arg in
[#0..#$1F, ' ', '.', ',', '?', ':', ';', '(', ')', '/', '\'];
end;
function WordCount(CText: string): Longint;
var
Ix: Word;
Work_Count: Longint;
begin
Work_Count := 0;
Ix := 1;
while Ix <= Length(CText) do
begin
while (Ix <= Length(CText)) and (Seps(CText[Ix])) do
Inc(Ix);
if Ix <= Length(CText) then
begin
Inc(Work_Count);
while (Ix <= Length(CText)) and (not Seps(CText[Ix])) do
Inc(Ix);
end;
end;
Word_Count := Work_Count;
end;
{
To count the number opf words in a TMemo Component,
call: WordCount(Memo1.Text)
}
Взято с
Как подсчитать возраст по дню рождения?
Как подсчитать возраст по дню рождения?
{BrthDate: Date of birth }
function TFFuncs.CalcAge(brthdate: TDateTime): Integer;
var
month, day, year, bmonth, bday, byear: word;
begin
DecodeDate(BrthDate, byear, bmonth, bday);
if bmonth = 0 then
result := 0
else
begin
DecodeDate(Date, year, month, day);
result := year - byear;
if (100 * month + day) < (100 * bmonth + bday) then
result := result - 1;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Month, Day, Year, CurrentMonth, CurrentDay, CurrentYear: word;
Age: integer;
begin
DecodeDate(DateTimePicker1.Date, Year, Month, Day);
DecodeDate(Date, CurrentYear, CurrentMonth, CurrentDay);
if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
Age := 0
else
begin
Age := CurrentYear - Year;
if (Month > CurrentMonth) then
dec(Age)
else if Month = CurrentMonth then
if (Day > CurrentDay) then
dec(Age);
end;
Label1.Caption := IntToStr(Age);
end;
Взято с
Delphi Knowledge BaseКак подсоединиться к MySQL
Как подсоединиться к MySQL
Perhaps you have already seen the uses clause. You may download mySQL.pas from
usesmySQL;
procedure Connect;
var
myServer: PMysql;
Tables: PMYSQL_RES;
TableRows: my_ulonglong;
Table: PMYSQL_ROW;
begin
myServer := mysql_init(nil);
if myServer <> nil then
begin
if mysql_options(myServer, MYSQL_OPT_CONNECT_TIMEOUT, '30') = 0 then
begin
if mysql_real_connect(myServer, 'host', 'user', 'password', 'database', 3306,
nil, CLIENT_COMPRESS) <> nil then
begin
Tables := mysql_list_tables(myServer, nil);
if Tables <> nil then
begin
TableRows := mysql_num_rows(Tables);
while TableRows > 0 do
begin
Table := mysql_fetch_row(Tables);
Tabelle := Table[0];
Dec(TableRows);
end;
end;
end;
end;
end;
end;
Взято с
Delphi Knowledge BaseКак показать Choose Computer диалог?
Как показать Choose Computer диалог?
{
The "Choose Computer" is a dialog provided by network services
(NTLANMAN.DLL) for Windows 2k/NT/XP
to display the servers and their computers.
}
type
TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool;
stdcall;
function ShowServerDialog(AHandle: THandle): string;
var
ServerBrowseDialogA0: TServerBrowseDialogA0;
LANMAN_DLL: DWORD;
buffer: array[0..1024] of char;
bLoadLib: Boolean;
begin
LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
if LANMAN_DLL = 0 then
begin
LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
bLoadLib := True;
end;
if LANMAN_DLL <> 0 then
begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
ServerBrowseDialogA0(AHandle, @buffer, 1024);
if buffer[0] = '\' then
begin
Result := buffer;
end;
if bLoadLib then
FreeLibrary(LANMAN_DLL);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := ShowServerDialog(Form1.Handle);
end;
Взято с сайта
Как показать DbGrid в режиме disabled?
Как показать DbGrid в режиме disabled?
Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу управления (в данном случае TDBGrid) запрещен (disabled).
procedure TForm1.Button1Click(Sender: TObject);
begin
DbGrid1.Enabled := false;
DbGrid1.Font.Color := clGray;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DbGrid1.Enabled := true;
DbGrid1.Font.Color := clBlack;
end;
Взято с Исходников.ru
Как показать File Properties dialog?
Как показать File Properties dialog?
{ This code shows the standard file properties dialog like in Windows Explorer }
uses
shellapi;
// Thanks to Peter Below (TeamB) for this code
procedure PropertiesDialog(FileName: string);
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.lpFile := PChar(FileName);
sei.lpVerb := 'properties';
sei.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteEx(@sei);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
PropertiesDialog(Opendialog1.FileName);
end;
Взято с сайта
Как показать иконку, ассоциированную с данным типом файла?
Как показать иконку, ассоциированную с данным типом файла?
ShellApi функция ExtractAssociatedIcon()
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var
Icon: hIcon;
IconIndex: word;
begin
IconIndex := 1;
Icon := ExtractAssociatedIcon(HInstance,
Application.ExeName,
IconIndex);
DrawIcon(Canvas.Handle, 10, 10, Icon);
end;
Взято с сайта
Как показать окно свойств экрана?
Как показать окно свойств экрана?
Для этого воспользуемся 'Rundll32.exe' и запустим её в 'shellexecute'. Не забудьте добавить 'shellapi' в Ваш список uses.
function GetSystemDir: TFileName;
var
SysDir: array[0..MAX_PATH - 1] of char;
begin
SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
if Result = '' then
raise Exception.Create(SysErrorMessage(GetLastError));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
x: Tfilename;
begin
x := getsystemdir;
ShellExecute(Form11.Handle, 'open', Pchar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl,@0,3', Pchar(X), SW_normal);
end;
//getsystemdir это функция, которая совместима со всеми версиями windows.
Взято с Исходников.ru
Как показать округлённое окошко подсказки в трее в Windows2000?
Как показать округлённое окошко подсказки в трее в Windows2000?
В Windows 2000, формат структуры NotifyIconData, которая используется для работы с иконками в Трее (которая, кстати, называется "The Taskbar Notification Area" :) значительно отличается от предыдущий версий Windows. Однако, эти изменения НЕ отражены в юните ShellAPI.pas в Delphi 5.
Итак, нам понадобится преобразованный SHELLAPI.H, в котором присутствуют все необходимые объявления:
uses Windows;
type
NotifyIconData_50 = record // определённая в shellapi.h
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array[0..MAXCHAR] of AnsiChar;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array[0..MAXBYTE] of AnsiChar;
uTimeout: UINT; // union with uVersion: UINT;
szInfoTitle: array[0..63] of AnsiChar;
dwInfoFlags: DWORD;
end{record};
const
NIF_INFO = $00000010;
NIIF_NONE = $00000000;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
А это набор вспомогательных типов:
type
TBalloonTimeout = 10..30{seconds};
TBalloonIconType = (bitNone, // нет иконки
bitInfo, // информационная иконка (синяя)
bitWarning, // иконка восклицания (жёлтая)
bitError); // иконка ошибки (краснаа)
Теперь мы готовы приступить к созданию округлённых подсказок!
Для этого воспользуемся следующей функцией:
uses SysUtils, Windows, ShellAPI;
function DZBalloonTrayIcon(const Window: HWND; const IconID: Byte; const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle: String; const BalloonIconType: TBalloonIconType): Boolean;
const
aBalloonIconTypes : array[TBalloonIconType] of Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
var
NID_50 : NotifyIconData_50;
begin
FillChar(NID_50, SizeOf(NotifyIconData_50), 0);
with NID_50 do begin
cbSize := SizeOf(NotifyIconData_50);
Wnd := Window;
uID := IconID;
uFlags := NIF_INFO;
StrPCopy(szInfo, BalloonText);
uTimeout := Timeout * 1000;
StrPCopy(szInfoTitle, BalloonTitle);
dwInfoFlags := aBalloonIconTypes[BalloonIconType];
end{with};
Result := Shell_NotifyIcon(NIM_MODIFY, @NID_50);
end;
Вызывается она следующим образом:
DZBalloonTrayIcon(Form1.Handle, 1, 10, 'this is the balloon text', 'title', bitWarning);
Иконка, должна быть предварительно добавлена с темже дескриптором окна и IconID (в данном примере Form1.Handle и 1).
Можете попробовать все три типа иконок внутри всплывающей подсказки.
P.S. На всякий случай, ниже представлены функции для добавление/удаления иконок в трее:
uses SysUtils, Windows, ShellAPI;
{добавление иконки}
function DZAddTrayIcon(const Window: HWND; const IconID: Byte; const Icon: HICON; const Hint: String = ''): Boolean;
var
NID : NotifyIconData;
begin
FillChar(NID, SizeOf(NotifyIconData), 0);
with NID do begin
cbSize := SizeOf(NotifyIconData);
Wnd := Window;
uID := IconID;
if Hint = '' then begin
uFlags := NIF_ICON;
end{if} else begin
uFlags := NIF_ICON or NIF_TIP;
StrPCopy(szTip, Hint);
end{else};
hIcon := Icon;
end{with};
Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;
{добавляет иконку с call-back сообщением}
function DZAddTrayIconMsg(const Window: HWND; const IconID: Byte; const Icon: HICON; const Msg: Cardinal; const Hint: String = ''): Boolean;
var
NID : NotifyIconData;
begin
FillChar(NID, SizeOf(NotifyIconData), 0);
with NID do begin
cbSize := SizeOf(NotifyIconData);
Wnd := Window;
uID := IconID;
if Hint = '' then begin
uFlags := NIF_ICON or NIF_MESSAGE;
end{if} else begin
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
StrPCopy(szTip, Hint);
end{else};
uCallbackMessage := Msg;
hIcon := Icon;
end{with};
Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;
{удаляет иконку}
function DZRemoveTrayIcon(const Window: HWND; const IconID: Byte): Boolean;
var
NID : NotifyIconData;
begin
FillChar(NID, SizeOf(NotifyIconData), 0);
with NID do begin
cbSize := SizeOf(NotifyIconData);
Wnd := Window;
uID := IconID;
end{with};
Result := Shell_NotifyIcon(NIM_DELETE, @NID);
end;
Несколько заключительных замечаний:
1. Нет необходимости использовать большую структуру NotifyIconData_50 для добавления или удаления иконок, старая добрая структура NotifyIconData прекрасно подойдёт для этого.
2. Для callback сообщения можно использовать WM_APP + что-нибудь.
3. Используя различные IconID, легко можно добавить несколько различных иконок из одного родительского окна и работать с ними по их IconID.
Взято с Исходников.ru
Как показать Open With диалог?
Как показать Open With диалог?
{
This code displays the application/file "Open With" dialog
Passing the full file path and name as a parameter will cause the
dialog to display the line "Click the program you want to use to open
the file 'filename'".
}
uses
ShellApi;
procedure OpenWith(FileName: string);
begin
ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'),
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
OpenWith(Opendialog1.FileName);
end;
Взято с сайта
Как показать содержимое Memo-поля в DBGrid?
Как показать содержимое Memo-поля в DBGrid?
Поумолчанию, DBGrid не может отображать memo-поля. Однако, проблему можно решить при помощи события OnDrawDataCell в DBGrid.
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const
Rect: TRect; Field: TField; State:
TGridDrawState);
var
P: array [0..50] of char; {размер массива, это количество необходимых символов}
bs: TBlobStream; {из memo-поля}
hStr: String;
begin
if Field is TMemoField then
begin
with (Sender as TDBGrid).Canvas do
begin {Table1Notes это TMemoField}
bs := TBlobStream.Create(Table1Notes, bmRead);
FillChar(P,SizeOf(P),#0); {строка завершается нулём}
bs.Read(P, 50); {читаем 50 символов из memo в blobStream}
bs.Free;
hStr := StrPas(P);
while Pos(#13, hStr) > 0 do {удаляем переносы каретки и}
hStr[Pos(#13, hStr)] := ' ';
while Pos(#10, hStr) > 0 do {отступы строк}
S[Pos(#10, hStr)] := ' ';
FillRect(Rect); {очищаем ячейку}
TextOut(Rect.Left, Rect.Top, hStr); {заполняем ячейку данными из memo}
end;
end;
end;
Замечание: перед тем, запустить пример, создайте объект TMemoField для memo-поля двойным кликом по компоненту TTable и добавлением memo-поля.
Взято с Исходников.ru
Как показать видео на полном экране?
Как показать видео на полном экране?
procedureTForm1.Button1Click(Sender: TObject);
const
longName: PChar = 'f:\media\ANIM1.MPG'; {Your complete FileName}
var
ret, shortName: PChar;
err: DWord;
begin
{Getting the short Name (8:3) of selected file}
shortName := strAlloc(521);
GetShortPathName(longName, shortname, 512);
{Sending a close Command to the MCI}
ret := strAlloc(255);
err := mciSendString(pchar('close movie'), 0, 0, 0);
{No error check because at the first call there is no MCI device to close}
{Open a new MCI Device with the selected movie file}
err := mciSendString(pchar('open ' + shortName + ' alias movie'), 0, 0, 0);
shortName := nil;
{If an Error was traced then display a MessageBox with the mciError string}
if err <> 0 then
begin
mciGetErrorString(err, ret, 255);
messageDlg(ret, mtInformation, [mbOk], 0);
end;
{Sending the "play fullscreen command to the Windows MCI}
err := mciSendString(pchar('play movie fullscreen'), 0, 0, 0);
{Use the following line instead of the above one if you want to play
it in screen mode}
err := mciSendString(pchar('play movie'), 0, 0, 0);
{If an Error was traced then display a MessageBox with the mciError string}
if err <> 0 then
begin
mciGetErrorString(err, ret, 255);
messageDlg(ret, mtInformation, [mbOk], 0);
end;
ret := nil;
end;
Взято с
Delphi Knowledge BaseКак получить активный URL из браузера?
Как получить активный URL из браузера?
Автор: Ruslan Abu Zant
Приводимая здесь функция показывает, как Ваше приложение может извлечь из браузера (IE или Netscape) URL , как, например, это делает аська.
Совместимость: Delphi 4.x (или выше)
Не забудьте добавить DDEMan в Ваш проект!
uses windows, ddeman, ......
function Get_URL(Servicio: string): String;
var
Cliente_DDE: TDDEClientConv;
temp:PChar; //<<-------------------------This is new
begin
Result := '';
Cliente_DDE:= TDDEClientConv.Create( nil );
with Cliente_DDE do
begin
SetLink( Servicio,'WWW_GetWindowInfo');
temp := RequestData('0xFFFFFFFF');
Result := StrPas(temp);
StrDispose(temp); //<<-Предотвращаем утечку памяти
CloseLink;
end;
Cliente_DDE.Free;
end;
procedure TForm1.Button1Click(Sender);
begin
showmessage(Get_URL('Netscape'));
или
showmessage(Get_URL('IExplore'));
end;
Взято с Исходников.ru
Как получить более светлый или более тёмный цвет?
Как получить более светлый или более тёмный цвет?
{
Here's some function that returns the lighter or darker color of a TColor.
You can use it, for example, to design a bevel or something like that.
}
{=======================================}
function Min(a, b: Longint): Longint;
begin
if a > b then Result := b
else
Result := a;
end;
function Max(a, b: Longint): Longint;
begin
if a > b then Result := a
else
Result := b;
end;
{=======================================}
function GetHighlightColor(BaseColor: TColor): TColor;
begin
Result := RGB(Min(GetRValue(ColorToRGB(BaseColor)) + 64, 255),
Min(GetGValue(ColorToRGB(BaseColor)) + 64, 255),
Min(GetBValue(ColorToRGB(BaseColor)) + 64, 255));
end;
function GetShadowColor(BaseColor: TColor): TColor;
begin
Result := RGB(Max(GetRValue(ColorToRGB(BaseColor)) - 64, 0),
Max(GetGValue(ColorToRGB(BaseColor)) - 64, 0),
Max(GetBValue(ColorToRGB(BaseColor)) - 64, 0));
end;
Взято с сайта
Как получить число и список всех компонентов, расположенных на TNoteBook?
Как получить число и список всех компонентов, расположенных на TNoteBook?
procedure TForm1.Button1Click(Sender: TObject);
var
n: integer;
p: integer;
begin
ListBox1.Clear;
with Notebook1 do
begin
for n := 0 to ControlCount - 1 do
begin
with TPage(Controls[n]) do
begin
ListBox1.Items.Add('Notebook Page: ' +
TPage(Notebook1.Controls[n]).Caption);
for p := 0 to ControlCount - 1 do
ListBox1.Items.Add(Controls[p].Name);
ListBox1.Items.Add(EmptyStr);
end;
end;
end;
end;
Как получить цвет строки в HTML формате
Как получить цвет строки в HTML формате
Если Вам необходимо создать HTML-файл, то необходимо объявить тэг для цвета шрифта либо цвета фона. Однако просто вставить значение TColor не получится - необходимо преобразовать цвет в формат RGB. В своём наборе SMExport я использую следующую функцию:
functionGetHTMLColor(cl: TColor; IsBackColor: Boolean): string;
var
rgbColor: TColorRef;
begin
if IsBackColor then
Result := 'bg'
else
Result := '';
rgbColor := ColorToRGB(cl);
Result := Result + 'color="#' +
Format('%.2x%.2x%.2x',
[GetRValue(rgbColor),
GetGValue(rgbColor),
GetBValue(rgbColor)]) + '"';
end;
Взято из
Как получить дату BIOS?
Как получить дату BIOS?
unit BiosDate;
interface
function GetBiosDate: String;
implementation
function SegOfsToLinear(Segment, Offset: Word): Integer;
begin
result := (Segment SHL 4) OR Offset;
end;
function GetBiosDate: String;
begin
result := String(PChar(Ptr(SegOfsToLinear($F000, $FFF5))));
end;
end.
Взято с Исходников.ru
Как получить дату по Юлианскому календарю?
Как получить дату по Юлианскому календарю?
functionjulian(year, month, day: Integer): real;
var
yr, mth: Integer;
noleap, leap, days, yrs: Real;
begin
if year < 0 then
yr := year + 1
else
yr := year;
mth := month;
if (month < 3) then
begin
mth := mth + 12;
yr := yr - 1;
end;
yrs := 365.25 * yr;
if ((yrs < 0) and (frac(yrs) <> 0)) then
yrs := int(yrs) - 1
else
yrs := int(yrs);
days := int(yrs) + int(30.6001 * (mth + 1)) + day - 723244.0;
if days < -145068.0 then
julian := days
else
begin
yrs := yr / 100.0;
if ((yrs < 0) and (frac(yrs) <> 0)) then
yrs := int(yrs) - 1;
noleap := int(yrs);
yrs := noleap / 4.0;
if ((yrs < 0) and (frac(yrs) <> 0)) then
yrs := int(yrs) - 1;
leap := 2 - noleap + int(yrs);
julian := days + leap;
end;
end;
Взято с
Delphi Knowledge BaseКак получить доступ к битам переменной и управлять их значением?
Как получить доступ к битам переменной и управлять их значением?
unitBitwise;
interface
function IsBitSet(const val: longint; const TheBit: byte): boolean;
function BitOn(const val: longint; const TheBit: byte): LongInt;
function BitOff(const val: longint; const TheBit: byte): LongInt;
function BitToggle(const val: longint; const TheBit: byte): LongInt;
implementation
function IsBitSet(const val: longint; const TheBit: byte): boolean;
begin
result := (val and (1 shl TheBit)) <> 0;
end;
function BitOn(const val: longint; const TheBit: byte): LongInt;
begin
result := val or (1 shl TheBit);
end;
function BitOff(const val: longint; const TheBit: byte): LongInt;
begin
result := val and ((1 shl TheBit) xor $FFFFFFFF);
end;
function BitToggle(const val: longint; const TheBit: byte): LongInt;
begin
result := val xor (1 shl TheBit);
end;
end.
SetWord ? слово, которое необходимо установить.
BitNum ? номер бита, который необходимо выставить согласно определениям в секции const (Bit0, Bit1 и др.).
GetBitStat возвращает значение True, если бит установлен и False ? в противном случае.
const
Bit0 = 1;
Bit1 = 2;
Bit2 = 4;
Bit3 = 8;
Bit4 = 16;
Bit5 = 32;
Bit6 = 64;
Bit7 = 128;
Bit8 = 256;
Bit9 = 512;
Bit10 = 1024;
Bit11 = 2048;
Bit12 = 4096;
Bit13 = 8192;
Bit14 = 16384;
Bit15 = 32768;
procedure SetBit(SetWord, BitNum: Word);
begin
SetWord := SetWord Or BitNum; { Устанавливаем бит }
end;
procedure ClearBit(SetWord, BitNum: Word);
begin
SetWord := SetWord Or BitNum; { Устанавливаем бит }
SetWord := SetWord Xor BitNum; { Переключаем бит }
end;
procedure ToggleBit(SetWord, BitNum: Word);
begin
SetWord := SetWord Xor BitNum; { Переключаем бит }
end;
function GetBitStat(SetWord, BitNum: Word): Boolean;
begin
GetBitStat := SetWord and BitNum = BitNum; { Если бит установлен }
end;
Источник: Книга В. Озерова "Delphi. Советы программистов"
Автор:
StayAtHomeВзято из
Как получить доступ к объекту метафайла
Как получить доступ к объекту метафайла
Below is an example of getting metafile information and enumerating each metafile record :
functionMyEnhMetaFileProc(DC: HDC; {handle to device context}
lpHTable: PHANDLETABLE; {pointer to metafile handle table}
lpEMFR: PENHMETARECORD; {pointer to metafile record}
nObj: integer; {count of objects}
TheForm: TForm1): integer; stdcall;
begin
{draw the metafile record}
PlayEnhMetaFileRecord(dc, lpHTable^, lpEMFR^, nObj);
{set to zero to stop metafile enumeration}
result := 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
MyMetafile: TMetafile;
lpENHMETAHEADER: PENHMETAHEADER; {extra metafile info}
lpENHMETAHEADERSIZE: DWORD;
NumMetaRecords: DWORD;
begin
{Create a metafile}
MyMetafile := TMetafile.Create;
with TMetafileCanvas.Create(MyMetafile, 0) do
try
Brush.Color := clRed;
Ellipse(0, 0, 100, 100);
Ellipse(100, 100, 200, 200);
Ellipse(200, 200, 300, 300);
Ellipse(300, 300, 400, 400);
Ellipse(400, 400, 500, 500);
Ellipse(500, 500, 600, 600);
finally
Free;
end;
{we might as well get some extra metafile info}
lpENHMETAHEADERSIZE := GetEnhMetaFileHeader(MyMetafile.Handle, 0, nil);
NumMetaRecords := 0;
if (lpENHMETAHEADERSIZE > 0) then
begin
GetMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
GetEnhMetaFileHeader(MyMetafile.Handle, lpENHMETAHEADERSIZE, lpENHMETAHEADER);
{Here is an example of getting number of metafile records}
NumMetaRecords := lpENHMETAHEADER^.nRecords;
{enumerate the records}
EnumEnhMetaFile(Canvas.Handle, MyMetafile.Handle, @MyEnhMetaFileProc, self,
Rect(0, 0, 600, 600));
FreeMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
end;
MyMetafile.Free;
end;
Взято с
Delphi Knowledge BaseКак получить handle на editbox в Internet Explorer?
Как получить handle на editbox в Internet Explorer?
var
hndl: HWND;
main: HWND;
begin
main := FindWindow('IEFrame', nil);
if main <> 0 then
begin
hndl := findwindowex(main, 0, 'Worker', nil);
if hndl <> 0 then
begin
hndl := findwindowex(hndl, 0, 'ReBarWindow32', nil);
if hndl <> 0 then
begin
hndl := findwindowex(hndl, 0, 'ComboBoxEx32', nil);
if hndl <> 0 then
begin
hndl := findwindowex(hndl, 0, 'ComboBox', nil);
if hndl <> 0 then
begin
hndl := findwindowex(hndl, 0, 'Edit', nil);
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure FindIEEditHandle;
end;
var
Form1: TForm1;
EditHandle: THandle;
implementation
{$R *.DFM}
function EnumIEChildProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
var
tmpS: string;
theClassName: string;
theWinText: string;
begin
Result := True;
SetLength(theClassName, 256);
GetClassName(AHandle, PChar(theClassName), 255);
SetLength(theWinText, 256);
GetWindowText(AHandle, PChar(theWinText), 255);
tmpS := StrPas(PChar(theClassName));
if theWinText <> EmptyStr then
tmpS := tmpS + '"' + StrPas(PChar(theWinText)) + '"'
else
tmpS := tmpS + '""';
if Pos('Edit', tmpS) > 0 then
begin
EditHandle := AHandle;
end;
end;
function IEWindowEnumProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
{callback for EnumWindows.}
var
theClassName: string;
theWinText: string;
tmpS: string;
begin
Result := True;
SetLength(theClassName, 256);
GetClassName(AHandle, PChar(theClassName), 255);
SetLength(theWinText, 256);
GetWindowText(AHandle, PChar(theWinText), 255);
tmpS := StrPas(PChar(theClassName));
if theWinText <> EmptyStr then
tmpS := tmpS + '"' + StrPas(PChar(theWinText)) + '"'
else
tmpS := tmpS + '""';
if Pos('IEFrame', tmpS) > 0 then
begin
EnumChildWindows(AHandle, @EnumIEChildProc, longInt(0));
end;
end;
procedure TForm1.FindIEEditHandle;
begin
Screen.Cursor := crHourGlass;
try
EnumWindows(@IEWindowEnumProc, LongInt(0));
finally
Screen.Cursor := crDefault;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FindIEEditHandle;
if EditHandle > 0 then
Label1.Caption := IntToStr(EditHandle)
else
label1.Caption := 'Not Found';
end;
end.
Взято с
Delphi Knowledge BaseКак получить hex-значение данного цвета?
Как получить hex-значение данного цвета?
GetRValue, GetGValue, GetBValue - дадут тебе байты цветов, затем тебе надо их перевести в hex...
Автор ответа: Vit
Взято с Vingrad.ru
IntToHex(Color);
Автор ответа: neutrino
Взято с Vingrad.ru
В модуле graphics имеются две недокументированные функции:
function ColorToString(Color: TColor): string;
Если значение TColor является именованным цветом, функция возвращает имя цвета ("clRed"). В противном случае возвращается шестнадцатиричное значение цвета в виде строки.
function StringToColor(S: string): TColor;
Данная функция преобразует "clRed" или "$0000FF" во внутреннее значение цвета.
Автор ответа: Pegas
Взято с Vingrad.ru
Как получить имя текущего пользователя?
Как получить имя текущего пользователя?
function GetCurrentUser: string;
var
pwrec: PPasswordRecord;
begin
pwrec := getpwuid(getuid);
Result := pwrec.pw_name;
end;
Взято с сайта
Как получить информацию о BIOS в Windows 9x?
Как получить информацию о BIOS в Windows 9x?
with Memo1.Lines do
begin
Add('MainBoardBiosName:'+^I+string(Pchar(Ptr($FE061))));
Add('MainBoardBiosCopyRight:'+^I+string(Pchar(Ptr($FE091))));
Add('MainBoardBiosDate:'+^I+string(Pchar(Ptr($FFFF5))));
Add('MainBoardBiosSerialNo:'+^I+string(Pchar(Ptr($FEC71))));
end;
Взято с Исходников.ru
Как получить информацию о BIOS в Windows NT/2000/XP?
Как получить информацию о BIOS в Windows NT/2000/XP?
В NT/2000/XP не получится прочитать значения прямо из BIOS, однако, ничего не мешает нам считать нужные значения из реестра.
procedure TBIOSInfo.GetRegInfoWinNT;
var
Registryv : TRegistry;
RegPath : string;
sl : TStrings;
begin
Params.Clear;
RegPath := '\HARDWARE\DESCRIPTION\System';
registryv:=tregistry.Create;
registryv.rootkey:=HKEY_LOCAL_MACHINE;
sl := nil;
try
registryv.Openkey(RegPath,false);
ShowMessage('BIOS Date: '+RegistryV.ReadString('SystemBiosDate'));
sl := ReadMultirowKey(RegistryV,'SystemBiosVersion');
ShowMessage('BIOS Version: '+sl.Text);
except
end;
Registryv.Free;
if Assigned(sl) then sl.Free;
end;
---------------------------
На всякий пожарный:
//следующий метод получает многострочные значения из реестра
//и преобразует их в TStringlist
function ReadMultirowKey(reg: TRegistry; Key: string): TStrings;
const bufsize = 100;
var
i: integer;
s1: string;
sl: TStringList;
bin: array[1..bufsize] of char;
begin
try
result := nil;
sl := nil;
sl := TStringList.Create;
if not Assigned(reg) then
raise Exception.Create('TRegistry object not assigned.');
FillChar(bin,bufsize,#0);
reg.ReadBinaryData(Key,bin,bufsize);
i := 1;
s1 := '';
while i < bufsize do
begin
if ord(bin[i]) >= 32 then
s1 := s1 + bin[i]
else
begin
if Length(s1) > 0 then
begin
sl.Add(s1);
s1 := '';
end;
end;
inc(i);
end;
result := sl;
except
sl.Free;
raise;
end;
end;
Взято с Исходников.ru
Как получить информацию о дорожке аудио-CD?
Как получить информацию о дорожке аудио-CD?
unitfrmMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, MMSystem;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button2: TButton;
Button3: TButton;
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
function IsAudioCD(Drive: char): bool;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.IsAudioCD(Drive: char): bool;
var
DrivePath: string;
MaximumComponentLength: DWORD;
FileSystemFlags: DWORD;
VolumeName: string;
begin
Result := false;
DrivePath := Drive + ':\';
if GetDriveType(PChar(DrivePath)) = DRIVE_CDROM then
begin
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil,
MaximumComponentLength, FileSystemFlags, nil, 0);
if lStrCmp(PChar(VolumeName), 'Audio CD') = 0 then
Result := True;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if IsAudioCD(' D ') then
showmessage('Cd is an audio cd')
else
showmessage('Cd is not an audio cd');
end;
procedure TForm1.Button3Click(Sender: TObject);
type
TDWord = record
High: Word;
Low: Word;
end;
var
msp: TMCI_INFO_PARMS;
MediaString: array[0..255] of char;
ret: longint;
I: integer;
StatusParms: TMCI_STATUS_PARMS;
MciSetParms: TMCI_SET_PARMS;
MciOpenParms: TMCI_OPEN_PARMS;
aDeviceID: MCIDEVICEID;
function GetTheDeviceID: MCIDEVICEID;
begin
FillChar(MciOpenParms, SizeOf(MciOpenParms), #0);
try
MciOpenParms.lpstrDeviceType := 'cdaudio';
ret := mciSendCommand(0, MCI_OPEN, MCI_OPEN_TYPE + MCI_OPEN_SHAREABLE,
LongInt(@MciOpenParms));
Result := MciOpenParms.wDeviceID;
except
on E: Exception do
begin
Result := 0;
showmessage('error receiving deviceIDt' + #13 + SysErrorMessage(GetLastError)
+ #13 + E.Message);
end;
end;
end;
function GetTrackInfo(const uMsg: UInt; const fdwCommand: DWord;
const dwItem: DWord; const dwTrack: DWord): string;
begin
Result := 'Did not work...';
FillChar(MediaString, SizeOf(MediaString), #0);
FillChar(StatusParms, SizeOf(StatusParms), #0);
StatusParms.dwItem := dwItem;
StatusParms.dwTrack := dwTrack;
ret := mciSendCommand(aDeviceID, uMsg, fdwCommand, longint(@StatusParms));
if Ret = 0 then
Result := IntToStr(StatusParms.dwReturn);
end;
procedure SetTimeInfo;
begin
FillChar(MciSetParms, SizeOf(MciSetParms), #0);
MciSetParms.dwTimeFormat := MCI_FORMAT_MSF;
ret := mciSendCommand(aDeviceID {Mp.DeviceId}, MCI_SET, MCI_SET_TIME_FORMAT,
longint(@MciSetParms));
if Ret <> 0 then
Showmessage('Error convering timeformat...');
end;
begin
Memo1.Clear;
aDeviceID := GetTheDeviceID;
Application.ProcessMessages;
Memo1.Lines.Add('Track info :');
SetTimeInfo;
Memo1.Lines.Add('Tracks: ' + GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,
MCI_STATUS_NUMBER_OF_TRACKS, 0));
Memo1.Lines.Add(' ');
for I := 1 to StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,
MCI_STATUS_NUMBER_OF_TRACKS, 0)) do
begin
Memo1.Lines.Add('Track ' + IntToStr(I) + ' : ' + IntToStr(MCI_MSF_MINUTE
(StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM +
MCI_TRACK, MCI_STATUS_LENGTH, I)))) + ':' +
IntToStr(MCI_MSF_SECOND(StrToInt(GetTrackInfo(MCI_STATUS,
MCI_STATUS_ITEM + MCI_TRACK, MCI_STATUS_LENGTH, I)))));
end;
Application.ProcessMessages;
end;
end.
Solve 2:
To get the number of tracks and the length of the current track that is playing, use this code :
uses
mmsystem;
procedure GetInfo(mp: TMediaPlayer);
var
Trk, Min, Sec: word;
begin
with mp do
begin
Trk := MCI_TMSF_TRACK(Position);
Min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position);
end;
label1.caption := Format('%.2d/%.2d %.2d:%.2d', [Trk, mp.tracks, min, sec]);
end;
And if you would like to check for an audio CD, try this code:
function IsAudioCD(Drive: char): bool;
var
DrivePath: string;
MaximumComponentLength: DWORD;
FileSystemFlags: DWORD;
VolumeName: string;
begin
Result := false;
DrivePath := Drive + ':\';
if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil,
MaximumComponentLength, FileSystemFlags, nil, 0);
if lStrCmp(PChar(VolumeName), 'Audio CD') = 0 then
result := true;
end;
Взято с
Delphi Knowledge BaseКак получить информацию о локальных настройках системы?
Как получить информацию о локальных настройках системы?
Delphi имеет функцию GetLocaleInfo, которая позволяет получать различную информацию о локальных настройках, таких как системный язык, символ валюты, количество десятичных знаков и т.д.
Далее приведена функция, которая возвращает значение в зависимости от параметра "flag":
........
function TForm1.GetLocaleInformation(Flag: Integer): String;
var
pcLCA: Array[0..20] of Char;
begin
if( GetLocaleInfo(LOCALE_SYSTEM_DEFAULT,Flag,pcLCA,19) <= 0 ) then begin
pcLCA[0] := #0;
end;
Result := pcLCA;
end;
........
Пример использования функции:
........
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetLocaleInformation(LOCALE_SENGLANGUAGE));
end;
........
"Flag" может содержать следующее значение (если посмотреть в Windows.pas):
LOCALE_NOUSEROVERRIDE { do not use user overrides }
LOCALE_USE_CP_ACP { use the system ACP }
LOCALE_ILANGUAGE { language id }
LOCALE_SLANGUAGE { localized name of language }
LOCALE_SENGLANGUAGE { English name of language }
LOCALE_SABBREVLANGNAME { abbreviated language name }
LOCALE_SNATIVELANGNAME { native name of language }
LOCALE_ICOUNTRY { country code }
LOCALE_SCOUNTRY { localized name of country }
LOCALE_SENGCOUNTRY { English name of country }
LOCALE_SABBREVCTRYNAME { abbreviated country name }
LOCALE_SNATIVECTRYNAME { native name of country }
LOCALE_IDEFAULTLANGUAGE { default language id }
LOCALE_IDEFAULTCOUNTRY { default country code }
LOCALE_IDEFAULTCODEPAGE { default oem code page }
LOCALE_IDEFAULTANSICODEPAGE { default ansi code page }
LOCALE_IDEFAULTMACCODEPAGE { default mac code page }
LOCALE_SLIST { list item separator }
LOCALE_IMEASURE { 0 = metric, 1 = US }
LOCALE_SDECIMAL { decimal separator }
LOCALE_STHOUSAND { thousand separator }
LOCALE_SGROUPING { digit grouping }
LOCALE_IDIGITS { number of fractional digits }
LOCALE_ILZERO { leading zeros for decimal }
LOCALE_INEGNUMBER { negative number mode }
LOCALE_SNATIVEDIGITS { native ascii 0-9 }
LOCALE_SCURRENCY { local monetary symbol }
LOCALE_SINTLSYMBOL { intl monetary symbol }
LOCALE_SMONDECIMALSEP { monetary decimal separator }
LOCALE_SMONTHOUSANDSEP { monetary thousand separator }
LOCALE_SMONGROUPING { monetary grouping }
LOCALE_ICURRDIGITS { # local monetary digits }
LOCALE_IINTLCURRDIGITS { # intl monetary digits }
LOCALE_ICURRENCY { positive currency mode }
LOCALE_INEGCURR { negative currency mode }
LOCALE_SDATE { date separator }
LOCALE_STIME { time separator }
LOCALE_SSHORTDATE { short date format string }
LOCALE_SLONGDATE { long date format string }
LOCALE_STIMEFORMAT { time format string }
LOCALE_IDATE { short date format ordering }
LOCALE_ILDATE { long date format ordering }
LOCALE_ITIME { time format specifier }
LOCALE_ITIMEMARKPOSN { time marker position }
LOCALE_ICENTURY { century format specifier (short date) }
LOCALE_ITLZERO { leading zeros in time field }
LOCALE_IDAYLZERO { leading zeros in day field (short date) }
LOCALE_IMONLZERO { leading zeros in month field (short date) }
LOCALE_S1159 { AM designator }
LOCALE_S2359 { PM designator }
LOCALE_ICALENDARTYPE { type of calendar specifier }
LOCALE_IOPTIONALCALENDAR { additional calendar types specifier }
LOCALE_IFIRSTDAYOFWEEK { first day of week specifier }
LOCALE_IFIRSTWEEKOFYEAR { first week of year specifier }
LOCALE_SDAYNAME1 { long name for Monday }
LOCALE_SDAYNAME2 { long name for Tuesday }
LOCALE_SDAYNAME3 { long name for Wednesday }
LOCALE_SDAYNAME4 { long name for Thursday }
LOCALE_SDAYNAME5 { long name for Friday }
LOCALE_SDAYNAME6 { long name for Saturday }
LOCALE_SDAYNAME7 { long name for Sunday }
LOCALE_SABBREVDAYNAME1 { abbreviated name for Monday }
LOCALE_SABBREVDAYNAME2 { abbreviated name for Tuesday }
LOCALE_SABBREVDAYNAME3 { abbreviated name for Wednesday }
LOCALE_SABBREVDAYNAME4 { abbreviated name for Thursday }
LOCALE_SABBREVDAYNAME5 { abbreviated name for Friday }
LOCALE_SABBREVDAYNAME6 { abbreviated name for Saturday }
LOCALE_SABBREVDAYNAME7 { abbreviated name for Sunday }
LOCALE_SMONTHNAME1 { long name for January }
LOCALE_SMONTHNAME2 { long name for February }
LOCALE_SMONTHNAME3 { long name for March }
LOCALE_SMONTHNAME4 { long name for April }
LOCALE_SMONTHNAME5 { long name for May }
LOCALE_SMONTHNAME6 { long name for June }
LOCALE_SMONTHNAME7 { long name for July }
LOCALE_SMONTHNAME8 { long name for August }
LOCALE_SMONTHNAME9 { long name for September }
LOCALE_SMONTHNAME10 { long name for October }
LOCALE_SMONTHNAME11 { long name for November }
LOCALE_SMONTHNAME12 { long name for December }
LOCALE_SMONTHNAME13 { long name for 13th month (if exists) }
LOCALE_SABBREVMONTHNAME1 { abbreviated name for January }
LOCALE_SABBREVMONTHNAME2 { abbreviated name for February }
LOCALE_SABBREVMONTHNAME3 { abbreviated name for March }
LOCALE_SABBREVMONTHNAME4 { abbreviated name for April }
LOCALE_SABBREVMONTHNAME5 { abbreviated name for May }
LOCALE_SABBREVMONTHNAME6 { abbreviated name for June }
LOCALE_SABBREVMONTHNAME7 { abbreviated name for July }
LOCALE_SABBREVMONTHNAME8 { abbreviated name for August }
LOCALE_SABBREVMONTHNAME9 { abbreviated name for September }
LOCALE_SABBREVMONTHNAME10 { abbreviated name for October }
LOCALE_SABBREVMONTHNAME11 { abbreviated name for November }
LOCALE_SABBREVMONTHNAME12 { abbreviated name for December }
LOCALE_SABBREVMONTHNAME13 { abbreviated name for 13th month (if exists) }
LOCALE_SPOSITIVESIGN { positive sign }
LOCALE_SNEGATIVESIGN { negative sign }
LOCALE_IPOSSIGNPOSN { positive sign position }
LOCALE_INEGSIGNPOSN { negative sign position }
LOCALE_IPOSSYMPRECEDES { mon sym precedes pos amt }
LOCALE_IPOSSEPBYSPACE { mon sym sep by space from pos amt }
LOCALE_INEGSYMPRECEDES { mon sym precedes neg amt }
LOCALE_INEGSEPBYSPACE { mon sym sep by space from neg amt }
LOCALE_FONTSIGNATURE { font signature }
LOCALE_SISO639LANGNAME { ISO abbreviated language name }
LOCALE_SISO3166CTRYNAME { ISO abbreviated country name }
Взято с Исходников.ru
Как получить информацию о процессоре?
Как получить информацию о процессоре?
О процессоре можно на любом уровне (приложении или драйвере) получить информацию с помощью команды(машинной) CPUID(386+):
Например(Вставка на асм в языке Паскаль):
{Получить тип процессора}
asm
mov eax,0
cpuid {Или db 0Fh, 0A2h}
{Теперь регистры EBX:ECX:EDX содержат строку "Genu-inel-ntel" (например)}
end;
Передать в Паскаль содержимое регистров можно, например, так:
var
EBXstr,ECXstr,EDXstr: string[5];
begin
asm
mov eax,0
cpuid
mov dword ptr EBXstr+1,EBX
mov byte ptr EBXstr,4
mov dword ptr ECXstr+1,ECX
mov byte ptr ECXstr,4
mov dword ptr EDXstr+1,EDX
mov byte ptr EDXstr,4
end;
writeln(EBSstr,ECXstr,EDXstr);
Автор ответа: Chingachguk
Взято с Vingrad.ru
unit CpuId;
interface
uses Windows, Mmsystem, Sysutils, Math, Dialogs;
type
TCpuRec=record
Name:string[128];
Vendor:string[12];
Frequency:word;
Family:integer;
Model:integer;
Stepping:integer;
L1DCache:word;
L1ICache:word;
L2Cache:word;
end;
TCpuType = (cpu8086, cpu286, cpu386, cpu486, cpuPentium);
TCpuData=object
function GetCPUIDSupport:Boolean;
function GetVendorString:string;
function GetCPUFrequency:word;
procedure GetFMS(var Family,Model,Stepping:byte);
function GetMaxCpuId:dword;
function CheckFPU:Boolean;
function CheckTSC:Boolean;
function CheckMSR:Boolean;
function CheckMPS:Boolean;
function GetNoCpus:cardinal;
function CheckPN:Boolean;
function CheckCMPXCHG8B:Boolean;
function CheckCMOVe:Boolean;
function CheckSelfSnoop:Boolean;
function CheckDebugTraceStore:Boolean;
function CheckFXSAVEFXRSTOR:Boolean;
function CheckMMX:Boolean;
function CheckMMXplus:Boolean;
function CheckSSE:Boolean;
function CheckSSE2:Boolean;
function CheckAMD3DNow:Boolean;
function CheckAMD3DNowPlus:Boolean;
function GetMaxExtendedFunctions:dword;
procedure GetExtendedFMS(var Family,Model,Stepping:byte);
function GetExtendedCpuName:string;
function GetExtendedL1DCache:word;
function GetExtendedL1ICache:word;
function GetExtendedL2Cache:word;
function CheckCeleron:Boolean;
function CheckPentiumIII:Boolean;
function CheckXeon:Boolean;
function CheckPentium4:Boolean;
function CheckIthanium:Boolean;
//****Aici am conrectat****
function IntelP5N:string;
function IntelP6N:string;
//****Pana aici****
function AMDK5N:string;
function Cyrix686N:string;
function GenericCpuN:string;
function P5CacheL1DI:word;
function P6CacheL1DI:word;
function P6CacheL2:word;
function AuthenticAMD:TCpuRec;
function GenuineIntel:TCpuRec;
function CyrixInstead:TCpuRec;
function GenericCPU:TCpuRec;
end;
const
Intel486:array[0..8] of string=
(''Intel 486 DX'',
''Intel 486 DX'',
''Intel 486 SX'',
''Intel 486 DX2'',
''Intel 486 SL'',
''Intel 486 SX2'',
''Intel 486 DX2'',
''Intel 486 DX4'',
''Intel 486 DX4'');
UMC486:array[0..1] of string=
(''UMC U5D'',
''UMC U5S'');
AMD486:array[0..5] of string=
(''AMD 486 DX2'',
''AMD 486 DX2'',
''AMD 486 DX4'',
''AMD 486 DX4'',
''AMD 5x86'',
''AMD 5x86'');
IntelP5:array[0..6] of string=
(''Intel Pentium P5 A-Step'',
''Intel Pentium P5'',
''Intel Pentium P54C'',
''Intel Pentium P24T Overdrive'',
''Intel Pentium MMX P55C'',
''Intel Pentium P54C'',
''Intel Pentium MMX P55C'');
NexGenNx586=''NexGen Nx586'';
Cyrix4x86=''VIA Cyrix 4x86'';
Cyrix5x86=''VIA Cyrix 5x86'';
CyrixMediaGX=''VIA Cyrix Media GX'';
CyrixM1=''VIA Cyrix 6x86'';
CyrixM2=''VIA Cyrix 6x86MX'';
CyrixIII=''VIA Cyrix III'';
AMDK5:array[0..3] of string=
(''AMD SSA5 (PR75/PR90/PR100)'',
''AMD 5k86 (PR120/PR133)'',
''AMD 5k86 (PR166)'',
''AMD 5k86 (PR200)'');
AMDK6:array[0..4] of string=
(''AMD K6 (166~233)'',
''AMD K6 (266~300)'',
''AMD K6-2'',
''AMD K6-III'',
''AMD K6-2+ or K6-III+'');
Centaur:array[0..2] of string=
(''Centaur C6'',
''Centaur C2'',
''Centaur C3'');
Rise:array[0..1] of string=
(''Rise mP6'',
''Rise mP6'');
IntelP6:array[0..7] of string=
(''Intel Pentium Pro A-Step'',
''Intel Pentium Pro'',
''Intel Pentium II'',
''Intel Pentium II'',
''Intel Pentium II'',
''Intel Pentium III'',
''Intel Pentium III'',
''Intel Pentium III'');
AMDK7:array[0..3] of string=
(''AMD Athlon(tm) Processor'',
''AMD Athlon(tm) Processor'',
''AMD Duron(tm) Processor'',
''AMD Thunderbird Processor'');
IntelP4=''Intel Pentium 4'';
var CpuData:TCpuData;
implementation
function TCpuData.GetCPUIDSupport:Boolean;
var TempDetect:dword;
begin
asm
pushf
pushfd
push eax
push ebx
push ecx
push edx
pushfd
pop eax
mov ebx,eax
xor eax,$00200000
push eax
popfd
pushfd
pop eax
push ebx
popfd
xor eax,ebx
mov TempDetect,eax
pop edx
pop ecx
pop ebx
pop eax
popfd
popf
end;
GetCPUIDSupport:=(TempDetect=$00200000);
end;
function TCpuData.GetVendorString:string;
var s1,s2,s3:array[0..3] of char;
TempVendor:string;
i:integer;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,0
db $0F,$A2 /// cpuid
mov s1,ebx
mov s2,edx
mov s3,ecx
pop edx
pop ecx
pop ebx
pop eax
end;
TempVendor:='''';
for i:=0 to 3 do
TempVendor:=TempVendor+s1[i];
for i:=0 to 3 do
TempVendor:=TempVendor+s2[i];
for i:=0 to 3 do
TempVendor:=TempVendor+s3[i];
GetVendorString:=TempVendor;
end;
function TCpuData.GetCPUFrequency:word;
var TimeStart:integer;
TimeStop:integer;
StartTicks:dword;
EndTicks:dword;
TotalTicks:dword;
cpuSpeed:dword;
NeverExit:Boolean;
begin
TimeStart:=0;
TimeStop:=0;
StartTicks:=0;
EndTicks:=0;
TotalTicks:=0;
cpuSpeed:=0;
NeverExit:=True;
TimeStart:=timeGetTime;
while NeverExit do
begin
TimeStop:=timeGetTime;
if ((TimeStop-TimeStart)>1) then
begin
asm
xor eax,eax
xor ebx,ebx
xor ecx,ecx
xor edx,edx
db $0F,$A2 /// cpuid
db $0F,$31 /// rdtsc
mov StartTicks,eax
end;
Break;
end;
end;
TimeStart:=TimeStop;
while NeverExit do
begin
TimeStop:=timeGetTime;
if ((TimeStop-TimeStart)>1000) then
begin
asm
xor eax,eax
xor ebx,ebx
xor ecx,ecx
xor edx,edx
db $0F,$A2 /// cpuid
db $0F,$31 /// rdtsc
mov EndTicks,eax
end;
Break;
end;
end;
TotalTicks:=EndTicks-StartTicks;
cpuSpeed:=TotalTicks div 1000000;
GetCPUFrequency:=cpuSpeed;
end;
procedure TCpuData.GetFMS(var Family,Model,Stepping:byte);
var TempFlags:dword;
BinFlags:array[0..31] of byte;
i,pos:integer;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
mov TempFlags,eax
pop edx
pop ecx
pop ebx
pop eax
end;
for i:=0 to 31 do
begin
BinFlags[i]:=TempFlags mod 2;
TempFlags:=TempFlags div 2;
end;
family:=0;
model:=0;
stepping:=0;
pos:=0;
for i:=0 to 3 do
begin
stepping:=stepping+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
inc(pos);
end;
pos:=4;
for i:=0 to 3 do
begin
model:=model+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
inc(pos);
end;
pos:=8;
for i:=0 to 3 do
begin
family:=family+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
inc(pos);
end;
end;
function TCpuData.GetMaxCpuId:dword;
var TempMax:dword;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,0
db $0F,$A2 /// cpuid
mov TempMax,eax
pop edx
pop ecx
pop ebx
pop eax
end;
GetMaxCpuId:=TempMax;
end;
function TCpuData.CheckFPU:Boolean;
label NoFpu;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$1
jz NoFpu
mov edx,0
mov TempCheck,edx
NoFpu:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckFpu:=(TempCheck=0);
end;
function TCpuData.CheckTSC:Boolean;
label NoTSC;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$10
jz NoTSC
mov edx,0
mov TempCheck,edx
NoTSC:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckTSC:=(TempCheck=0);
end;
function TCpuData.CheckMSR:Boolean;
label NoMSR;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$20
jz NoMSR
mov edx,0
mov TempCheck,edx
NoMSR:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckMSR:=(TempCheck=0);
end;
function TCpuData.CheckMPS:Boolean;
var SysInfo:TSystemInfo;
begin
GetSysTemInfo(SysInfo);
CheckMPS:=(SysInfo.dwNumberOfProcessors>1);
end;
function TCpuData.GetNoCpus:cardinal;
var SysInfo:TSystemInfo;
begin
GetSystemInfo(SysInfo);
GetNoCpus:=SysInfo.dwNumberOfProcessors;
end;
function TCpuData.CheckPN:Boolean;
label NoPN;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$40000
jz NoPN
mov edx,0
mov TempCheck,edx
NoPN:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckPN:=(TempCheck=0);
end;
function TCpuData.CheckCMPXCHG8B:Boolean;
label NoCMPXCHG8B;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$100
jz NoCMPXCHG8B
mov edx,0
mov TempCheck,edx
NoCMPXCHG8B:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckCMPXCHG8B:=(TempCheck=0);
end;
function TCpuData.CheckCMOVe:Boolean;
label NoCMOVe;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$8000
jz NoCMOVe
mov edx,0
mov TempCheck,edx
NoCMOVe:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckCMOVe:=(TempCheck=0);
end;
function TCpuData.CheckSelfSnoop:Boolean;
label NoSelfSnoop;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$8000000
jz NoSelfSnoop
mov edx,0
mov TempCheck,edx
NoSelfSnoop:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckSelfSnoop:=(TempCheck=0);
end;
function TCpuData.CheckDebugTraceStore:Boolean;
label NoDebugTraceStore;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$200000
jz NoDebugTraceStore
mov edx,0
mov TempCheck,edx
NoDebugTraceStore:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckDebugTraceStore:=(TempCheck=0);
end;
function TCpuData.CheckFXSAVEFXRSTOR:Boolean;
label NoFXSAVEFXRSTOR;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$1000000
jz NoFXSAVEFXRSTOR
mov edx,0
mov TempCheck,edx
NoFXSAVEFXRSTOR:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckFXSAVEFXRSTOR:=(TempCheck=0);
end;
function TCpuData.CheckMMX:Boolean;
label NoMMX;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$800000
jz NoMMX
mov edx,0
mov TempCheck,edx
NoMMX:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckMMX:=(TempCheck=0);
end;
function TCpuData.CheckMMXplus:Boolean;
label NoMMXplus;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000001
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
test edx,$400000
jz NoMMXplus
mov edx,0
mov TempCheck,edx
NoMMXplus:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckMMXplus:=(TempCheck=0);
end;
function TCpuData.CheckSSE:Boolean;
label NoSSE;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$2000000
jz NoSSE
mov edx,0
mov TempCheck,edx
NoSSE:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckSSE:=(TempCheck=0);
end;
function TCpuData.CheckSSE2:Boolean;
label NoSSE2;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
test edx,$4000000
jz NoSSE2
mov edx,0
mov TempCheck,edx
NoSSE2:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckSSE2:=(TempCheck=0);
end;
function TCpuData.CheckAMD3DNow:Boolean;
label NoAMD3DNow;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000001
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
test edx,$80000000
jz NoAMD3DNow
mov edx,0
mov TempCheck,edx
NoAMD3DNow:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckAMD3DNow:=(TempCheck=0);
end;
function TCpuData.CheckAMD3DNowPlus:Boolean;
label NoAMD3DNowPlus;
var TempCheck:dword;
begin
TempCheck:=1;
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000001
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
test edx,$40000000
jz NoAMD3DNowPlus
mov edx,0
mov TempCheck,edx
NoAMD3DNowPlus:
pop edx
pop ecx
pop ebx
pop eax
end;
CheckAMD3DNowPlus:=(TempCheck=0);
end;
function TCpuData.GetMaxExtendedFunctions:dword;
var TempExt:dword;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000000
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
shl eax,1
shr eax,1
mov TempExt,eax
pop edx
pop ecx
pop ebx
pop eax
end;
GetMaxExtendedFunctions:=TempExt;
end;
procedure TCpuData.GetExtendedFMS(var family,model,stepping:byte);
var TempFlags:dword;
BinFlags:array[0..31] of byte;
i,pos:integer;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000001
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
mov TempFlags,eax
pop edx
pop ecx
pop ebx
pop eax
end;
for i:=0 to 31 do
begin
BinFlags[i]:=TempFlags mod 2;
TempFlags:=TempFlags div 2;
end;
family:=0;
model:=0;
stepping:=0;
pos:=0;
for i:=0 to 3 do
begin
stepping:=stepping+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
inc(pos);
end;
pos:=4;
for i:=0 to 3 do
begin
model:=model+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
inc(pos);
end;
pos:=8;
for i:=0 to 3 do
begin
family:=family+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
inc(pos);
end;
end;
function TCpuData.GetExtendedCpuName:string;
var s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12:array[0..3] of char;
TempCpuName:string;
i:integer;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000002
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
mov s1,eax
mov s2,ebx
mov s3,ecx
mov s4,edx
mov eax,$80000003
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
mov s5,eax
mov s6,ebx
mov s7,ecx
mov s8,edx
mov eax,$80000004
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
mov s9,eax
mov s10,ebx
mov s11,ecx
mov s12,edx
pop edx
pop ecx
pop ebx
pop eax
end;
TempCpuName:='''';
for i:=0 to 3 do
TempCpuName:=TempCpuName+s1[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s2[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s3[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s4[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s5[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s6[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s7[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s8[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s9[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s10[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s11[i];
for i:=0 to 3 do
TempCpuName:=TempCpuName+s12[i];
GetExtendedCpuName:=TempCpuName;
end;
function TCpuData.GetExtendedL1DCache:word;
var L1D,TempL1D:dword;
BinArray:array[0..31] of byte;
i,p:integer;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000005
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
mov L1D,ecx
pop edx
pop ecx
pop ebx
pop eax
end;
for i:=0 to 31 do
begin
BinArray[i]:=L1D mod 2;
L1D:=L1D div 2;
end;
TempL1D:=0;
p:=0;
for i:=24 to 31 do
begin
TempL1D:=TempL1D+(BinArray[i]*StrToInt(FloatToStr(Power(2,p))));
inc(p);
end;
GetExtendedL1DCache:=TempL1D;
end;
function TCpuData.GetExtendedL1ICache:word;
var L1I,TempL1I:dword;
BinArray:array[0..31] of byte;
i,p:integer;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000005
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
mov L1I,edx
pop edx
pop ecx
pop ebx
pop eax
end;
for i:=0 to 31 do
begin
BinArray[i]:=L1I mod 2;
L1I:=L1I div 2;
end;
TempL1I:=0;
p:=0;
for i:=24 to 31 do
begin
TempL1I:=TempL1I+(BinArray[i]*StrToInt(FloatToStr(Power(2,p))));
inc(p);
end;
GetExtendedL1ICache:=TempL1I;
end;
function TCpuData.GetExtendedL2Cache:word;
var L2,TempL2:dword;
BinArray:array[0..31] of byte;
i,p:integer;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,$80000006
mov ebx,0
mov ecx,0
mov edx,0
db $0F,$A2 /// cpuid
mov L2,ecx
pop edx
pop ecx
pop ebx
pop eax
end;
for i:=0 to 31 do
begin
BinArray[i]:=L2 mod 2;
L2:=L2 div 2;
end;
TempL2:=0;
p:=0;
for i:=16 to 31 do
begin
TempL2:=TempL2+(BinArray[i]*StrToInt(FloatToStr(Power(2,p))));
inc(p);
end;
GetExtendedL2Cache:=TempL2;
end;
function TCpuData.CheckCeleron:Boolean;
var BId:byte;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
mov BId,bl
pop edx
pop ecx
pop ebx
pop eax
end;
CheckCeleron:=(BId=$1);
end;
function TCpuData.CheckPentiumIII:Boolean;
var BId:byte;
begin
CheckPentiumIII:=(CheckMMX and CheckSSE);
end;
function TCpuData.CheckXeon:Boolean;
var BId:byte;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
mov BId,bl
pop edx
pop ecx
pop ebx
pop eax
end;
CheckXeon:=(BId=$3);
end;
function TCpuData.CheckPentium4:Boolean;
var BId:byte;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
mov BId,bl
pop edx
pop ecx
pop ebx
pop eax
end;
CheckPentium4:=(BId=$8);
end;
function TCpuData.CheckIthanium:Boolean;
var res:dword;
BinArray:array[0..31] of byte;
i:byte;
begin
asm
push eax
push ebx
push ecx
push edx
mov eax,1
db $0F,$A2 /// cpuid
mov res,edx
pop edx
pop ecx
pop ebx
pop eax
end;
for i:=0 to 31 do
begin
BinArray[i]:=res mod 2;
res:=res div 2;
end;
CheckIthanium:=(CheckPentium4 and (BinArray[30]=1));
end;
function TCpuData.IntelP5N:string;
begin
If CheckMMX then IntelP5N:=''Intel Pentium(r) MMX(tm)''
else IntelP5N:=''Intel Pentium(r)'';
end;
function TCpuData.IntelP6N:string;
begin
if CheckCeleron then IntelP6N:=''Intel Celeron(r)''
else
if CheckPentiumIII then IntelP6N:=''Intel Pentium(r) III''
else
if CheckXeon then IntelP6N:=''Intel Pentium(r) III Xeon(tm)''
else
if not CheckMMX then IntelP6N:=''Intel Pentium(r) PRO''
else IntelP6N:=''Intel Pentium(r) II'';
end;
function TCpuData.AMDK5N:string;
var Family,Model,Stepping:byte;
begin
GetFMS(Family,Model,Stepping);
if Model=0 then AMDK5N:=''AMD K5''
else AMDK5N:=GetExtendedCpuName;
end;
function TCpuData.Cyrix686N:string;
begin
if CpuData.GetMaxExtendedFunctions>0 then Cyrix686N:=GetExtendedCpuName
else
if CheckMMX then Cyrix686N:=''VIA Cyrix 6x86MII''
else
Cyrix686N:=''VIA Cyrix 6x86'';
end;
function TCpuData.GenericCpuN:string;
var SysInfo:TSystemInfo;
begin
GetSystemInfo(SysInfo);
if SysInfo.dwProcessorType=386
then GenericCpuN:=''Generic 386 CPU''
else
if SysInfo.dwProcessorType=486
then GenericCpuN:=''Generic 486 CPU''
else
if SysInfo.dwProcessorType=586
then GenericCpuN:=''Pentium Class CPU''
else GenericCpuN:=''Unknown CPU'';
end;
function TCpuData.P5CacheL1DI:word;
begin
if CheckMMX then P5CacheL1DI:=16
else P5CacheL1DI:=8;
end;
function TCpuData.P6CacheL1DI:word;
begin
if not CheckMMX then P6CacheL1DI:=8
else P6CacheL1DI:=16;
end;
function TCpuData.P6CacheL2:word;
var Family,Model,Stepping:byte;
begin
if CheckCeleron then P6CacheL2:=128
else
if CheckPentiumIII then begin
GetFMS(Family,Model,Stepping);
if Model=7 then P6CacheL2:=512
else if Model=8 then P6cacheL2:=256
else P6CacheL2:=512;
end
else if not CheckMMX then P6CacheL2:=512
else P6CacheL2:=512;
end;
function TCpuData.AuthenticAMD:TCpuRec;
var Family,Model,Stepping:byte;
EFamily,EModel,EStepping:byte;
begin
GetFMS(Family,Model,Stepping);
If Family=4 then begin
AuthenticAMD.Name:=''AMD 486'';
AuthenticAMD.Vendor:=GetVendorString;
AuthenticAMD.Frequency:=0;
AuthenticAMD.Family:=Family;
AuthenticAMD.Model:=Model;
AuthenticAMD.Stepping:=Stepping;
AuthenticAMD.L1DCache:=8;
AuthenticAMD.L1ICache:=8;
AuthenticAMD.L2Cache:=0;
end
else
if Family=5 then begin
if GetMaxExtendedFunctions>4 then
begin
AuthenticAMD.Name:=GetExtendedCpuName;
AuthenticAMD.Vendor:=GetVendorString;
AuthenticAMD.Frequency:=GetCPUFrequency;
GetExtendedFMS(EFamily,EModel,EStepping);
AuthenticAMD.Family:=EFamily;
AuthenticAMD.Model:=EModel;
AuthenticAMD.Stepping:=EStepping;
AuthenticAMD.L1DCache:=GetExtendedL1DCache;
AuthenticAMD.L1ICache:=GetExtendedL1ICache;
AuthenticAMD.L2Cache:=0;
end
else
begin
AuthenticAMD.Name:=AMDK5N;
AuthenticAMD.Vendor:=GetVendorString;
AuthenticAMD.Frequency:=GetCPUFrequency;
AuthenticAMD.Family:=Family;
AuthenticAMD.Model:=Model;
AuthenticAMD.Stepping:=Stepping;
AuthenticAMD.L1DCache:=16;
AuthenticAMD.L1ICache:=16;
AuthenticAMD.L2Cache:=0;
end;
end
else if family>5 then
begin
AuthenticAMD.Name:=GetExtendedCpuName;
AuthenticAMD.Name:=GetExtendedCpuName;
AuthenticAMD.Vendor:=GetVendorString;
AuthenticAMD.Frequency:=GetCPUFrequency;
GetExtendedFMS(EFamily,EModel,EStepping);
AuthenticAMD.Family:=EFamily;
AuthenticAMD.Model:=EModel;
AuthenticAMD.Stepping:=EStepping;
AuthenticAMD.L1DCache:=GetExtendedL1DCache;
AuthenticAMD.L1ICache:=GetExtendedL1ICache;
AuthenticAMD.L2Cache:=GetExtendedL2Cache;
end;
end;
function TCpuData.GenuineIntel:TCpuRec;
var Family,Model,Stepping:byte;
begin
GetFMS(Family,Model,Stepping);
if Family=4 then begin
GenuineIntel.Name:=''Intel 486'';
GenuineIntel.Vendor:=GetVendorString;
GenuineIntel.Frequency:=0;
GenuineIntel.Family:=Family;
GenuineIntel.Model:=Model;
GenuineIntel.Stepping:=Stepping;
GenuineIntel.L1DCache:=8;
GenuineIntel.L1ICache:=8;
GenuineIntel.L2Cache:=0;
end
else
if Family=5 then begin
GenuineIntel.Name:=IntelP5N;
GenuineIntel.Vendor:=GetVendorString;
GenuineIntel.Frequency:=GetCPUFrequency;
GenuineIntel.Family:=Family;
GenuineIntel.Model:=Model;
GenuineIntel.Stepping:=Stepping;
GenuineIntel.L1DCache:=P5CacheL1DI;
GenuineIntel.L1ICache:=P5CacheL1DI;
GenuineIntel.L2Cache:=0;
end
else
if Family=6 then begin
GenuineIntel.Name:=IntelP6N;
GenuineIntel.Vendor:=GetVendorString;
GenuineIntel.Frequency:=GetCPUFrequency;
GenuineIntel.Family:=Family;
GenuineIntel.Model:=Model;
GenuineIntel.Stepping:=Stepping;
GenuineIntel.L1DCache:=P6CacheL1DI;
GenuineIntel.L1ICache:=P6CacheL1DI;
GenuineIntel.L2Cache:=P6CacheL2;
end
else
if Family=$F then begin
if CheckPentium4 then
begin
GenuineIntel.Name:=''Intel Pentium(r) 4'';
GenuineIntel.Vendor:=GetVendorString;
GenuineIntel.Frequency:=GetCPUFrequency;
GenuineIntel.Family:=32;
GenuineIntel.Model:=Model;
GenuineIntel.Stepping:=Stepping;
GenuineIntel.L1DCache:=8;
GenuineIntel.L1ICache:=12;
GenuineIntel.L2Cache:=256;
end
else if CheckIthanium then
begin
GenuineIntel.Name:=''Intel Ithanium'';
GenuineIntel.Vendor:=GetVendorString;
GenuineIntel.Frequency:=GetCPUFrequency;
GenuineIntel.Family:=64;
GenuineIntel.Model:=Model;
GenuineIntel.Stepping:=Stepping;
GenuineIntel.L1DCache:=0;
GenuineIntel.L1ICache:=0;
GenuineIntel.L2Cache:=0;
end;
end;
end;
function TCpuData.CyrixInstead:TCpuRec;
var Family,Model,Stepping:byte;
EFamily,EModel,EStepping:byte;
begin
GetFMS(Family,Model,Stepping);
if Family=4 then begin
CyrixInstead.Name:=''VIA Cyrix 4x86'';
CyrixInstead.Vendor:=GetVendorString;
CyrixInstead.Frequency:=0;
CyrixInstead.Family:=Family;
CyrixInstead.Model:=Model;
CyrixInstead.Stepping:=Stepping;
CyrixInstead.L1DCache:=8;
CyrixInstead.L1ICache:=8;
CyrixInstead.L2Cache:=0;
end
else
if Family=5 then begin
CyrixInstead.Name:=''VIA Cyrix 5x86'';
CyrixInstead.Vendor:=GetVendorString;
CyrixInstead.Frequency:=GetCPUFrequency;
CyrixInstead.Family:=Family;
CyrixInstead.Model:=Model;
CyrixInstead.Stepping:=Stepping;
CyrixInstead.L1DCache:=8;
CyrixInstead.L1ICache:=8;
CyrixInstead.L2Cache:=0;
end
else begin
if GetMaxExtendedFunctions>0 then
Begin
CyrixInstead.Name:=GetExtendedCpuName;
CyrixInstead.Vendor:=GetVendorString;
CyrixInstead.Frequency:=GetCPUFrequency;
GetExtendedFMS(EFamily,EModel,EStepping);
CyrixInstead.Family:=EFamily;
CyrixInstead.Model:=EModel;
CyrixInstead.Stepping:=EStepping;
CyrixInstead.L1DCache:=GetExtendedL1DCache;
CyrixInstead.L1ICache:=GetExtendedL1ICache;
CyrixInstead.L2Cache:=GetExtendedL2Cache;
end
else begin
CyrixInstead.Name:=Cyrix686N;
CyrixInstead.Vendor:=GetVendorString;
CyrixInstead.Frequency:=GetCPUFrequency;
CyrixInstead.Family:=Family;
CyrixInstead.Model:=Model;
CyrixInstead.Stepping:=Stepping;
CyrixInstead.L1DCache:=32;
CyrixInstead.L1ICache:=32;
CyrixInstead.L2Cache:=0;
end;
end;
end;
function TCpuData.GenericCPU:TCpuRec;
var Family,Model,Stepping:byte;
EFamily,EModel,EStepping:byte;
begin
if not GetCPUIDSupport then
begin
MessageDlg(''This CPU does not support the CPUID instruction!!!'',mtWarning,
[mbOk],0);
GenericCPU.Name:=''Unidentified CPU'';
GenericCPU.Vendor:=''Unidentified'';
GenericCPU.Frequency:=0;
GenericCPU.Family:=-1;
GenericCPU.Model:=-1;
GenericCPU.Stepping:=-1;
GenericCPU.L1DCache:=0;
GenericCPU.L1ICache:=0;
GenericCPU.L2Cache:=0;
end
else
begin
GetFMS(Family,Model,Stepping);
if GetMaxExtendedFunctions>0 then
begin
GenericCPU.Name:=GetExtendedCPUName;
GenericCPU.Vendor:=GetVendorString;
GenericCPU.Frequency:=GetCPUFrequency;
CpuData.GetExtendedFMS(EFamily,EModel,EStepping);
GenericCPU.Family:=EFamily;
GenericCPU.Model:=EFamily;
GenericCPU.Stepping:=EStepping;
GenericCPU.L1DCache:=GetExtendedL1DCache;
GenericCPU.L1ICache:=GetExtendedL1ICache;
GenericCPU.L2Cache:=GetExtendedL2Cache;
end
else begin
GenericCPU.Name:=GenericCpuN;
GenericCPU.Vendor:=GetVendorString;
if Family<=4 then GenericCPU.Frequency:=0
else GenericCPU.Frequency:=GetCPUFrequency;
GenericCPU.Family:=Family;
GenericCPU.Model:=Model;
GenericCPU.Stepping:=Stepping;
GenericCPU.L1DCache:=0;
GenericCPU.L1ICache:=0;
GenericCPU.L2Cache:=0;
end;
end;
end;
end.
Взято с Исходников.ru
Как узнать тип процессора (через реестр)?
function CPUType: string;
var
Reg: TRegistry;
begin
CPUType := '';
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\Hardware\Description\System\CentralProcessor\0', False) then
CPUType := Reg.ReadString('Identifier');
finally
Reg.Free;
end;
end;
Источник:
Прислал p0sol
Как получить инфу о SCSI дисках?
Как получить инфу о SCSI дисках?
programScsiSN;
// PURPOSE: Simple console application that display SCSI harddisk serial number
{$APPTYPE CONSOLE}
uses
Windows, SysUtils;
//-------------------------------------------------------------
function GetDeviceHandle(sDeviceName: string): THandle;
begin
Result := CreateFile(PChar('\\.\' + sDeviceName),
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING, 0, 0)
end;
//-------------------------------------------------------------
function ScsiHddSerialNumber(DeviceHandle: THandle): string;
{$ALIGN ON}
type
TScsiPassThrough = record
Length: Word;
ScsiStatus: Byte;
PathId: Byte;
TargetId: Byte;
Lun: Byte;
CdbLength: Byte;
SenseInfoLength: Byte;
DataIn: Byte;
DataTransferLength: ULONG;
TimeOutValue: ULONG;
DataBufferOffset: DWORD;
SenseInfoOffset: ULONG;
Cdb: array[0..15] of Byte;
end;
TScsiPassThroughWithBuffers = record
spt: TScsiPassThrough;
bSenseBuf: array[0..31] of Byte;
bDataBuf: array[0..191] of Byte;
end;
{ALIGN OFF}
var
dwReturned: DWORD;
len: DWORD;
Buffer: array[0..SizeOf(TScsiPassThroughWithBuffers) +
SizeOf(TScsiPassThrough) - 1] of Byte;
sptwb: TScsiPassThroughWithBuffers absolute Buffer;
begin
Result := '';
FillChar(Buffer, SizeOf(Buffer), #0);
with sptwb.spt do
begin
Length := SizeOf(TScsiPassThrough);
CdbLength := 6; // CDB6GENERIC_LENGTH
SenseInfoLength := 24;
DataIn := 1; // SCSI_IOCTL_DATA_IN
DataTransferLength := 192;
TimeOutValue := 2;
DataBufferOffset := PChar(@sptwb.bDataBuf) - PChar(@sptwb);
SenseInfoOffset := PChar(@sptwb.bSenseBuf) - PChar(@sptwb);
Cdb[0] := $12; // OperationCode := SCSIOP_INQUIRY;
Cdb[1] := $01; // Flags := CDB_INQUIRY_EVPD; Vital product data
Cdb[2] := $80; // PageCode Unit serial number
Cdb[4] := 192; // AllocationLength
end;
len := sptwb.spt.DataBufferOffset + sptwb.spt.DataTransferLength;
if DeviceIoControl(DeviceHandle, $0004D004, @sptwb, SizeOf(TScsiPassThrough),
@sptwb, len, dwReturned, nil)
and ((PChar(@sptwb.bDataBuf) + 1)^ = #$80) then
SetString(Result, PChar(@sptwb.bDataBuf) + 4,
Ord((PChar(@sptwb.bDataBuf) + 3)^));
end;
//=============================================================
var
hDevice: THandle = 0;
sSerNum, sDeviceName: string;
begin
sDeviceName := ParamStr(1);
if sDeviceName = '' then
begin
WriteLn;
WriteLn('Display SCSI-2 device serial number.');
WriteLn;
WriteLn('Using:');
WriteLn;
if Win32Platform = VER_PLATFORM_WIN32_NT then // Windows NT/2000
WriteLn(' ScsiSN PhysicalDrive0')
else
WriteLn(' ScsiSN C:');
WriteLn(' ScsiSN Cdrom0');
WriteLn(' ScsiSN Tape0');
WriteLn;
Exit;
end;
hDevice := GetDeviceHandle(sDeviceName);
if hDevice = INVALID_HANDLE_VALUE then
WriteLn('Error on GetDeviceHandle: ', SysErrorMessage(GetLastError))
else
try
sSerNum := ScsiHddSerialNumber(hDevice);
if sSerNum = '' then
WriteLn('Error on DeviceIoControl: ',
SysErrorMessageGetLastError))
else
WriteLn('Device ' + sDeviceName
+ ' serial number = "', sSerNum, '"');
finally
CloseHandle(hDevice);
end;
end.
For more information about SCSI commands:
ftp://ftp.t10.org/t10/drafts/scsi-1/
ftp://ftp.t10.org/t10/drafts/spc/
ftp://ftp.t10.org/t10/drafts/spc2/
Взято с
Delphi Knowledge BaseКак получить инфу о жестком диске?
Как получить инфу о жестком диске?
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение сведений о диске (метка/имя диска, файловая система, серийный номер)
Получение информации о любом диске.
Работает на FDD, HDD, CD, другие не пробовал.
Создайте модуль с именем HDDInfo и полностью скопируйте в него весь текст.
Зависимости: Все Windows (32S,95,NT)
Автор: cyborg, cyborg1979@newmail.ru, ICQ:114205759, Бузулук
Copyright: Собственное написание (Осипов Евгений Анатольевич)
Дата: 23 мая 2002 г.
***************************************************** }
unit HDDInfo;
interface
Uses Windows;
Const {Константы для TypeOfDisk функции GetDisks}
DiskUnknown=0; {Неизвестные диски}
DiskNone=1; {Отсутствующие диски}
DiskFDD=DRIVE_REMOVABLE; {Съёмные диски, дискеты}
DiskHDD=DRIVE_FIXED; {Не съёиные диски, жёсткие диски}
DiskNet=DRIVE_REMOTE; {Сетевые диски}
DiskCDROM=DRIVE_CDROM; {CD ROM}
DiskRAM=DRIVE_RAMDISK; {Диски в ОЗУ}
{Получить имена нужных дисков}
function GetDisks(TypeOfDisk : Word) : String;
{Функция получения информации о диске (HDD,FDD,CD) с буквой Disk}
{
Передаваемые значения:
Disk - Буква диска
Получаемые значения:
VolumeName - Метка/Имя тома
FileSystemName - Файловая система
VolumeSerialNo - Серийный номер диска (можно привязывать к диску программы)
MaxComponentLength - Максимальная длинна имени файла
FileSystemFlags - Флаги смотрите в справке Delphi по GetVolumeInformation
Функция возвращает true, если всё прошло успешно (диск нашёлся),
и false, если возникли проблемы, например диска нет в дисководе,
либо дисковода такого вообще нет
}
Function GetHDDInfo(Disk : Char;Var VolumeName, FileSystemName : String;
Var VolumeSerialNo, MaxComponentLength, FileSystemFlags:LongWord) : Boolean;
implementation
function GetDisks(TypeOfDisk : Word) : String;{Получить имена нужных дисков}
var
DriveArray : array[1..26] of Char;
I : integer;
begin
DriveArray:='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
for I := 1 to 26 do
if GetDriveType(PChar(DriveArray[I]+':\')) = TypeOfDisk then
Result := Result+DriveArray[I];
end;
Function GetHDDInfo(Disk : Char;Var VolumeName, FileSystemName : String;
Var VolumeSerialNo, MaxComponentLength, FileSystemFlags:LongWord) : Boolean;
Var
_VolumeName,_FileSystemName:array [0..MAX_PATH-1] of Char;
_VolumeSerialNo,_MaxComponentLength,_FileSystemFlags:LongWord;
Begin
if GetVolumeInformation(PChar(Disk+':\'),_VolumeName,MAX_PATH,@_VolumeSerialNo,
_MaxComponentLength,_FileSystemFlags,_FileSystemName,MAX_PATH) then
Begin
VolumeName:=_VolumeName;
VolumeSerialNo:=_VolumeSerialNo;
MaxComponentLength:=_MaxComponentLength;
FileSystemFlags:=_FileSystemFlags;
FileSystemName:=_FileSystemName;
Result:=True;
End
else
Result:=False;
End;
end.
Пример использования:
USES ..., ..., ..., HDDInfo; {Добавляем наш модуль}
{Нужно создать на форме компонент TLabel , Name которого ставим в Disks}
{И в событии главной формы OnActicate написать это:}
procedure TMyForm.FormActivate(Sender: TObject);
Var
S,SOut : String;
I : Integer;
VolumeName,FileSystemName : String;
VolumeSerialNo,MaxComponentLength,FileSystemFlags:LongWord;
begin
S:=GetDisks(DiskHDD); {Получаем список Жёстких дисков (Параметр DiskHDD)}
SOut:='';
For I:=1 to Length(S) do {Получаем информацию о всех дисках и пишем в TLabel на форме}
Begin
{Если диск существует/вставлен ...}
if GetHDDInfo(S[I], VolumeName, FileSystemName, VolumeSerialNo,
MaxComponentLength, FileSystemFlags) then {... тогда собираем информацию}
SOut:=SOut+
'Диск: '+S[I]+#13#10+
'Метка: '+VolumeName+#13#10+
'Файловая система: '+FileSystemName+#13+#10+
'Серийный номер: '+IntToHex(VolumeSerialNo,8)+#13+#10+
'Макс. длина имени файла: '+IntToStr(MaxComponentLength)+#13+#10+
'Flags: '+IntToHex(FileSystemFlags,4)+#13#10+#13#10;
End;
Disks.Caption:=SOut; {Выводим в компонент TLabel полученные данные о дисках}
end;
Прислал Pegas
Взято с Vingrad.ru
Присутствует неточность в топике "Как получить инфу о жестком диске?".
Неточность заключается в том, что функция "GetVolumeInformation" выдает
совершенно разный номер диска под системами 9х и NT. Я долго бился над
этой проблемой т. к. в своей программе привязываются к номеру в своей
программе для определения какой диск вставил пользователь. Пару раз
задавал этот вопрос в форумах, но ответа так и не получил. Но недавно
я нашел решение этой проблемы. Вот код моей функции для корректного
определения серийного номера диска под любой ОС:
function SirealNumberDisk(disk: string): string;
// Определяем серийный номер диска
var
VolumeName : array [0..MAX_PATH-1] of Char;
FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;
MaxComponentLength : DWord;
FileSystemFlags : DWord;
function GetReplaceCDNumber(num: String): String;
var
i, len: Integer;
begin
Result:= '';
len:= Length(num);
if len <> 8 then exit;
for i:= 1 to (len div 2) do begin
Dec(len);
Result:= Result + num[len];
Result:= Result + num[len+1];
Dec(len);
end;
end;
begin
GetVolumeInformation(PChar(disk), VolumeName, MAX_PATH, @VolumeSerialNo, MaxComponentLength,
FileSystemFlags, FileSystemName, MAX_PATH);
Result:= IntToHex(Integer(VolumeSerialNo), 8);
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Result:= GetReplaceCDNumber(Result);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption:= SirealNumberDisk('f:\');
end;
Прислал Alex&Co
Посетите мой сайт
Как получить/изменить громкость?
Как получить/изменить громкость?
procedureGetVolume(var volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
volL := 0;
volR := 0;
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
// get volume
waveOutGetVolume(hWO, @vol);
volL := vol and $FFFF;
volR := vol shr 16;
waveOutClose(hWO);
end;
procedure SetVolume(const volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
vol := volL + volR shl 16;
// set volume
waveOutSetVolume(hWO, vol);
waveOutClose(hWO);
end;
Взято с
Delphi Knowledge BaseКак получить эффект тени для hint?
Как получить эффект тени для hint?
type
TXPHintWindow = class(THintWindow)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMNCPaint(var msg: TMessage); message WM_NCPAINT;
end;
function IsWinXP: Boolean;
begin
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
(Win32MajorVersion >= 5) and (Win32MinorVersion >= 1);
end;
procedure TXPHintWindow.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = $00020000;
begin
inherited;
if IsWinXP then
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
procedure TXPHintWindow.WMNCPaint(var msg: TMessage);
var
R: TRect;
DC: HDC;
begin
DC := GetWindowDC(Handle);
try
R := Rect(0, 0, Width, Height);
DrawEdge(DC, R, EDGE_ETCHED, BF_RECT or BF_MONO);
finally
ReleaseDC(Handle, DC);
end;
end;
initialization
HintWindowClass := TXPHintWindow;
Application.ShowHint := False;
Application.ShowHint := True;
end.
Взято с сайта
Как получить картинки из MessageDlg?
Как получить картинки из MessageDlg?
procedureTForm1.Button1Click(Sender: TObject);
var
Ic: TIcon;
begin
Ic := TIcon.Create;
Ic.Handle := LoadIcon(0, IDI_APPLICATION);
Form1.Canvas.Draw(1, 1, Ic);
Ic.Handle := LoadIcon(0, IDI_ASTERISK);
Form1.Canvas.Draw(32, 1, Ic);
Ic.Handle := LoadIcon(0, IDI_EXCLAMATION);
Form1.Canvas.Draw(64, 1, Ic);
Ic.Handle := LoadIcon(0, IDI_QUESTION);
Form1.Canvas.Draw(1, 32, Ic);
Ic.Handle := LoadIcon(0, IDI_HAND);
Form1.Canvas.Draw(32, 32, Ic);
Ic.Handle := LoadIcon(0, IDI_WINLOGO);
Form1.Canvas.Draw(64, 32, Ic);
Ic.Destroy;
end;
Взято из
Как получить картинку с видео источника
Как получить картинку с видео источника
Для использования следующиего примера необходимо иметь "Microsoft Video for Windows SDK". Пример показывает, как открыть видео устройство для захвата видео, как сграбить фрейм с устройства, как сохранить этот фрейм на диск в виде файла .BMP, как записать .AVI файл (со звуком, но без предварительного просмотра), и как закрыть устройство.
Замечание: Для работы примера необходимо иметь установленное устройство захвата видео (video capture device).
Пример:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
OpenVideo: TButton;
CloseVideo: TButton;
GrabFrame: TButton;
SaveBMP: TButton;
StartAVI: TButton;
StopAVI: TButton;
SaveDialog1: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure OpenVideoClick(Sender: TObject);
procedure CloseVideoClick(Sender: TObject);
procedure GrabFrameClick(Sender: TObject);
procedure SaveBMPClick(Sender: TObject);
procedure StartAVIClick(Sender: TObject);
procedure StopAVIClick(Sender: TObject);
private
{ Private declarations }
hWndC : THandle;
CapturingAVI : bool;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const WM_CAP_START = WM_USER;
const WM_CAP_STOP = WM_CAP_START + 68;
const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
const WM_CAP_SAVEDIB = WM_CAP_START + 25;
const WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
const WM_CAP_SEQUENCE = WM_CAP_START + 62;
const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;
function capCreateCaptureWindowA(lpszWindowName : PCHAR;
dwStyle : longint;
x : integer;
y : integer;
nWidth : integer;
nHeight : integer;
ParentWin : HWND;
nId : integer): HWND;
STDCALL EXTERNAL 'AVICAP32.DLL';
procedure TForm1.FormCreate(Sender: TObject);
begin
CapturingAVI := false;
hWndC := 0;
SaveDialog1.Options :=
[ofHideReadOnly, ofNoChangeDir, ofPathMustExist]
end;
procedure TForm1.OpenVideoClick(Sender: TObject);
begin
hWndC := capCreateCaptureWindowA('My Own Capture Window',
WS_CHILD or WS_VISIBLE ,
Panel1.Left,
Panel1.Top,
Panel1.Width,
Panel1.Height,
Form1.Handle,
0);
if hWndC <> 0 then
SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
end;
procedure TForm1.CloseVideoClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);
hWndC := 0;
end;
end;
procedure TForm1.GrabFrameClick(Sender: TObject);
begin
if hWndC <> 0 then
SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);
end;
procedure TForm1.SaveBMPClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SaveDialog1.DefaultExt := 'bmp';
SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp';
if SaveDialog1.Execute then
SendMessage(hWndC,
WM_CAP_SAVEDIB,
0,
longint(pchar(SaveDialog1.FileName)));
end;
end;
procedure TForm1.StartAVIClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SaveDialog1.DefaultExt := 'avi';
SaveDialog1.Filter := 'AVI files (*.avi)|*.avi';
if SaveDialog1.Execute then begin
CapturingAVI := true;
SendMessage(hWndC,
WM_CAP_FILE_SET_CAPTURE_FILEA,
0,
Longint(pchar(SaveDialog1.FileName)));
SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0);
end;
end;
end;
procedure TForm1.StopAVIClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SendMessage(hWndC, WM_CAP_STOP, 0, 0);
CapturingAVI := false;
end;
end;
end.
Взято с Исходников.ru
Как получить контекст свойства по его целочисленному значению?
Как получить контекст свойства по его целочисленному значению?
unitPropertyList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons;
type
TMyStream = class(TFileStream)
private
FFred: integer;
published
property Fred: integer read FFred write FFred;
end;
type
TFrmPropertyList = class(TForm)
SpeedButton1: TSpeedButton;
ListBox1: TListBox;
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FrmPropertyList: TFrmPropertyList;
implementation
{$R *.DFM}
uses
TypInfo;
procedure ListProperties(AInstance: TPersistent; AList: TStrings);
var
i: integer;
pInfo: PTypeInfo;
pType: PTypeData;
propList: PPropList;
propCnt: integer;
tmpStr: string;
begin
pInfo := AInstance.ClassInfo;
if (pInfo = nil) or (pInfo^.Kind <> tkClass) then
raise Exception.Create('Invalid type information');
pType := GetTypeData(pInfo); {Pointer to TTypeData}
AList.Add('Class name: ' + pInfo^.Name);
{If any properties, add them to the list}
propCnt := pType^.PropCount;
if propCnt > 0 then
begin
AList.Add (EmptyStr);
tmpStr := IntToStr(propCnt) + ' Propert';
if propCnt > 1 then
tmpStr := tmpStr + 'ies'
else
tmpStr := tmpStr + 'y';
AList.Add(tmpStr);
FillChar(tmpStr[1], Length(tmpStr), '-');
AList.Add(tmpStr);
{Get memory for the property list}
GetMem(propList, sizeOf(PPropInfo) * propCnt);
try
{Fill in the property list}
GetPropInfos(pInfo, propList);
{Fill in info for each property}
for i := 0 to propCnt - 1 do
AList.Add(propList[i].Name + ': ' + propList[i].PropType^.Name);
finally
FreeMem(propList, sizeOf(PPropInfo) * propCnt);
end;
end;
end;
function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;
var
i: integer;
props: PPropList;
typeData: PTypeData;
begin
Result := nil;
if (AControl = nil) or (AControl.ClassInfo = nil) then
Exit;
typeData := GetTypeData(AControl.ClassInfo);
if (typeData = nil) or (typeData^.PropCount = 0) then
Exit;
GetMem(props, typeData^.PropCount * SizeOf(Pointer));
try
GetPropInfos(AControl.ClassInfo, props);
for i := 0 to typeData^.PropCount - 1 do
begin
with Props^[i]^ do
if (Name = AProperty) then
result := Props^[i];
end;
finally
FreeMem(props);
end;
end;
procedure TFrmPropertyList.SpeedButton1Click(Sender: TObject);
var
c: integer;
begin
ListProperties(self, ListBox1.Items);
for c := 0 to ComponentCount - 1 do
begin
ListBox1.Items.Add(EmptyStr);
ListProperties(Components[c], ListBox1.Items);
end;
end;
end.
Tip by Ralph Friedman
Взято из
Как получить координаты курсора в memo-поле?
Как получить координаты курсора в memo-поле?
procedure CaretPos(H: THandle; var L,C : Word);
begin
L := SendMessage(H,EM_LINEFROMCHAR,-1,0);
C := LoWord(SendMessage(H,EM_GETSEL,0,0)) - SendMessage(H,EM_LINEINDEX,-1,0);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LineNum,ColNum : Word;
begin
CaretPos(Memo1.Handle,LineNum,ColNum);
Edit1.Text := IntToStr(LineNum) + ' ' + IntToStr(ColNum);
end;
Хотя в Delphi 5 свойство CaretPos уже включено в memo.
Взято с Исходников.ru
Как получить номер строки memo, в которой находится курсор?
Для этого необходимо послать сообщение EM_LINEFROMCHAR.
LineNumber := Memo1.Perform(EM_LINEFROMCHAR, -1, 0);
Взято с Исходников.ru
Как получить неповторяющиеся случайные числа?
Как получить неповторяющиеся случайные числа?
procedureShuffle(var aArray; aItemCount: Integer; aItemSize: Integer);
{ after Julian M Bucknall }
var
Inx: Integer;
RandInx: Integer;
SwapItem: PByteArray;
A: TByteArray absolute aArray;
begin
if (aItemCount > 1) then
begin
GetMem(SwapItem, aItemSize);
try
for Inx := 0 to (aItemCount - 2) do
begin
RandInx := Random(aItemCount - Inx);
Move(A[Inx * aItemSize], SwapItem^, aItemSize);
Move(A[RandInx * aItemSize], A[Inx * aItemSize], aItemSize);
Move(SwapItem^, A[RandInx * aItemSize], aItemSize);
end;
finally
FreeMem(SwapItem, aItemSize);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
a: array[1..10] of Integer;
i: Shortint;
begin
Randomize;
for i := Low(a) to High(a) do a[i] := i;
Shuffle(a, High(a), SizeOf(Integer));
for i := 1 to High(a) - 1 do
ListBox1.Items.Add(IntToStr(a[i]));
end;
Взято с сайта
Автор: Дедок Василий
type
arr = array[1..255] of integer;
procedure FillArray(var A: arr; n: integer);
var
i: integer;
s: string;
q: byte;
begin
randomize;
s := '';
for i := 1 to n do
begin
q := random(i);
insert(chr(i), s, q);
end;
for i := 1 to n do
begin
A[i] := ord(s[i]);
end;
end;
Автор: Иваненко Фёдор Григорьевич
procedure FillArray(var A: array of Integer);
var
I, S, R: Integer;
begin
for I := 0 to High(A) do
A[I] := I;
for i := High(A) downto 0 do
begin
R := Random(I);
S := A[R];
A[R] := A[I];
A[I] := S;
end;
end;
Взято с
Как получить определённую часть текста из RichEdit?
Как получить определённую часть текста из RichEdit?
Иногда бывает необходимо полудить только часть текста из RichEdit не выделяя его, то есть не используя свойство SelText. Ниже представлен код, который позволяет сделать это.
{Переопределяем неправильное объявление TTextRange в RichEdit.pas}
TTextRange = record
chrg: TCharRange;
lpstrText: PAnsiChar;
end;
function REGetTextRange(RichEdit: TRichEdit;
BeginPos, MaxLength: Integer): string;
{RichEdit - RichEdit control
BeginPos - абсолютное значение первого символа
MaxLength - максимально число получаемых символов}
var
TextRange: TTextRange;
begin
if MaxLength>0 then
begin
SetLength(Result, MaxLength);
with TextRange do
begin
chrg.cpMin := BeginPos;
chrg.cpMax := BeginPos+MaxLength;
lpstrText := PChar(Result);
end;
SetLength(Result, SendMessage(RichEdit.Handle, EM_GETTEXTRANGE, 0,
longint(@TextRange)));
end
else Result:='';
end;
Следующую функцию можно использовать для получения слова, над которым находится курсор мышки:
function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer;
{ функция возвращает абсолютное положение символа для данных координат курсора}
var
P: TPoint;
begin
P := Point(X, Y);
Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, longint(@P));
end;
function REExtractWordFromPos(RichEdit: TRichEdit; X, Y: Integer):=
string;
{ X, Y - координаты в rich edit }
{возвращает слово в текущих координатах курсора}
var
BegPos, EndPos: Integer;
begin
BegPos := RECharIndexByPos(RichEdit, X, Y);
if (BegPos < 0) or
(SendMessage(RichEdit.Handle,EM_FINDWORDBREAK,WB_CLASSIFY,BegPos) and
(WBF_BREAKLINE or WBF_ISWHITE) <> 0 ) then
begin
result:='';
exit;
end;
if SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,WB_CLASSIFY,BegPos-1) and
(WBF_BREAKLINE or WBF_ISWHITE) = 0 then
BegPos:=SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
WB_MOVEWORDLEFT, BegPos);
EndPos:=SendMessage(RichEdit.Handle,EM_FINDWORDBREAK,WB_MOVEWORDRIGHT,BegPos);
Result:=TrimRight(REGetTextRange(RichEdit, BegPos, EndPos - BegPos));
end;
Взято с Исходников.ru
Как получить параметры Alias?
Как получить параметры Alias?
The following function uses the GetAliasParams method of TSession to get the directory mapping for an alias:
usesDbiProcs, DBiTypes;
function GetDataBaseDir(const Alias: string): string;
{* Will return the directory of the database given the alias
(without trailing backslash) *}
var
sp: PChar;
Res: pDBDesc;
begin
try
New(Res);
sp := StrAlloc(length(Alias) + 1);
StrPCopy(sp, Alias);
if DbiGetDatabaseDesc(sp, Res) = 0 then
Result := StrPas(Res^.szPhyName)
else
Result := '';
finally
StrDispose(sp);
Dispose(Res);
end;
end;
Взято с
Delphi Knowledge BaseКак получить переменные окружения типа PATH и PROMPT?
Как получить переменные окружения типа PATH и PROMPT?
Вариант 1:
Для этого используется API функция GetEnvironmentVariable.
GetEnvironmentVariable возвращает значения:
- В случае удачного выполнения функции, возвращаемое значение содержит количество символов, хранящихся в буфере, не включая последнего нулевого.
- Если указанная переменная окружения для текущего процесса не найдена, то возвращаемое значение равно нулю.
- Если буфер не достаточного размера, то возвращаемое значение равно требуемому размеру для хранения строки значения и завершающего нулевого символа.
function GetDOSEnvVar(const VarName: string): string;
var
i: integer;
begin
Result := '';
try
i := GetEnvironmentVariable(PChar(VarName), nil, 0);
if i > 0 then
begin
SetLength(Result, i);
GetEnvironmentVariable(Pchar(VarName), PChar(Result), i);
end;
except
Result := '';
end;
end;
Вариант 2:
procedure TMainFrm.AddVarsToMemo(Sender: TObject);
var
p : pChar;
begin
Memo1.Lines.Clear;
Memo1.WordWrap := false;
p := GetEnvironmentStrings;
while p^ <> #0 do begin
Memo1.Lines.Add(StrPas(p));
inc(p, lStrLen(p) + 1);
end;
FreeEnvironmentStrings(p);
end;
Взято с Исходников.ru
Как получить полный исходник HTML?
Как получить полный исходник HTML?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
В IE5, можно получить исходник используя свойство outerHTML тэгов
HTML. В IE4 или IE3, Вам понадобится записать документ в файл, а затем
загрузить файл в TMemo, TStrings, и т.д.
var
HTMLDocument: IHTMLDocument2;
PersistFile: IPersistFile;
begin
...
HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
PersistFile := HTMLDocument as IPersistFile;
PersistFile.Save(StringToOleStr('test.htm'), True);
while HTMLDocument.readyState < > 'complete' do
Application.ProcessMessages;
...
end;
Автор: Ron Loewy Обратите внимание: Вам понадобится импортировать библиотеку
MSHTML и добавить MSHTML_TLB как ActiveX, в секцию Uses.
Как получить POST данные?
Как получить POST данные?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
Если данные передаются в формате 'animal=cat& color=brown' и т.д.,
то попробуйте использовать следующий код:
procedure TDBModule.Navigate(stURL, stPostData: String; var wbWebBrowser: TWebBrowser);
var
vWebAddr, vPostData, vFlags, vFrame, vHeaders: OleVariant;
iLoop: Integer;
begin
{Are we posting data to this Url?}
if Length(stPostData)> 0 then
begin
{Require this header information if there is stPostData.}
vHeaders:= 'Content-Type: application/x-www-form-urlencoded'+ #10#13#0;
{Set the variant type for the vPostData.}
vPostData:= VarArrayCreate([0, Length(stPostData)], varByte);
for iLoop := 0 to Length(stPostData)- 1 do // Iterate
begin
vPostData[iLoop]:= Ord(stPostData[iLoop+ 1]);
end; // for
{Final terminating Character.}
vPostData[Length(stPostData)]:= 0;
{Set the type of Variant, cast}
TVarData(vPostData).vType:= varArray;
end;
{And the other stuff.}
vWebAddr:= stURL;
{Make the call Rex.}
wbWebBrowser.Navigate2(vWebAddr, vFlags, vFrame, vPostData, vHeaders);
end; {End of Navigate procedure.}
Автор: Craig Foley Ответ: А это другой способ:
procedure TForm1.SubmitPostForm;
var
strPostData: string;
Data: Pointer;
URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
{
< !-- submit this html form: -->
< form method=" post" action=" http://127.0.0.1/cgi-bin/register.pl" >
< input type=" text" name=" FIRSTNAME" value=" Hans" >
< input type=" text" name=" LASTNAME" value=" Gulo" >
< input type=" text" name=" NOTE" value=" thats it" >
< input type=" submit" >
< /form>
}
strPostData := 'FIRSTNAME=Hans& LASTNAME=Gulo& NOTE=thats+it';
PostData := VarArrayCreate([0, Length(strPostData) - 1], varByte);
Data := VarArrayLock(PostData);
try
Move(strPostData[1], Data^, Length(strPostData));
finally
VarArrayUnlock(PostData);
end;
URL := 'http://127.0.0.1/cgi-bin/register.pl';
Flags := EmptyParam;
TargetFrameName := EmptyParam;
Headers := EmptyParam; // TWebBrowse
// эти заголовки соответствующими зна?ениями
WebBrowser1.Navigate2(URL, Flags, TargetFrameName, PostData, Headers);
end;
Автор: Hans Gulo.
Как получить размер физической установленной памяти?
Как получить размер физической установленной памяти?
uses
Windows, SysUtils;
function DisplayRam: string;
var
Info: TMemoryStatus;
begin
Info.dwLength := SizeOf(TMemoryStatus);
GlobalMemoryStatus(Info);
Result := Format('%d MB RAM', [(Info.dwTotalPhys shr 20) + 1]);
end;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := sizeof(MemStat);
GlobalMemoryStatus(MemStat);
result := inttoStr(memstat.dwTotalPhys div 1024);
end;
function PhysmemFree: string;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := sizeof(MemStat);
GlobalMemoryStatus(MemStat);
result := inttoStr(memstat.dwAvailPhys div 1024);
end;
function MemLoad: string;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := sizeof(MemStat);
GlobalMemoryStatus(MemStat);
result := inttoStr(memstat.dwMemoryLoad);
end;
function TotalPageFile: string;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := sizeof(MemStat);
GlobalMemoryStatus(MemStat);
result := inttoStr(memstat.dwTotalPageFile div 1024);
end;
function AvailPageFile: string;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := sizeof(MemStat);
GlobalMemoryStatus(MemStat);
result := inttoStr(memstat.dwAvailPageFile div 1024);
end;
function VirTotPageFile: string;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := sizeof(MemStat);
GlobalMemoryStatus(MemStat);
result := inttoStr(memstat.dwTotalVirtual div 1024);
end;
function AvailVir: string;
var
MemStat: TMemoryStatus;
begin
MemStat.dwLength := sizeof(MemStat);
GlobalMemoryStatus(MemStat);
result := inttoStr(memstat.dwAvailVirtual div 1024);
end;
uses
Windows;
function TMyApp.GlobalMemoryStatus(Index: Integer): Integer;
var
MemoryStatus: TMemoryStatus
begin
with MemoryStatus do
begin
dwLength := SizeOf(TMemoryStatus);
Windows.GlobalMemoryStatus(MemoryStatus);
case Index of
1: Result := dwMemoryLoad;
2: Result := dwTotalPhys div 1024;
3: Result := dwAvailPhys div 1024;
4: Result := dwTotalPageFile div 1024;
5: Result := dwAvailPageFile div 1024;
6: Result := dwTotalVirtual div 1024;
7: Result := dwAvailVirtual div 1024;
else
Result := 0;
end;
end;
end;
Взято с
Delphi Knowledge BaseКак получить размер развёрнутого TComboBox?
Как получить размер развёрнутого TComboBox?
В течение события FormShow, выпадающему списке дважды посылается сообщение CB_SHOWDROPDOWN , один раз, чтобы он открылся, а второй - чтобы свернулся. Затем посылается сообщение CB_GETDROPPEDCONTROLRECT, передающее адрес TRect.
Когда вызов SendMessage возвращается, то TRect будет содержать прямоугольник, который соответствует раскрытому ComboBox-у относительно окна. Затем можно вызвать ScreenToClient для преобразования координат TRect-а в координаты относительно клиентской области формы.
var
R : TRect;
procedure TForm1.FormShow(Sender: TObject);
var
T : TPoint;
begin
SendMessage(ComboBox1.Handle,
CB_SHOWDROPDOWN,
1,
0);
SendMessage(ComboBox1.Handle,
CB_SHOWDROPDOWN,
0,
0);
SendMessage(ComboBox1.Handle,
CB_GETDROPPEDCONTROLRECT,
0,
LongInt(@r));
t := ScreenToClient(Point(r.Left, r.Top));
r.Left := t.x;
r.Top := t.y;
t := ScreenToClient(Point(r.Right, r.Bottom));
r.Right := t.x;
r.Bottom := t.y;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Canvas.Rectangle(r.Left,
r.Top,
r.Right,
r.Bottom );
end;
Взято с Исходников.ru
Как получить разрешение принтера по умолчанию?
Как получить разрешение принтера по умолчанию?
uses
Printers;
function GetPixelsPerInchX: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, LOGPIXELSX)
end;
function GetPixelsPerInchY: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, LOGPIXELSY)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := Format('x: %d y: %d DPI (dots per inch)',
[GetPixelsPerInchX, GetPixelsPerInchY]);
end;
Взято с сайта
Как получить результирующим полем разницу между хранимой датой и текущей датой
Как получить результирующим полем разницу между хранимой датой и текущей датой
SELECTCAST((поле_с_датой -"NOW") AS INTEGER) FROM MyBase
Получишь результат в днях.
Взято из
Как получить содержимое поля[1,1] DBGrid?
Как получить содержимое поля[1,1] DBGrid?
DBGrid.SelectedRow.Fields[1].Value
Взято с сайта
