nyuuzyou/wikis huggingface dataset:
Как показать подсказки Hints для элементов меню

=== Как показать подсказки Hints для элементов меню ===
В примере создается обработчик события Application.Hint - подсказки меню изображаются на status Panel: 
type
 TForm1 = class(TForm)
 Panel1: TPanel;
 MainMenu1: TMainMenu;
 MenuItemFile: TMenuItem;
 MenuItemOpen: TMenuItem;
 MenuItemClose: TMenuItem;
 OpenDialog1: TOpenDialog;
 procedure FormCreate(Sender: TObject);
 procedure MenuItemCloseClick(Sender: TObject);
 procedure MenuItemOpenClick(Sender: TObject);
 private
 {Private declarations}
 procedure HintHandler(Sender: TObject);
 public
 {Public declarations}
end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
 Panel1.Align := alBottom;
 MenuItemFile.Hint := 'File Menu';
 MenuItemOpen.Hint := 'Opens A File';
 MenuItemClose.Hint := 'Closes the Application';
 Application.OnHint := HintHandler;
end;
procedure TForm1.HintHandler(Sender: TObject);
begin
 Panel1.Caption := Application.Hint;
end;
procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin
 Application.Terminate;
end;
procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin
 if OpenDialog1.Execute then
 Form1.Caption := OpenDialog1.FileName;
end; 
Source: http://delphiworld.narod.ru/
ID: 01293
Как показать содержимое 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-поля.
Source: Взято из http://forum.sources.ru
ID: 03016
----
В обработчик события GetText TMemoField поместите следующую строку:
Text := GrabMemoAsString(TMemoField(Sender));
и поместите следующую функцию так, чтобы к ней можно было свободно обратиться:
function GrabMemoAsString(TheField: TMemoField): string;
begin
 if TheField.IsNull then
 Result := ''
 else
 with TBlobStream.Create(TheField, bmRead) do
 begin
 if Size >= 255 then
 begin
 Read(Result[1], 255);
 Result[0] := #255;
 end
 else
 begin
 Read(Result[1], Size);
 Result[0] := Chr(Size);
 end;
 Free;
 while Pos(#10, Result) > 0 do
 Result[Pos(#10, Result)] := ' ';
 while Pos(#13, Result) > 0 do
 Result[Pos(#13, Result)] := ' ';
 end;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 03017
Category:Базы данных
Category:DBGrid
Как показать удалённые записи

=== Как показать удалённые записи ===
procedure DeletedRecords(Table: TTable; SioNo: Boolean);
begin
 Table.DisableControls;
 try
 Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON, LongInt(SioNo)));
 finally
 Table.EnableControls;
 end;
 Table.Refresh;
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02569
Как получить/изменить громкость?

=== Как получить/изменить громкость? ===
procedure GetVolume(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;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 02260
Как получить / установить приоритет процесса?

=== Как получить / установить приоритет процесса? ===
const
 ppIdle : Integer = -1;
 ppNormal : Integer = 0;
 ppHigh : Integer = 1;
 ppRealTime : Integer = 2;
function SetProcessPriority(Priority: Integer): Integer;
var
 H: THandle;
begin
 Result := ppNormal;
 H := GetCurrentProcess();
 if (Priority = ppIdle) then
 SetPriorityClass(H, IDLE_PRIORITY_CLASS)
 else if (Priority = ppNormal) then
 SetPriorityClass(H, NORMAL_PRIORITY_CLASS)
 else if (Priority = ppHigh) then
 SetPriorityClass(H, HIGH_PRIORITY_CLASS)
 else if (Priority = ppRealTime) then
 SetPriorityClass(H, REALTIME_PRIORITY_CLASS);
 case GetPriorityClass(H) of
 IDLE_PRIORITY_CLASS : Result := ppIdle;
 NORMAL_PRIORITY_CLASS : Result := ppNormal;
 HIGH_PRIORITY_CLASS : Result := ppHigh;
 REALTIME_PRIORITY_CLASS : Result := ppRealTime;
 End;
end;
function GetProcessPriority: Integer;
var
 H: THandle;
begin
 Result := ppNormal;
 H := GetCurrentProcess();
 case GetPriorityClass(H) of
 IDLE_PRIORITY_CLASS : Result := ppIdle;
 NORMAL_PRIORITY_CLASS : Result := ppNormal;
 HIGH_PRIORITY_CLASS : Result := ppHigh;
 REALTIME_PRIORITY_CLASS : Result := ppRealTime;
 end;
end;
Как использовать:
 function SetProcessPriority(Priority: Integer): Integer; 
для установки приоритета Вашего приложения, либо:
 function GetProcessPriority: Integer; 
для получения приоритета.
Source: Взято из http://forum.sources.ru
ID: 02042
----
Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью - т.к. присвоение слишком высокого приоритета может привести к медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function. 
procedure TForm1.Button1Click(Sender: TObject);
var
 ProcessID: DWORD;
 ProcessHandle: THandle;
 ThreadHandle: THandle;
begin
 ProcessID := GetCurrentProcessID;
 ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
 False,
 ProcessID);
 SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
 ThreadHandle := GetCurrentThread;
 SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;
ID: 02043
Как получить Handle рабочего стола

=== Как получить Handle рабочего стола ===
Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять хэндл этого органа управления. Пример: 
function GetDesktopListViewHandle: THandle;
var
 S: string;
begin
 Result := FindWindow('ProgMan', nil);
 Result := GetWindow(Result, GW_CHILD);
 Result := GetWindow(Result, GW_CHILD);
 SetLength(S, 40);
 GetClassName(Result, PChar(S), 39);
 if PChar(S) <> 'SysListView32' then
 Result := 0;
end;
После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32. 
К примеру, следующая строка кода: 
SendMessage(GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0);
разместит иконки рабочего стола по левой стороне рабочего стола Windows. 
Source: http://delphiworld.narod.ru/
ID: 01836
Как получить POST данные?

Перевод материала с сайта 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.}
Author: 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;
Author: Hans Gulo
Source: http://blackman.km.ru/myfaq/cont4.phtml
ID: 03449
----
в BeforeNavigate2, если посмотреть на PostData, увидим строку типа "????????", а как нормальную получить ?
function VariantArrayToStream(VarArray: OleVariant): TStream;
var
 pLocked: Pointer;
begin
 Result := TMemoryStream.Create;
 if VarIsEmpty(VarArray) or VarIsNull(VarArray) then Exit;
 Result.Size := VarArrayHighBound(VarArray, 1) - VarArrayLowBound(VarArray, 1) + 1;
 pLocked := VarArrayLock(VarArray);
 try
 Result.Write(pLocked^, Result.Size);
 finally
 VarArrayUnlock(VarArray);
 Result.Position := 0;
 end;
end;
procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
 const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
 Headers: OleVariant; var Cancel: WordBool);
var
 stream: TStream;
begin
 stream := VariantArrayToStream(PostData);
 try
 Memo1.Lines.LoadFromStream(stream);
 finally
 stream.Free;
 end;
end;
Author: Alex
Source: http://forum.sources.ru
ID: 03450
Category:Связь
Category:WebBrowser
Как получить RTF из Word без буффера обмена?

uses
 Word_TLB, ActiveX, ComObj;
function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
var
 Formats: IEnumFORMATETC;
 TempFormat: TFormatEtc;
 pFormatName: PChar;
 Found: Boolean;
begin
 try
 OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats));
 Found := False;
 while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
 begin
 pFormatName := AllocMem(255);
 GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
 if (string(pFormatName) = 'Rich Text Format') then
 begin
 RTFFormat := TempFormat;
 Found := True;
 end;
 FreeMem(pFormatName);
 end;
 Result := Found;
 except
 Result := False;
 end;
end;
function GetRTF: string;
var
 DataObject: IDataObject;
 RTFFormat: TFormatEtc;
 ReturnData: TStgMedium;
 Buffer: PChar;
 WordDoc: _Document;
 WordApp: _Application;
begin
 Result := ;
 try
 GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
 except
 ShowMessage('Error: MSWord is not running');
 Exit;
 end;
 if (WordApp <> nil) then
 try
 WordDoc := WordApp.ActiveDocument;
 WordDoc.QueryInterface(IDataObject, DataObject);
 if GetRTFFormat(DataObject, RTFFormat) then
 begin
 OleCheck(DataObject.GetData(RTFFormat, ReturnData));
 //RTF is passed through global memory
 Buffer := GlobalLock(ReturnData.hglobal);
 //Buffer is a pointer to the RTF text
 Result := StrPas(Buffer);
 GlobalUnlock(ReturnData.hglobal);
 ReleaseStgMedium(ReturnData);
 end;
 except
 // Error occured...
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 ss: TStringstream;
 rtfText: string;
begin
 rtfText := GetRTF;
 ss := TStringStream.Create(rtfText);
 try
 ss.Position := 0;
 Memo1.Text := rtfText;
 RichEdit1.Lines.LoadFromStream(ss);
 finally
 ss.Free
 end;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04435
Category:COM
Category:MS Office
Как получить RTF текст из TRichEdit

=== Как получить RTF текст из TRichEdit ===
function GetRTFText(ARichEdit: TRichedit): string;
var
 ss: TStringStream;
 emptystr: string;
begin
 emptystr := ;
 ss := TStringStream.Create(emptystr);
 try
 ARichEdit.PlainText := False;
 ARichEdit.Lines.SaveToStream(ss);
 Result := ss.DataString;
 finally
 ss.Free
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 Memo1.Text := GetRTFText(RichEdit1);
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01021
Как получить TextRange страницы без фреймов?

HTML_Doc := WebBrowser1.Document As IHTMLDocument2;
Window := HTML_Doc.parentWindow As IHTMLWindow2;
Body := HTML_Doc.get_body As IHTMLBodyElement;
Range := oBody.createTextRange;
Можно еще так:
var a: IHTMLTxtRange;
a := IHTMLDocument2(webbrowser1.Document).selection.createRange as IHTMLTxtRange;
Author: Good Man
Source: Vingrad.ru http://forum.vingrad.ru
ID: 03529
Category:Связь
Category:WebBrowser
Как получить UNC путь к файлу?

=== Как получить UNC путь к файлу? ===
function GetUNCName(PathStr: string): string;
var
 bufSize: DWord;
 buf: TUniversalNameInfo;
 msg: string;
begin
 bufSize := SizeOf(TUniversalNameInfo);
 if (WNetGetUniversalName(PChar(PathStr), UNIVERSAL_NAME_INFO_LEVEL,
 buf, bufSize) > 0) then
 case GetLastError of
 ERROR_BAD_DEVICE: msg := 'ERROR_BAD_DEVICE';
 ERROR_CONNECTION_UNAVAIL: msg := 'ERROR_CONNECTION_UNAVAIL';
 ERROR_EXTENDED_ERROR: msg := 'ERROR_EXTENDED_ERROR';
 ERROR_MORE_DATA: msg := 'ERROR_MORE_DATA';
 ERROR_NOT_SUPPORTED: msg := 'ERROR_NOT_SUPPORTED';
 ERROR_NO_NET_OR_BAD_PATH: msg := 'ERROR_NO_NET_OR_BAD_PATH';
 ERROR_NO_NETWORK: msg := 'ERROR_NO_NETWORK';
 ERROR_NOT_CONNECTED: msg := 'ERROR_NOT_CONNECTED';
 end
 else
 msg := buf.lpUniversalName;
 Result := msg;
end;
Работает только на NT/2000/XP
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 03160
Category:Файловая система
Как получить URL?

TWebBrowser.После нажатия кнопки на web форме формируется ссылка на какую-то страницу с параметрами, а с этой страницы уже происходит перенаправление на результирующую страницу. Хотелось бы увидеть ссылку на страницу вместе с параметрами.
function GetPostParam(const PostData: OleVariant): string;
var
 V: Variant;
 P: PChar;
 lb, hb, i: Integer;
begin
 V := Variant(TVarData(PostData).VPointer^);
 if VarIsArray(V) then
 begin
 P := VarArrayLock(V);
 try
 lb := VarArrayLowBound(V, 1);
 hb := VarArrayHighBound(V, 1);
 SetString(Result, P, hb - lb + 1);
 for i := 1 to Length(Result) do
 begin
 if Result[i] = #0 then
 begin
 SetLength(Result, i - 1);
 Break;
 end;
 end;
 Exit;
 finally
 VarArrayUnlock(V);
 end;
 end;
 Result:= ;
end;
Author: P.O.D.
Source: http://forum.sources.ru
ID: 03476
Category:Связь
Category:WebBrowser
Как получить 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);
ID: 03511
----
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;
{ callback for EnumWindows. }
function IEWindowEnumProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
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.
Source: Delphi Knowledge Base: http://www.baltsoft.com/
ID: 03512
== См. также ==
* Как взять URL из окна IE?
Category:Связь
Category:WebBrowser
Как получить hex-значение данного цвета?

GetRValue, GetGValue, GetBValue - дадут тебе байты цветов, затем тебе надо их перевести в hex...
Author: Vit
Source: http://forum.vingrad.ru
ID: 03668
----
IntToHex(Color);
Author: neutrino
Source: http://forum.vingrad.ru
ID: 03669
----
В модуле graphics имеются две недокументированные функции:
function ColorToString(Color: TColor): string;
Если значение TColor является именованным цветом, функция возвращает имя цвета ("clRed"). В противном случае возвращается шестнадцатиричное значение цвета в виде строки.
function StringToColor(S: string): TColor;
Данная функция преобразует "clRed" или "$0000FF" во внутреннее значение цвета.
Author: Pegas
Source: http://forum.vingrad.ru
ID: 03670
Category:Графика
Category:Цвета и палитры
Как получить более светлый или более тёмный цвет?

{
 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;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03690
== См. также ==
* Как сделать стандартные цвета в Delphi светлее или темнее
Category:Графика
Category:Цвета и палитры
Как получить версию моей DLL?

=== Как получить версию моей DLL? ===
procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer); 
var 
 Info: Pointer; 
 InfoSize: DWORD; 
 FileInfo: PVSFixedFileInfo; 
 FileInfoSize: DWORD; 
 Tmp: DWORD; 
begin 
 InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp); 
 if InfoSize = 0 then 
 //Файл не содержит информации о версии
 else 
 begin 
 GetMem(Info, InfoSize); 
 try 
 GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); 
 VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); 
 Major1 := FileInfo.dwFileVersionMS shr 16; 
 Major2 := FileInfo.dwFileVersionMS and $FFFF; 
 Minor1 := FileInfo.dwFileVersionLS shr 16; 
 Minor2 := FileInfo.dwFileVersionLS and $FFFF; 
 finally 
 FreeMem(Info, FileInfoSize); 
 end; 
 end; 
end;
Source: Взято из http://forum.sources.ru
ID: 01988
Как получить весь размер системной памяти?

=== Как получить весь размер системной памяти? ===
function GetMemoryTotalPhys(): DWord;
var
 memStatus: TMemoryStatus;
begin
 memStatus.dwLength := SizeOf(memStatus);
 GlobalMemoryStatus(memStatus);
 Result := memStatus.dwTotalPhys;
end;
Source: Взято из http://forum.sources.ru
ID: 02074
Как получить дату 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.
Source: Взято из http://forum.sources.ru
ID: 01357
----
var
 BiosDate: array[0..7] of char absolute
 $FFFF5;
 PCType: byte absolute $FFFFE;
procedure TForm1.FormCreate(Sender: TObject);
var
 S: string;
begin
 case PCType of
 $FC: S := 'AT';
 $FD: S := 'PCjr';
 $FE: S := 'XT =8-O';
 $FF: S := 'PC';
 else
 S := 'Нестандартный';
 end;
 Caption := 'Дата BIOS: ' + BiosDate + ' Тип ПК: ' + S;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 01358
----
function GetBiosDate1: String;
var
 Buffer : Array[0..8] Of Char;
 N : DWORD;
begin
 ReadProcessMemory(GetCurrentProcess,
 Ptr($FFFF5),
 @Buffer,
 8,
 N);
 Buffer[8] := #0;
 Result := StrPas(Buffer)
end;
function GetBiosDate2: String;
begin
 Result := string(PChar(ptr($FFFF5)));
end;
{ Only for Win 95/98/ME) }
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01359
----
{ получение даты BIOS в Win95 }
function GetBIOSDate: string;
var
 s: array[0..7] of char;
 p: pchar;
begin
 p := @s;
 asm
 push esi
 push edi
 push ecx
 mov esi,$0ffff5
 mov edi,p
 mov cx,8
 @@1:mov al,[esi]
 mov [edi],al
 inc edi
 inc esi
 loop @@1
 pop ecx
 pop edi
 pop esi
 end;
 SetString(Result, s, 8);
end;
Source: http://delphiworld.narod.ru/
ID: 01360
Как получить дату по Юлианскому календарю?

=== Как получить дату по Юлианскому календарю? ===
function julian(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;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 00197