Как узнать номер BIOS для разных версий Windows?
Как узнать номер BIOS для разных версий Windows?
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;
Windows NT
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;
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;
нашел на
и
Автор ответа: МММ
Взято с Vingrad.ru
Как узнать номер недели данного дня в году?
Как узнать номер недели данного дня в году?
Вариант 1:
function WeekOfYear(ADate : TDateTime) : word;
var
day : word;
month : word;
year : word;
FirstOfYear : TDateTime;
begin
DecodeDate(ADate, year, month, day);
FirstOfYear := EncodeDate(year, 1, 1);
Result := Trunc(ADate - FirstOfYear) div 7 + 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(WeekOfYear(Date)));
end;
Вариант 2:
function WeekNum(const ADate: TDateTime): word;
var
Year: word;
Month: word;
Day: word;
begin
DecodeDate(ADate + 4 - DayOfWeek(ADate + 6), Year, Month, Day);
result := 1 + trunc((ADate - EncodeDate(Year, 1, 5) +
DayOfWeek(EncodeDate(Year, 1, 3))) / 7);
end;
Вариант 3:
function WeekOfYear(Dat: TDateTime): Word;
// Интерпретация номеров дней:
// ISO: 1 = Понедельник, 7 = Воскресенье
// Delphi SysUtils: 1 = Воскресенье, 7 = Суббота
var
Day,
Month,
Year: Word;
FirstDate: TDateTime;
DateDiff : Integer;
begin
day := SysUtils.DayOfWeek(Dat)-1;
Dat := Dat + 3 - ((6 + day) mod 7);
DecodeDate(Dat, Year, Month, Day);
FirstDate := EncodeDate(Year, 1, 1);
DateDiff := Trunc(Dat - FirstDate);
Result := 1 + (DateDiff div 7);
end;
Взято с Исходников.ru
Как узнать о нажатии non-menu клавиши в момент когда меню показано?
Как узнать о нажатии non-menu клавиши в момент когда меню показано?
Автор: Arx ( http://arxoft.tora.ru )
Создайте обработчик сообщения WM_MENUCHAR.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
One1: TMenuItem;
Two1: TMenuItem;
THree1: TMenuItem;
private
{Private declarations}
procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WmMenuChar(var m : TMessage);
begin
Form1.Caption := 'Non standard menu key pressed';
m.Result := 1;
end;
end.
Взято с Исходников.ru
Как узнать откуда была установленна Windows?
Как узнать откуда была установленна Windows?
usesRegistry;
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false);
ShowMessage(reg.ReadString('SourcePath'));
reg.CloseKey;
reg.free;
end;
Взято из
DELPHI VCL FAQ
Перевод с английского Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для
Как узнать перечень таблиц базы и количество записей в них?
Как узнать перечень таблиц базы и количество записей в них?
procedureTForm1.Button1Click(Sender: TObject);
var
SL: TStrings;
index: Integer;
begin
SL := TStringList.Create;
try
ADOConnection1.GetTableNames(SL, False);
for index := 0 to (SL.Count - 1) do begin
Table1.Insert;
Table1.FieldByName('Name').AsString := SL[index];
ADOTable1.TableName := SL[index];
ADOTable1.Open;
Table1.FieldByName('Records').AsInteger :=
ADOTable1.RecordCount;
Table1.Post;
end;
finally
SL.Free;
ADOTable1.Close;
end;
end;
Взято с
Комментарий Vit: открытие больших таблиц, особенно на удалённых серверах баз данных может быть исключительно длительным процессом. ADO оптимизированно для работы через запросы, поэтому количество записей можно значительно быстрее узнать составляя query и выполняя её:
procedure TForm1.Button1Click(Sender: TObject);
var
SL: TStrings;
index: Integer;
begin
SL := TStringList.Create;
try
ADOConnection1.GetTableNames(SL, False);
for index := 0 to (SL.Count - 1) do begin
Table1.Insert;
Table1.FieldByName('Name').AsString := SL[index];
ADOQuery1.sql.text := 'Select Count(*) From '+SL[index];
ADOQuery1.Open;
Table1.FieldByName('Records').AsInteger :=ADOQuery1.fields[0].AsInteger;
Table1.Post;
ADOQuery1.Close;
end;
finally
SL.Free;
end;
end;
Как узнать, по какой колонке был клик в TListView?
Как узнать, по какой колонке был клик в TListView?
Метод GetItemAt позволяет получить координаты ListItem, по которой был клик, но только для первой колонки TListView. Если нужно узнать по какому элементу из другой колонки кликнул пользователь, то прийдётся объявить новый метод в наследованном классе:
uses ComCtrls;
type
TListViewX = class(TListView)
public
function GetItemAtX(X, Y: integer; var Col: integer): TListItem;
end;
implementation
function TListViewX.GetItemAtX(X, Y: integer;
var Col: integer): TListItem;
var
i, n, RelativeX, ColStartX: Integer;
ListItem: TlistItem;
begin
Result := GetItemAt(X, Y);
if Result <> nil then begin
Col := 0; // Первая колонка
end else if (ViewStyle = vsReport)
and (TopItem <> nil) then begin
// Первая, попробуем найти строку
ListItem := GetItemAt(TopItem.Position.X, Y);
if ListItem <> nil then begin
// Теперь попробуем найти колонку
RelativeX := X-ListItem.Position.X-BorderWidth;
ColStartX := Columns[0].Width;
n := Columns.Count - 1;
for i := 1 to n do begin
if RelativeX < ColStartX then break;
if RelativeX <= ColStartX +
StringWidth(ListItem.SubItems[i-1]) then
begin
Result := ListItem;
Col := i;
break;
end;//if
Inc(ColStartX, Columns[i].Width);
end;//for
end;//if
end;//if
end;
А вот так выглядит событие MouseDown:
procedure TForm1.ListView1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
col: integer;
li: TListItem;
begin
li := TListViewX(ListView1).GetItemAtX(x, y, col);
if li <> nil then
ShowMessage('Column #' + IntToStr(col));
end;
Взято с Исходников.ru
Как узнать, подключён ли компьютер к сети?
Как узнать, подключён ли компьютер к сети?
procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) and $01 = $01 then
ShowMessage('Computer is attached to a network!')
else
ShowMessage('Computer is not attached to a network!');
end;
Взято с Исходников.ru
Как узнать, присутствует ли мышка?
Как узнать, присутствует ли мышка?
function MousePresent : Boolean;
begin
if GetSystemMetrics(SM_MOUSEPRESENT) <> 0 then
Result := true
else
Result := false;
end;
Взято с Исходников.ru
Как узнать путь базы данных и её имя?
Как узнать путь базы данных и её имя?
Делается это при помощи dbiGetDatabaseDesc:
uses BDE;
.....
procedure ShowDatabaseDesc(DBName: string);
const
DescStr = 'Driver Name: %s'#13#10'AliasName: %s'#13#10 +
'Text: %s'#13#10'Physical Name/Path: %s';
var
dbDes: DBDesc;
begin
dbiGetDatabaseDesc(PChar(DBName), @dbDes);
with dbDes do
ShowMessage(Format(DescStr, [szDbType, szName, szText, szPhyName]));
end;
Взято с Исходников.ru
Как узнать путь к браузеру по умолчанию?
Как узнать путь к браузеру по умолчанию?
uses
Registry;
{....}
procedure TForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry;
KeyName: string;
ValueStr: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
KeyName := 'htmlfile\shell\open\command';
if Reg.OpenKey(KeyName, False) then
begin
ValueStr := Reg.ReadString('');
Reg.CloseKey;
Label1.Caption := ValueStr;
end
else
ShowMessage('No Default Webbrowser !');
finally
Reg.Free;
end;
end;
Взято с сайта
Как узнать размер картинки для JPG, GIF и PNG файлов?
Как узнать размер картинки для JPG, GIF и PNG файлов?
unit ImgSize;
interface
uses Classes;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word);
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word);
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word);
implementation
uses SysUtils;
function ReadMWord(f: TFileStream): Word;
type
TMotorolaWord = record
case Byte of
0: (Value: Word);
1: (Byte1, Byte2: Byte);
end;
var
MW: TMotorolaWord;
begin
{ It would probably be better to just read these two bytes in normally }
{ and then do a small ASM routine to swap them. But we aren't talking }
{ about reading entire files, so I doubt the performance gain would be }
{ worth the trouble. }
f.read(MW.Byte2, SizeOf(Byte));
f.read(MW.Byte1, SizeOf(Byte));
Result := MW.Value;
end;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word);
const
ValidSig: array[0..1] of Byte = ($FF, $D8);
Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
Sig: array[0..1] of byte;
f: TFileStream;
x: integer;
Seg: byte;
Dummy: array[0..15] of byte;
Len: word;
ReadLen: LongInt;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
ReadLen := f.read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then ReadLen := 0;
if ReadLen > 0 then
begin
ReadLen := f.read(Seg, 1);
while (Seg = $FF) and (ReadLen > 0) do
begin
ReadLen := f.read(Seg, 1);
if Seg <> $FF then
begin
if (Seg = $C0) or (Seg = $C1) then
begin
ReadLen := f.read(Dummy[0], 3); { don't need these bytes }
wHeight := ReadMWord(f);
wWidth := ReadMWord(f);
end
else
begin
if not (Seg in Parameterless) then
begin
Len := ReadMWord(f);
f.Seek(Len - 2, 1);
f.read(Seg, 1);
end
else
Seg := $FF; { Fake it to keep looping. }
end;
end;
end;
end;
finally
f.Free;
end;
end;
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word);
type
TPNGSig = array[0..7] of Byte;
const
ValidSig: TPNGSig = (137,80,78,71,13,10,26,10);
var
Sig: TPNGSig;
f: tFileStream;
x: integer;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
f.read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then Exit;
f.Seek(18, 0);
wWidth := ReadMWord(f);
f.Seek(22, 0);
wHeight := ReadMWord(f);
finally
f.Free;
end;
end;
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word);
type
TGIFHeader = record
Sig: array[0..5] of char;
ScreenWidth, ScreenHeight: Word;
Flags, Background, Aspect: Byte;
end;
TGIFImageBlock = record
Left, Top, Width, Height: Word;
Flags: Byte;
end;
var
f: file;
Header: TGifHeader;
ImageBlock: TGifImageBlock;
nResult: integer;
x: integer;
c: char;
DimensionsFound: boolean;
begin
wWidth := 0;
wHeight := 0;
if sGifFile = '' then
Exit;
{$I-}
FileMode := 0; { read-only }
AssignFile(f, sGifFile);
reset(f, 1);
if IOResult <> 0 then
{ Could not open file }
Exit;
{ Read header and ensure valid file. }
BlockRead(f, Header, SizeOf(TGifHeader), nResult);
if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0) or
(StrLComp('GIF', Header.Sig, 3) <> 0) then
begin
{ Image file invalid }
Close(f);
Exit;
end;
{ Skip color map, if there is one }
if (Header.Flags and $80) > 0 then
begin
x := 3 * (1 shl ((Header.Flags and 7) + 1));
Seek(f, x);
if IOResult <> 0 then
begin
{ Color map thrashed }
Close(f);
Exit;
end;
end;
DimensionsFound := False;
FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
{ Step through blocks. }
BlockRead(f, c, 1, nResult);
while (not EOF(f)) and (not DimensionsFound) do
begin
case c of
',': { Found image }
begin
BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
if nResult <> SizeOf(TGIFImageBlock) then
begin
{ Invalid image block encountered }
Close(f);
Exit;
end;
wWidth := ImageBlock.Width;
wHeight := ImageBlock.Height;
DimensionsFound := True;
end;
'y': { Skip }
begin
{ NOP }
end;
{ nothing else. just ignore }
end;
BlockRead(f, c, 1, nResult);
end;
Close(f);
{$I+}
end;
end.
Взято с сайта
Как узнать размеры шрифтов в Windows?
Как узнать размеры шрифтов в Windows?
GetTextMetrics()
Автор Song
Взято с Vingrad.ru
Как определить, какой шрифт установлен в системе, большой или маленький
Следующуя функция возвращает true, если маленькие шрифты установлены в системе. Так же можно заменить строку 'Result := (GetDeviceCaps(DC, logpixelsx) = 96);' на 'Result := (GetDeviceCaps(DC, logpixelsx) = 120);' чтобы определять - установлены ли в системе крупные шрифты.
Function UsesSmallFonts: boolean;
var
DC: HDC;
begin
DC := GetDC(0);
Result := (GetDeviceCaps(DC, logpixelsx) = 96);
ReleaseDC(0, DC);
end;
Взято с Исходников.ru
Как узнать разрешение экрана?
Как узнать разрешение экрана?
GetSystemMetrics
Автор AntonSaburov
Взято с Vingrad.ru
TScreen.WIdth/Height
Автор Song
Взято с Vingrad.ru
Как узнать серийный номер аудио CD?
Как узнать серийный номер аудио CD?
CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.
Пример:
usesMMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
var
mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then
begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end
else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;
end.
Взято из
DELPHI VCL FAQ
Перевод с английского Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для
Как узнать состояние клавиши CAPS LOCK?
Как узнать состояние клавиши CAPS LOCK?
function IsCapsLockOn : Boolean;
begin
Result := 0 <> (GetKeyState(VK_CAPITAL) and $01);
end;
Взято с Исходников.ru
Как узнать состояние модема в Win32?
Как узнать состояние модема в Win32?
Следующий пример демонстрирует получение состояния управляющих регистров модема.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
ModemStat : DWord;
begin
CommPort := 'COM2';
{Открываем com-порт}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_READ,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
{Получаем состояние модема}
if GetCommModemStatus(hCommFile, ModemStat) <> false then begin
if ModemStat and MS_CTS_ON <> 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_ON <> 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON <> 0then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON <> 0 then
ShowMessage('The RLSD (receive-line-signal-detect) is
on.');
end;
{Закрываем com-порт}
CloseHandle(hCommFile);
end;
Взято с Исходников.ru
Как узнать состояние памяти?
Как узнать состояние памяти?
var
Status : TMemoryStatus;
begin
Status.dwLength := sizeof( TMemoryStatus );
GlobalMemoryStatus( Status );
...
После этого TMemoryStatus будет содержать следующие паоля:
Status.dwMemoryLoad: Количество используемой памяти в процентах (%).
Status.dwTotalPhys: Общее количество физической памяти в байтах.
Status.dwAvailPhys: Количество оставшейся физической памяти в байтах.
Status.dwTotalPageFile: Объём страничного файла в байтах.
Status.dwAvailPageFile: Свободного места в страничном файле.
Status.dwTotalVirtual: Общий объём виртуальной памяти в байтах.
Status.dwAvailVirtual: Количество свободной виртуальной памяти в байтах.
Предваритель, желательно преобразовать эти значения в гига-, мега- или килобайты, например так:
label14.Caption := 'Total Ram: ' + IntToStr(Status.dwTotalPhys div 1024417) + 'meg';
Взято с Исходников.ru
Как узнать существует ли страница (worksheet)?
Как узнать существует ли страница (worksheet)?
{... }
WB := Excel.Workbooks[1];
for Idx := 1 to WB.Worksheets.Count do
if WB.Worksheets[Idx].Name = 'first' then
Showmessage('Found the worksheet');
{ ... }
Взято с
Delphi Knowledge BaseКак узнать тип соединения с интернетом?
Как узнать тип соединения с интернетом?
uses
WinInet;
const
MODEM = 1;
LAN = 2;
PROXY = 4;
BUSY = 8;
function GetConnectionKind(var strKind: string): Boolean;
var
flags: DWORD;
begin
strKind := '';
Result := InternetGetConnectedState(@flags, 0);
if Result then
begin
if (flags and MODEM) = MODEM then strKind := 'Modem';
if (flags and LAN) = LAN then strKind := 'LAN';
if (flags and PROXY) = PROXY then strKind := 'Proxy';
if (flags and BUSY) = BUSY then strKind := 'Modem Busy';
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
strKind: string;
begin
if GetConnectionKind(strKind) then
ShowMessage(strKind);
end;
Взято с сайта
Как узнать установлен ли activeX на машине?
Как узнать установлен ли activeX на машине?
{... }
var
strOLE: string;
begin
strOLE = "YourCOMServer.Application" {your ProgID}
if (CLSIDFromProgID(PWideChar(WideString(strOLE), ClassID) = S_OK) then
begin
{ ... }
end;
end;
{ ... }
const
cKEY = '\SOFTWARE\Classes\CLSID\%s\InprocServer32'
var
sKey: string;
sComServer: string;
exists: boolean;
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
sKey := format(cKEY, [GuidToString(ClassID)]);
if Reg.OpenKey(sKey, False) then
begin
sComServer := Reg.ReadString('');
if FileExists(sComServer) then
begin
{ ... }
end;
end;
finally
Reg.free;
end;
end;
Взято с
Delphi Knowledge BaseКак узнать версию ADO?
Как узнать версию ADO?
{
With different versions of MDAC available it is sometimes
useful to know that your application won't fail because a user
hasn't got the latest version installed.
The following function returns the ADO version installed,
you need to place ComObj in the uses clause to use this function.
}
function GetADOVersion: Double;
var
ADO: OLEVariant;
begin
try
ADO := CreateOLEObject('adodb.connection');
Result := StrToFloat(ADO.Version);
ADO := Null;
except
Result := 0.0;
end;
end;
// To use this function try something like:
procedure TForm1.Button1Click(Sender: TObject);
const
ADOVersionNeeded = 2.5;
begin
if GetADOVersion then
ShowMessage('Need to install MDAC version 2.7')
else
ShowMessage(Format('ADO Version %n, is OK', [GetADOVersion]));
end;
Взято с сайта
function TfrmMain.GetADOVersion: Double;
var
ADO: OLEVariant;
begin
try
ADO := CreateOLEObject('adodb.connection');
Result := StrToFloat(ADO.Version);
ADO := Null;
except
Result := 0.0;
end;
end;
Взято из
Как узнать версию BDE?
Как узнать версию BDE?
uses
BDE;
{Without the Registry:}
procedure TForm1.Button1Click(Sender: TObject);
var
ThisVersion: SYSVersion;
begin
DbiGetSysVersion(ThisVersion);
ShowMessage('BORLAND DATABASE ENGINE VERSION = ' + IntToStr(ThisVersion.iVersion));
end;
{With the Registry:}
function GetBDEVersion: string;
var
h: hwnd;
ptr: Pointer;
proc: TSYSVerProc;
ver: SYSVersion;
idapi: string;
reg: TRegistry;
begin
try
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('CLSID\{FB99D710-18B9-11D0-A4CF-00A024C91936}\InProcServer32', False);
idapi := reg.ReadString('');
reg.CloseKey;
finally
reg.Free;
end;
Result := '<BDE Bulunamadi>';
h := LoadLibrary(PChar(idapi));
if h <> 0 then
try
ptr := GetProcAddress(h, 'DbiGetSysVersion');
if ptr <> nil then
begin
proc := ptr;
Proc(Ver);
Result := IntToStr(ver.iVersion);
Insert('.', Result, 2);
end;
finally
FreeLibrary(h);
end;
end;
Взято с сайта
Как узнать версию Internet Explorer?
Как узнать версию Internet Explorer?
uses
Registry;
function GetIEVersion(Key: string): string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKey('Software\Microsoft\Internet Explorer', False);
try
Result := Reg.ReadString(Key);
except
Result := '';
end;
Reg.CloseKey;
finally
Reg.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('IE-Version: ' + GetIEVersion('Version')[1] + '.' + GetIEVersion('Version')[3]);
ShowMessage('IE-Version: ' + GetIEVersion('Version'));
// <major version>.<minor version>.<build number>.<sub-build number>
end;
Взято с сайта
Как узнать версию компилятора?
Как узнать версию компилятора?
Иногда надо выполнить разный код в зависимости от версии Дельфи, особенно актуально это при разработки компонентов и модулей, которые используются в разных приложениях.
В Дельфи предопределены специальные константы компиляции для этого:
Ver80 - Дельфи 1
Ver90 - Дельфи 2
Ver93 - С Buider 1
Ver100 - Дельфи 3
Ver110 - С Buider 3
Ver120 - Дельфи 4
Ver125 - С Buider 4
Ver130 - Дельфи 5
Ver140 - Дельфи 6
Ver150 - Дельфи 7
Пример использования:
procedure TForm1.Button2Click(Sender: TObject);
const Version=
{$Ifdef Ver80}'Дельфи 1';{$EndIf}
{$Ifdef Ver90}'Дельфи 2';{$EndIf}
{$Ifdef Ver100}'Дельфи 3';{$EndIf}
{$Ifdef Ver120}'Дельфи 4';{$EndIf}
{$Ifdef Ver130}'Дельфи 5 ';{$EndIf}
{$Ifdef Ver140}'Дельфи 6';{$EndIf}
{$Ifdef Ver150}'Дельфи 7';{$EndIf}
begin
ShowMessage('Для компиляции этой программы был использован '+Version);
end;
Автор Vit
Взято с Vingrad.ru
Как узнать версию MS Word?
Как узнать версию MS Word?
{... }
MsWord := CreateOleObject('Word.Basic');
try
{Return Application Info. This call is the same for English and
French Microsoft Word.}
Lang := MsWord.AppInfo(Integer(16));
except
try
{For German Microsoft Word the procedure name is translated}
Lang := MsWord.AnwInfo(Integer(16));
except
try
{For Swedish Microsoft Word the procedure name is translated}
Lang := MsWord.PrgmInfo(Integer(16));
except
try
{For Dutch Microsoft Word the procedure name is translated}
Lang := MsWord.ToepasInfo(Integer(16));
except
{If this procedure does not exist there is a different translation
of Microsoft Word}
ShowMessage('Microsoft Word version is not German, French, Dutch, Swedish
or English.');
Exit;
end;
end;
end;
end;
ShowMessage(Lang);
{ ... }
Взято с
Delphi Knowledge BaseКак узнать версию программы?
Как узнать версию программы?
function FileVersion(AFileName:string): string;
var
szName: array[0..255] of Char;
P: Pointer;
Value: Pointer;
Len: UINT;
GetTranslationString:string;
FFileName: PChar;
FValid:boolean;
FSize: DWORD;
FHandle: DWORD;
FBuffer: PChar;
begin
try
FFileName := StrPCopy(StrAlloc(Length(AFileName) + 1), AFileName);
FValid := False;
FSize := GetFileVersionInfoSize(FFileName, FHandle);
if FSize > 0 then
try
GetMem(FBuffer, FSize);
FValid := GetFileVersionInfo(FFileName, FHandle, FSize, FBuffer);
except
FValid := False;
raise;
end;
Result := '';
if FValid then
VerQueryValue(FBuffer, '\VarFileInfo\Translation', p, Len)
else p := nil;
if P <> nil then
GetTranslationString := IntToHex(MakeLong(HiWord(Longint(P^)), LoWord(Longint(P^))), 8);
if FValid then
begin
StrPCopy(szName, '\StringFileInfo\' + GetTranslationString + '\FileVersion');
if VerQueryValue(FBuffer, szName, Value, Len) then
Result := StrPas(PChar(Value));
end;
finally
try
if FBuffer <> nil then FreeMem(FBuffer, FSize);
except
end;
try
StrDispose(FFileName);
except
end;
end;
end;
В качестве параметра задать имя программы, если своей программы:
FileVersion(Paramstr(0));
Автор ответа Vit
Взято с Vingrad.ru
Как узнать версию сервера?
Как узнать версию сервера?
This function gets the connected MS SQL Server version. It returns the version info in 3 OUT parameters.
VerNum : double eg. 7.00623
VerStrShort : string eg. '7.00.623'
VerStrLong : string eg. 'Microsoft SQL Server 7.00 - 7.00.623 (Intel X86) Nov 27 1998 22:20:07 Copyright (c) 1988-1998 Microsoft Corporation Enterprise Edition on Windows NT 5.0 (Build 2195: Service Pack 1)'
I have tested it with MSSQL 7 and MSSQL 2000. I assume it should work for the others. Any feedback and fixes for different versions would be appreciated.
The TQuery parameter that it recieves is a TQuery component that is connected to an open database connection.
procedure GetSqlVersion(Query: TQuery;
out VerNum: double;
out VerStrShort: string;
out VerStrLong: string);
var
sTmp, sValue: string;
i: integer;
begin
// @@Version does not return a Cursor.
// Read the value from the Record Buffer
// Can be used to read all sys functions from MS Sql
sValue := '';
Query.SQL.Text := 'select @@Version';
Query.Open;
SetLength(sValue, Query.RecordSize + 1);
Query.GetCurrentRecord(PChar(sValue));
SetLength(sValue, StrLen(PChar(sValue)));
Query.Close;
if sValue <> '' then
VerStrLong := sValue
else
begin
// Don't know this version
VerStrLong := '?';
VerNum := 0.0;
VerStrShort := '?.?.?.?';
end;
if VerStrLong <> '' then
begin
sTmp := trim(copy(VerStrLong, pos('-', VerStrLong) + 1, 1024));
VerStrShort := copy(sTmp, 1, pos(' ', sTmp) - 1);
sTmp := copy(VerStrShort, 1, pos('.', VerStrShort));
for i := length(sTmp) + 1 to length(VerStrShort) do
begin
if VerStrShort[i] <> '.' then
sTmp := sTmp + VerStrShort[i];
end;
VerNum := StrToFloat(sTmp);
end;
end;
Взято с
Delphi Knowledge BaseКак узнать загрузку процессора? (NT/2000/XP)
Как узнать загрузку процессора? (NT/2000/XP)
const
SystemBasicInformation = 0;
SystemPerformanceInformation = 2;
SystemTimeInformation = 3;
type
TPDWord = ^DWORD;
TSystem_Basic_Information = packed record
dwUnknown1: DWORD;
uKeMaximumIncrement: ULONG;
uPageSize: ULONG;
uMmNumberOfPhysicalPages: ULONG;
uMmLowestPhysicalPage: ULONG;
uMmHighestPhysicalPage: ULONG;
uAllocationGranularity: ULONG;
pLowestUserAddress: Pointer;
pMmHighestUserAddress: Pointer;
uKeActiveProcessors: ULONG;
bKeNumberProcessors: byte;
bUnknown2: byte;
wUnknown3: word;
end;
type
TSystem_Performance_Information = packed record
liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}
dwSpare: array[0..75] of DWORD;
end;
type
TSystem_Time_Information = packed record
liKeBootTime: LARGE_INTEGER;
liKeSystemTime: LARGE_INTEGER;
liExpTimeZoneBias: LARGE_INTEGER;
uCurrentTimeZoneId: ULONG;
dwReserved: DWORD;
end;
var
NtQuerySystemInformation: function(infoClass: DWORD;
buffer: Pointer;
bufSize: DWORD;
returnSize: TPDword): DWORD; stdcall = nil;
liOldIdleTime: LARGE_INTEGER = ();
liOldSystemTime: LARGE_INTEGER = ();
function Li2Double(x: LARGE_INTEGER): Double;
begin
Result := x.HighPart * 4.294967296E9 + x.LowPart
end;
procedure GetCPUUsage;
var
SysBaseInfo: TSystem_Basic_Information;
SysPerfInfo: TSystem_Performance_Information;
SysTimeInfo: TSystem_Time_Information;
status: Longint; {long}
dbSystemTime: Double;
dbIdleTime: Double;
bLoopAborted : boolean;
begin
if @NtQuerySystemInformation = nil then
NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'),
'NtQuerySystemInformation');
// get number of processors in the system
status := NtQuerySystemInformation(SystemBasicInformation, @SysBaseInfo, SizeOf(SysBaseInfo), nil);
if status <> 0 then Exit;
// Show some information
with SysBaseInfo do
begin
ShowMessage(
Format('uKeMaximumIncrement: %d'#13'uPageSize: %d'#13+
'uMmNumberOfPhysicalPages: %d'+#13+'uMmLowestPhysicalPage: %d'+#13+
'uMmHighestPhysicalPage: %d'+#13+'uAllocationGranularity: %d'#13+
'uKeActiveProcessors: %d'#13'bKeNumberProcessors: %d',
[uKeMaximumIncrement, uPageSize, uMmNumberOfPhysicalPages,
uMmLowestPhysicalPage, uMmHighestPhysicalPage, uAllocationGranularity,
uKeActiveProcessors, bKeNumberProcessors]));
end;
bLoopAborted := False;
while not bLoopAborted do
begin
// get new system time
status := NtQuerySystemInformation(SystemTimeInformation, @SysTimeInfo, SizeOf(SysTimeInfo), 0);
if status <> 0 then Exit;
// get new CPU's idle time
status := NtQuerySystemInformation(SystemPerformanceInformation, @SysPerfInfo, SizeOf(SysPerfInfo), nil);
if status <> 0 then Exit;
// if it's a first call - skip it
if (liOldIdleTime.QuadPart <> 0) then
begin
// CurrentValue = NewValue - OldValue
dbIdleTime := Li2Double(SysPerfInfo.liIdleTime) - Li2Double(liOldIdleTime);
dbSystemTime := Li2Double(SysTimeInfo.liKeSystemTime) - Li2Double(liOldSystemTime);
// CurrentCpuIdle = IdleTime / SystemTime
dbIdleTime := dbIdleTime / dbSystemTime;
// CurrentCpuUsage% = 100 - (CurrentCpuIdle * 100) / NumberOfProcessors
dbIdleTime := 100.0 - dbIdleTime * 100.0 / SysBaseInfo.bKeNumberProcessors + 0.5;
// Show Percentage
Form1.Label1.Caption := FormatFloat('CPU Usage: 0.0 %',dbIdleTime);
Application.ProcessMessages;
// Abort if user pressed ESC or Application is terminated
bLoopAborted := (GetKeyState(VK_ESCAPE) and 128 = 128) or Application.Terminated;
end;
// store new CPU's idle and system time
liOldIdleTime := SysPerfInfo.liIdleTime;
liOldSystemTime := SysTimeInfo.liKeSystemTime;
// wait one second
Sleep(1000);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetCPUUsage
end;
Взято с сайта
Как узнать значения, которые пользователь вводит в TDBGrid?
Как узнать значения, которые пользователь вводит в TDBGrid?
procedure TForm1.DBGrid1KeyUp(Sender: TObject;
var Key: Word; Shift: TShiftState);
var
B: byte;
begin
for B := 0 to DBGrid1.ControlCount - 1 do
if DBGrid1.Controls[B] is TInPlaceEdit then
begin
with DBGrid1.Controls[B] as TInPlaceEdit do
begin
Label1.Caption := 'Text = ' + Text;
end;
end;
end;
Взято с Исходников.ru
Как в консольном приложении можно задать цвет текста?
Как в консольном приложении можно задать цвет текста?
Цвет Текста задается командой SetTextColor(Color), параметр Color - целое число от 0 до 15.
Вывод текста в указанном месте экрана задается командой GotoXY(X,Y,Text).
X,Y-координаты экрана.
Text - переменная типа String.
Ответ 3:
Вот текст модуля, напоминающего про наш любимый ДОС (CRT-like):
unit UffCRT;
// written by Michael Uskoff, Apr 2001, St.Petersburg, RUSSIA
interface
procedure ClrScr;
procedure SetAttr(attr: word);
function GetAttr: word;
procedure GotoXY(aX, aY: integer); // zero-based coords
function WhereX: integer;
function WhereY: integer;
implementation
uses Windows;
var
UpperLeft: TCoord = (X: 0; Y: 0);
hCon: integer;
procedure GotoXY(aX, aY: integer);
var aCoord: TCoord;
begin
aCoord.x := aX;
aCoord.y := aY;
SetConsoleCursorPosition(hCon, aCoord);
end;
procedure SetAttr(attr: word);
begin
SetConsoleTextAttribute(hCon, attr);
end;
function WhereX: integer;
var ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
Result := ScrBufInfo.dwCursorPosition.x;
end;
function WhereY: integer;
var ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
Result := ScrBufInfo.dwCursorPosition.y;
end;
function GetAttr: word;
var ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
Result := ScrBufInfo.wAttributes;
end;
procedure ClrScr;
var fill: integer;
ScrBufInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
fill := ScrBufInfo.dwSize.x * ScrBufInfo.dwSize.y;
FillConsoleOutputCharacter(hCon, ' ', fill, UpperLeft, fill);
FillConsoleOutputAttribute(hCon, ScrBufInfo.wAttributes, fill, UpperLeft, fill);
GotoXY(0, 0);
end;
initialization
hCon := GetStdHandle(STD_OUTPUT_HANDLE);
end.
Теперь можно творить такое:
uses UffCRT;
....
ClrScr;
SetAttr($1E);
GotoXY(32, 12);
Write('Hello, master !');
ReadLn;
...
Взято с сайта
Как в ListBox нарисовать Item своим цветом?
Как в ListBox нарисовать Item своим цветом?
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
With ListBox1 do
begin
If odSelected in State then
Canvas.Brush.Color:=clTeal { твой цвет }
else
Canvas.Brush.Color:=clWindow;
Canvas.FillRect(Rect);
Canvas.TextOut(Rect.Left+2,Rect.Top,Items[Index]);
end;
end;
Hе забудьте установить свойство Style у своего ListBox в lbOwnerDrawFixed или в
lbOwnerDrawVariable.
Взято с Исходников.ru
Как в run-time Action добавить в ActionList?
Как в run-time Action добавить в ActionList?
var
NewAction : TAction;
begin
NewAction := TAction.Create(self);
NewAction.ActionList := ActionList1;
end;
Автор ответа: Dayana
Взято с Vingrad.ru
Как в TBlobField запихать картинку из переменной типа TBitmap?
Как в TBlobField запихать картинку из переменной типа TBitmap?
1) LoadFromStream/SaveToStream
2) TBlobField.assign
Автор ответа Vit
Взято с Vingrad.ru
Как включить/отключить хранитель экрана?
Как включить/отключить хранитель экрана?
procedure TForm1.Button1Click(Sender: TObject);
begin
{Turn it off}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
0,
nil,
0);
{Turn it on}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
1,
nil,
0);
end;
Как включить/выключить спикер?
Как включить/выключить спикер?
Это выключит спикеp:
SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);
Это включит:
SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);
Alexey Lesovik
(2:5020/898.15)
Взято из
FAQ:Delphi and Windows API Tips'n'Tricks
olmal@mail.ru
http://www.chat.ru/~olmal
Как вместо печати графики использовать резидентный шрифт принтера?
Как вместо печати графики использовать резидентный шрифт принтера?
Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.
uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
tm: TTextMetric;
i: integer;
begin
if PrintDialog1.Execute then
begin
Printer.BeginDoc;
Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
GetTextMetrics(Printer.Canvas.Handle, tm);
for i := 1 to 10 do
begin
Printer.Canvas.TextOut(100, i * tm.tmHeight +
tm.tmExternalLeading, 'Test');
end;
Printer.EndDoc;
end;
end;
Как внести изменения в код VCL?
Как внести изменения в код VCL?
Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support.
-Но если Вы решили сделать это...
Изменения в код VCL никогда не должны вносится в секцию "interface" модуля - только в секцию "implimentation". Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "library path" можно изменить в меню:
Delphi 1 : Options | Environment | Library
Delphi 2 : Tools | Options | Library
Delphi 3 : Tools | Environment Options | Library
Delphi 4 : Tools | Environment Options | Library
C++ Builder : Options | Environment | Library
Как восстановить целостность автоинкрементного поля?
Как восстановить целостность автоинкрементного поля?
Problem/Question/Abstract:
Recently I got unique key violations during insert attempts on a piece of code that used to work (what can go bad, will go bad). I found that the offending field - was actually created by a generator. For some reason the generator returned values that where already in the database.
·how can I display the current value of the generator?
·how can I adjust the value of the generator?
Answer:
See the example (table name is SD_LOAD, generator name is GEN_SD_LOAD).
Note:
You cannot modify the value of the generator inside of a trigger or stored procedure. You only can call the gen_id() function to increment the value in a generator. The SET GENERATOR command will only work outside of a stored procedure or trigger.
SELECT DISTINCT(GEN_ID(gen_sd_load, 0))FROM sd_load
set GENERATOR gen_sd_load to 2021819
Взято с
Delphi Knowledge BaseКак восстановить индекс Paradox?
Как восстановить индекс Paradox?
BDE включает функцию для этого - DbiRegenIndexes.
Copyright © 1996 Epsylon Technologies
Взято из
FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349Как вращать текст
Как вращать текст
procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string);
var hFont, Fontold: integer;
DC: hdc;
Fontname: string;
begin
if length(txt)= 0 then
EXIT;
DC:= Screen.ActiveForm.Canvas.handle;
SetBkMode(DC, transparent);
Fontname:= Screen.ActiveForm.Canvas.Font.Name;
hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0,
0,1,4,$10,2,4,PChar(Fontname));
Fontold:= SelectObject(DC, hFont);
TextOut(DC,x,y,PChar(txt), length(txt));
SelectObject(DC, Fontold);
DeleteObject(hFont);
end;
Взято с Исходников.ru
Как вставить картинку
Как вставить картинку
Answer:
If WS is your worksheet:
{... }
WS.Shapes.AddPicture('C:\Pictures\Small.Bmp', EmptyParam, EmptyParam, 10, 160,
EmptyParam, EmptyParam);
or
{ ... }
var
Pics: Excel2000.Pictures; {or whichever Excel}
Pic: Excel2000.Picture;
Pic: Excel2000.Shape;
Left, Top: integer;
{ ... }
Pics := (WS.Pictures(EmptyParam, 0) as Pictures);
Pic := Pics.Insert('C:\Pictures\Small.Bmp', EmptyParam);
Pic.Top := WS.Range['D4', 'D4'].Top;
Pic.Left := WS.Range['D4', 'D4'].Left;
{ ... }
EmptyParam a special variant (declared in Variants.pas in D6+). However in later versions of Delphi some conversions cause problems. This should work:
uses
OfficeXP; { ... }
WS.Shapes.AddPicture('H:\Pictures\Game\Hills.bmp', msoFalse, msoTrue, 10, 160, 100,
100);
But you may have to use a TBitmap to find out how large the picture should be.
Взято с
Delphi Knowledge BaseКак вставить картинку в RichEdit?
Как вставить картинку в RichEdit?
В стандартном RichEdit нельзя, для RichEdit с картинками используйте RichEdit из RxLib или JVCL.
Автор ответа Vit
Взято с Vingrad.ru
Ниже представлен пример, который можно применить к RxRichEdit, RichEditEx, RichEdit98, и Microsoft RichTextBox (поставляемый с VB5+) не прибегая к использованию буфера обмена или OLE:
function BitmapToRTF(pict: TBitmap): string;
var
bi,bb,rtf: string;
bis,bbs: Cardinal;
achar: ShortString;
hexpict: string;
I: Integer;
begin
GetDIBSizes(pict.Handle,bis,bbs);
SetLength(bi,bis);
SetLength(bb,bbs);
GetDIB(pict.Handle,pict.Palette,PChar(bi)^,PChar(bb)^);
rtf := '{\rtf1 {\pict\dibitmap ';
SetLength(hexpict,(Length(bb) + Length(bi)) * 2);
I := 2;
for bis := 1 to Length(bi) do
begin
achar := Format('%x',[Integer(bi[bis])]);
if Length(achar) = 1 then
achar := '0' + achar;
hexpict[I-1] := achar[1];
hexpict[I] := achar[2];
Inc(I,2);
end;
for bbs := 1 to Length(bb) do
begin
achar := Format('%x',[Integer(bb[bbs])]);
if Length(achar) = 1 then
achar := '0' + achar;
hexpict[I-1] := achar[1];
hexpict[I] := achar[2];
Inc(I,2);
end;
rtf := rtf + hexpict + ' }}';
Result := rtf;
end;
А вот пример использования этой функции:
{SS это TStringStream, RE это TRxRichEdit, а BMP это TBitmap содержащий картинку.}
SS := TStringStream.Create(BitmapToRTF(BMP));
RE.PlainText := False;
RE.StreamMode := [smSelection];
RE.Lines.LoadFromStream(SS);
SS.Free;
Взято с Исходников.ru
Как вставить конец страницы?
Как вставить конец страницы?
{... }
Excel.ActiveWindow.View := xlPageBreakPreview;
WS.HPageBreaks.Add(WS.Cells.Item[78, 1]);
{ ... }
Взято с
Delphi Knowledge BaseКак вставить растровое изображение в компонент ListBox?
Как вставить растровое изображение в компонент ListBox?
Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.
Пример:
Рисуются изображения размером 32*16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!
Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.
{ Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}
procedure TForm1.bLoadClick(Sender: TObject);
VAR S : String;
begin
ListBox1.Clear; {чистим список}
S := '*.bmp'#0; {задаем шаблон}
ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список}
end;
............
{Отобразить изображения и имена файлов в ListBox}
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: DrawState);
var
Bitmap: TBitmap;
Offset: Integer;
BMPRect: TRect;
begin
with (Control as TListBox).Canvas do
begin
FillRect(Rect);
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile(ListBox1.Items[Index]);
Offset := 0;
if Bitmap <> nil then
begin
BMPRect := Bounds(Rect.Left + 2, Rect.Top + 2,
(Rect.Bottom - Rect.Top - 2) * 2, Rect.Bottom - Rect.Top - 2);
{StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон}
BrushCopy(BMPRect, Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
Offset := (Rect.Bottom - Rect.Top + 1) * 2;
end;
TextOut(Rect.Left + Offset, Rect.Top, ListBox1.Items[Index]);
Bitmap.Free;
end;
end;
Данный пример работает медленно, но оптимизация, для ускорения, вызвала бы трудность в понимании общего принципа его работы.
Взято с Исходников.ru
Как вставить содержимое файла в текущую позицию TMemo?
Как вставить содержимое файла в текущую позицию TMemo?
Для чтения файла будем использовать TMemoryStream, а затем используем метод SetSelTextBuf() из TMemo, чтобы вставить в него текст:
var
TheMStream : TMemoryStream;
Zero : char;
begin
TheMStream := TMemoryStream.Create;
TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
TheMStream.Seek(0, soFromEnd);
//Буфер завершается нулём!
Zero := #0;
TheMStream.Write(Zero, 1);
TheMStream.Seek(0, soFromBeginning);
Memo1.SetSelTextBuf(TheMStream.Memory);
TheMStream.Free;
end;
Взято с Исходников.ru
Как вставить свой курсор из внешнего файла?
Как вставить свой курсор из внешнего файла?
Используя процедуру LoadCursorFromFile
var
h: hcursor;
begin
h := LoadCursorFromFile('D:\mc.cur');
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
var h: THandle;
begin
h := LoadImage(0, 'c:\Cursor.cur', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
LR_LOADFROMFILE);
if h = 0 then
ShowMessage('Cursor not loaded!!!')
else
begin
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;
Этот пример позволяет также использовать анимированные курсоры (*.ani)!
Вот кусок кода для загрузки анимированного курсора, который можно вставить в обработку события активизации формы :
var
h: THandle;
name: array[0..255] of char;
begin
StrPCopy(name, 'Animcurs.ani');
h := LoadImage(0, name, IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
LR_LOADFROMFILE);
if h <> 0 then
begin
Screen.Cursors[1] := h;
Screen.Cursor := 1;
end
else
Screen.Cursor := crDefault;
end;
Взято с сайта
Как вставить свой пункт меню?
Как вставить свой пункт меню?
{... }
var
CBar: CommandBar;
MenuItem: OleVariant;
{ ... }
{ Add an item to the File menu }
CBar := Word.CommandBars['File'];
MenuItem := CBar.Controls.Add(msoControlButton, EmptyParam, EmptyParam,
EmptyParam, True) as CommandBarButton;
MenuItem.Caption := 'NewMenuItem';
MenuItem.DescriptionText := 'Does nothing';
{Note that a VB macro with the right name must exist before you assign it to the item!}
MenuItem.OnAction := 'VBMacroName';
{ ... }
Взято с
Delphi Knowledge BaseКак выбрать цвет пользуя TTrackBar
Как выбрать цвет пользуя TTrackBar
Drop three TrackBars on a form. Set Min to 0, Max to 255. Drop a TImage on the form. Then try this code:
{... }
var
Form1: TForm1;
MyColor: LongWord;
RedColor: LongWord = $00000000;
GreenColor: LongWord = $00000000;
BlueColor: LongWord = $00000000;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
DoImageFill;
end;
procedure TForm1.DoImageFill;
begin
MyColor := RedColor or GreenColor or BlueColor;
Image1.Canvas.Brush.Color := TColor(MyColor);
Image1.Canvas.FillRect(Rect(0, 0, Image1.Width, Image1.Height));
end;
procedure TForm1.RedBarChange(Sender: TObject);
begin
RedColor := RedBar.Position;
DoImageFill;
end;
procedure TForm1.GreenBarChange(Sender: TObject);
begin
GreenColor := GreenBar.Position shl 8;
DoImageFill;
end;
procedure TForm1.BlueBarChange(Sender: TObject);
begin
BlueColor := BlueBar.Position shl 16;
DoImageFill;
end;
end.
Each color value ranges from 0 to 255. Set the three trackbars with this range. You can use the RGB function to create a color from these values.
{ ... }
type
TForm1 = class(TForm)
redTrackBar: TTrackBar;
greenTrackBar: TTrackBar;
blueTrackBar: TTrackBar;
Panel1: TPanel;
procedure blueTrackBarChange(Sender: TObject);
procedure greenTrackBarChange(Sender: TObject);
procedure redTrackBarChange(Sender: TObject);
public
{ Public declarations }
procedure ChangeColor;
end;
procedure TForm1.ChangeColor;
begin
Panel1.Color := RGB(redTrackBar.Position, greenTrackBar.Position, blueTrackBar.Position);
end;
procedure TForm1.blueTrackBarChange(Sender: TObject);
begin
ChangeColor;
end;
procedure TForm1.greenTrackBarChange(Sender: TObject);
begin
ChangeColor;
end;
procedure TForm1.redTrackBarChange(Sender: TObject);
begin
ChangeColor;
end;
Взято с
Delphi Knowledge BaseКак выбрать случайную запись?
Как выбрать случайную запись?
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Table1.First;
Table1.MoveBy(Random(Table1.RecordCount));
end;
Взято с сайта
Как вычислить CRC-32 для файла?
Как вычислить CRC-32 для файла?
// The constants here are for the CRC-32 generator
// polynomial, as defined in the Microsoft
// Systems Journal, March 1995, pp. 107 - 108
const
Table: array[0..255] of DWORD =
($00000000, $77073096, $EE0E612C, $990951BA,
$076DC419, $706AF48F, $E963A535, $9E6495A3,
$0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
$09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
$1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
$1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
$14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
$3B6E20C8, $4C69105E, $D56041E4, $A2677172,
$3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
$32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
$26D930AC, $51DE003A, $C8D75180, $BFD06116,
$21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
$2802B89E, $5F058808, $C60CD9B2, $B10BE924,
$2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
$76DC4190, $01DB7106, $98D220BC, $EFD5102A,
$71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
$7807C9A2, $0F00F934, $9609A88E, $E10E9818,
$7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
$6B6B51F4, $1C6C6162, $856530D8, $F262004E,
$6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
$62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
$4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
$4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
$44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
$5005713C, $270241AA, $BE0B1010, $C90C2086,
$5768B525, $206F85B3, $B966D409, $CE61E49F,
$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
$59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
$EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
$EAD54739, $9DD277AF, $04DB2615, $73DC1683,
$E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
$E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
$F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
$F762575D, $806567CB, $196C3671, $6E6B06E7,
$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
$F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
$D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
$DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
$CB61B38C, $BC66831A, $256FD2A0, $5268E236,
$CC0C7795, $BB0B4703, $220216B9, $5505262F,
$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
$C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
$9B64C2B0, $EC63F226, $756AA39C, $026D930A,
$9C0906A9, $EB0E363F, $72076785, $05005713,
$95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
$92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
$81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
$88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
$8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
$A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
$A7672661, $D06016F7, $4969474D, $3E6E77DB,
$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
$A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
$BAD03605, $CDD70693, $54DE5729, $23D967BF,
$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
type
//----------------------------------crc32----------------------------------
{$IFDEF VER130} // This is a bit awkward
// 8-byte integer
TInteger8 = Int64; // Delphi 5
{$ELSE}
{$IFDEF VER120}
TInteger8 = Int64; // Delphi 4
{$ELSE}
TInteger8 = COMP; // Delphi 2 or 3
{$ENDIF}
{$ENDIF}
//----------------------------------crc32----------------------------------
// Use CalcCRC32 as a procedure so CRCValue can be passed in but
// also returned. This allows multiple calls to CalcCRC32 for
// the "same" CRC-32 calculation.
procedure CalcCRC32(p: Pointer; ByteCount: DWORD; var CRCValue: DWORD);
// The following is a little cryptic (but executes very quickly).
// The algorithm is as follows:
// 1. exclusive-or the input byte with the low-order byte of
// the CRC register to get an INDEX
// 2. shift the CRC register eight bits to the right
// 3. exclusive-or the CRC register with the contents of Table[INDEX]
// 4. repeat steps 1 through 3 for all bytes
var
i: DWORD;
q: ^BYTE;
begin
q := p;
for i := 0 to ByteCount - 1 do
begin
CRCvalue := (CRCvalue shr 8) xor
Table[q^ xor (CRCvalue and $000000FF)];
Inc(q)
end
end {CalcCRC32};
function CalcStringCRC32(s: string; out CRC32: DWORD): Boolean;
var
CRC32Table: DWORD;
begin
// Verify the table used to compute the CRCs has not been modified.
// Thanks to Gary Williams for this suggestion, Jan. 2003.
CRC32Table := $FFFFFFFF;
CalcCRC32(Addr(Table[0]), SizeOf(Table), CRC32Table);
CRC32Table := not CRC32Table;
if CRC32Table <> $6FCF9E13 then ShowMessage('CRC32 Table CRC32 is ' +
IntToHex(Crc32Table, 8) +
', expecting $6FCF9E13')
else
begin
CRC32 := $FFFFFFFF; // To match PKZIP
if Length(s) > 0 // Avoid access violation in D4
then CalcCRC32(Addr(s[1]), Length(s), CRC32);
CRC32 := not CRC32; // To match PKZIP
end;
end;
procedure CalcFileCRC32(FromName: string; var CRCvalue: DWORD;
var TotalBytes: TInteger8;
var error: Word);
var
Stream: TMemoryStream;
begin
error := 0;
CRCValue := $FFFFFFFF;
Stream := TMemoryStream.Create;
try
try
Stream.LoadFromFile(FromName);
if Stream.Size > 0 then CalcCRC32(Stream.Memory, Stream.Size, CRCvalue)
except
on E: EReadError do
error := 1
end;
CRCvalue := not CRCvalue
finally
Stream.Free
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
CRC32: DWORD;
begin
s := 'Test String';
if CalcStringCRC32(s, CRC32) then
ShowMessage(IntToStr(crc32));
end;
Взято с сайта
Как вычислить CRC (контрольную сумму) для файла?
Как вычислить CRC (контрольную сумму) для файла?
function GetCheckSum(FileName: string): DWORD;
var
F: file of DWORD;
P: Pointer;
Fsize: DWORD;
Buffer: array [0..500] of DWORD;
begin
FileMode := 0;
AssignFile(F, FileName);
Reset(F);
Seek(F, FileSize(F) div 2);
Fsize := FileSize(F) - 1 - FilePos(F);
if Fsize > 500 then Fsize := 500;
BlockRead(F, Buffer, Fsize);
Close(F);
P := @Buffer;
asm
xor eax, eax
xor ecx, ecx
mov edi , p
@again:
add eax, [edi + 4*ecx]
inc ecx
cmp ecx, fsize
jl @again
mov @result, eax
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetCheckSum('c:\Autoexec.bat')));
end;
Взято с сайта
Как вычислить IP адрес компьютера?
Как вычислить IP адрес компьютера?
Описывается функция, которая показывает, как вычислить IP адрес компьютера в интернете по его доменному имени.
Совместимость: Delphi 3.x (или выше)
Объявляем Winsock, для использования в функции
function HostToIP(Name: string; var Ip: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, Name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
if Assigned (hostEnt^.h_addr_list) then
begin
addr := hostEnt^.h_addr_list^;
if Assigned (addr) then
begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else
begin
Result := False;
end;
finally
WSACleanup;
end
end;
Вы можете разметстить на форме EditBox, Кнопку и Label и добавить к кнопке следующий обработчик события OnClick:
procedure TForm1.Button1Click(Sender: TObject);
var
IP: string;
begin
if HostToIp(Edit1.Text, IP) then Label1.Caption := IP;
end;
Автор ответа: neutrino
Взято с Vingrad.ru
А вот какой способ предложен для нахождения собственного IP рассылкой мастеров дельфи ():
var
WSAData: TWSAData;
SockAddrIn: TSockAddrIn;
Host: PHostEnt;
// Эти переменные объявлены в Winsock.pas
begin
if WSAStartup($101, WSAData) = 0 then begin
Host := GetHostByName(@Localname[1]);
if Host<>nil then begin
SockAddrIn.sin_addr.S_addr:= longint(plongint(Host^.h_addr_list^)^);
LocalIP := inet_ntoa(SockAddrIn.sin_addr);
end;
WSACleanUp;
end;
end;
Взято с Vingrad.ru
Как вычислить IP-адрес по доменному имени
Как вычислить IP-адрес по доменному имени
uses winsock
-------
function IPAddrToName(IPAddr : String): String;
var
SockAddrIn: TSockAddrIn;
HostEnt: PHostEnt;
WSAData: TWSAData;
begin
WSAStartup($101, WSAData);
SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
if HostEnt<>nil then
begin
result:=StrPas(Hostent^.h_name)
end
else
begin
result:='';
end;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption:=IPAddrToName(Edit1.Text);
end;
Взято с Исходников.ru
Как вычислить математическое выражение
Как вычислить математическое выражение
Зачастую пользователь должен ввести что-то типа "1+2/(3*4)" и программа должна разобрать выражение и произвести вычисления. Делается это с помощью рекурсивных функций, которые постеменно разбирают выражение. К счастью не обязательно изобретать велосипед: в бесплатной библиотеке RxLib есть модуль Parsing.pas включающий в себя класс для вычисления математических выражений, библиотеку можно взять на
или
Модуль Parsing.pas вполне может работать отдельно и без установки пакета компонент (но в таком случае вам прийдется взять еще несколько inc файлов помимо него).
Автор ответа: Vit
Взято с Vingrad.ru
