nyuuzyou/wikis huggingface dataset:
Узнать о завершении работы Windows

=== Узнать о завершении работы Windows ===
Если текст в Memo1 был изменен, то программа не разрешает завершения сеанса Windows.
type
 TForm1 = class(TForm)
 private
 procedure WMQueryEndSession(var Msg: TWMQueryEndSession); message WM_QUERYENDSESSION;
 end;
implementation
procedure TForm1.WMQueryEndSession(var Msg: TWMQueryEndSession);
begin
 Msg.Result := Integer(not Memo1.Modified);
end;
 e-mail: delphi4all@narod.ru
 e-mail: aleksey@sch103.krasnoyarsk.su
Author: : Алексей Денисов
ID: 01673
----
Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна 
Используй GetMessage(), в качестве HWND окна пиши NULL (на Паскале - 0). Если в очереди сообщений следующее - WM_QUIT, то эта функция фозвращает FALSE. Если ты пишешь программу для Win32, то запихни это в отдельный поток, организующий выход из программы. 
Source: http://delphiworld.narod.ru/
ID: 01674
Узнать текущие время и дату по Гринвичу

=== Узнать текущие время и дату по Гринвичу ===
procedure TForm1.Button4Click(Sender: TObject);
var
 lt: TSYSTEMTIME;
 st: TSYSTEMTIME;
begin
 GetLocalTime(lt);
 GetSystemTime(st);
 Memo1.Lines.Add(Format('LocalTime = %d/%d/%d %d:%d:%d',
 [lt.wmonth, lt.wDay, lt.wYear, lt.wHour, lt.wMinute, lt.wSecond]);
 Memo1.Lines.Add(Format('UTCTime = %d/%d/%d %d:%d:%d',
 [st.wmonth, st.wDay, st.wYear, st.wHour, st.wMinute, st.wSecond]);
end;
Source: http://delphiworld.narod.ru
ID: 01649
Узнать текущую раскладку клавиатуры в любом активном окне

=== Узнать текущую раскладку клавиатуры в любом активном окне ===
 **** UBPFD *********** by delphibase.endimus.com ****
>> Узнать текущую раскладку клавиатуры в любом активном окне
возвращает числовое значение соответственно установленной раскладке
Зависимости: windows
Copyright: delphi help и немного усердия :-)
Дата: 4 декабря 2003 г.
***************************************************** }
if GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, nil)) = 67699721 then
 // раскладка английская
else
 // раскладка НЕанглийская, например 68748313 соответствует русской
Source: http://delphibase.endimus.com
ID: 01973
Указание языка помещенного в clipboard текста

=== Указание языка помещенного в clipboard текста ===
Столкнулся с проблемой вставки в Clipboard русского текста в Win2K, WinXP. Залез в DRKB.. Ну да, там вариант предложен довольно смешной (создать TRichEdit, вставить в него clipboard, весь текст пометить русским, и вернуть в clipboard)... Всё бы ничего, но если у меня программа без форм, да и без окон вообще, то TRichEdit не создаётся ('Control has no parent window') . Почитал хелп, посмотрел, что именно Вынь сует в буфер на разных языках, и нашёл простой и красивый способ. Имхо, ему там и место - в разделе "Буфер обмена".Для указания языка текста в clipboard используется специальный формат . Данные в этом формате - это . При вставке текста в формате CF_TEXT, или CF_OEMTEXT, нужно просто добавить в формате , после чего Windows сможет правильно преобразовать имеющийся текст в недостающие форматы (например в CF_UNICODETEXT), да и просто будет корректно вставлен в самом CF_TEXT.
Как вставить русский текст в буфер обмена Windows 2000, Windows
procedure CopyDataToClipboard(fmt: word; s: string);
var
 hg: THandle;
 P: PChar;
begin
 hg := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1);
 P := GlobalLock(hg);
 StrPCopy(P, s);
 GlobalUnlock(hg);
 Clipboard.Open;
 SetClipboardData(fmt, hg); // fmt = CF_UNICODETEXT | CF_OEMTEXT | CF_TEXT | CF_LOCALE
 Clipboard.Close;
 GlobalFree(hg);
end;
procedure CopyStringToClipboard(const s: string);
var Locale: word;
begin
 // Set CF_TEXT & CF_LOCALE
 CopyDataToClipboard(CF_TEXT, s);
 Locale := GetSystemDefaultLangID; // Get it as you please. even hard-coded ;) $0419 = LANG_RUSSIAN (f.e.)
 CopyDataToClipboard(CF_LOCALE, Chr(Lo(Locale))+Chr(Hi(Locale)));
end;
Author: Mechanic
Source: Взято из http://forum.sources.ru
ID: 01899
Указатель на вариантный тип

=== Указатель на вариантный тип ===
I just ran across this in some of my old code and thought Id share it with you:
Consider the following (simplified code): 
 function CreateVariantPtr(_Value: variant): pVariant;
 begin
 GetMem(Result, SizeOf(Variant));
 Result^ := _Value;
 end;
Seems pretty simple, doesnt it? Anybody who can spot the bug? I got spurious access violations in the line Result^ := _Value; Ok, the reason: Memory allocated with GetMem is not initialised, so the "Variant" pointed to by Result contains some random data, for example something that might represent a variant type which requires some finalisation when the variant is changed, lets say a variant array of some sort. But this finalisation wont work because the content is just some random garbage, and sometimes I was lucky (I mean that!) and got an access violation that allowed me to spot the error. The fix: 
 function CreateVariantPtr(_Value: variant): pVariant;
 begin
 GetMem(Result, SizeOf(Variant));
 Initialize(Result^);
 Result^ := _Value;
 end;
Language: en
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00833
Уменьшение мерцания ListBox в обработчике OwnerDraw

=== Уменьшение мерцания ListBox в обработчике OwnerDraw ===
Предположим ListBox имеет в своем списке два элемента, элемент 0 имеет фокус, активен другой компонент и вы щелкаете на элементе 1. При этом происходит *ПЯТИКРАТНЫЙ* вызов OnDrawItem, смотрите сами изменения состояний двух элементов: 
 Index State
 0 [odSelected, odFocused]
 0 [odSelected]
 0 []
 1 [odSelected]
 1 [odSelected, odFocused]
В случае единственного элемента в списке ListBox получается конфуз, поскольку при щелчке на нем вы получаете тот же самый сценарий, только вместо двух индексов присутствует один, нулевой. 
Имея эту информацию, вы можете минимизировать количество вызовов процедуры отрисовки. Для примера, в не-multi-select ListBox, элемент не нужно отрисовывать, если его состояние = [odSelected], поскольку это состояние всегда сопровождается НЕ selected НЕ focused, или ОДНОВРЕМЕННО selected и focused. В этом вам поможет технология отслеживания в обработчике OnDrawItem предыдущего отрисованного элемента, и если предыдущий запомненный элемент равен текущему, то отрисовывать его необязательно, например:
...
const 
 LastIndex: LongInt = -1;
begin
 IF Index = LastIndex THEN
 ...
 ELSE
 ...
 LastIndex := Index;
end;
Author: Neil 
Source: Взято с http://delphiworld.narod.ru
ID: 00664
Умножение больших целых чисел

type
 IntNo = record
 Low32, Hi32: DWORD;
 end;
 function Multiply(p, q: DWORD): IntNo;
 var
 x: IntNo;
 begin
 asm
 MOV EAX,[p]
 MUL [q]
 MOV [x.Low32],EAX
 MOV [x.Hi32],EDX
 end;
 Result := x
 end;
// Test the above with:
// So kannst du es testen
var
 r: IntNo;
 begin
 r := Multiply(40000000, 80000000);
 ShowMessage(IntToStr(r.Hi32) + ', ' + IntToStr(r.low32))
 end;
Source: http://www.swissdelphicenter.ch
ID: 04068
Category:Алгоритмы
Category:Математика
Универсальная функция возврата значения элемента даты

=== Универсальная функция возврата значения элемента даты ===
Универсальная функция возврата значения элемента даты (год, месяц, день, квартал):
function RetDate(inDate: TDateTime; inTip: integer): integer;
var
 xYear, xMonth, xDay: word;
begin
 Result := 0;
 DecodeDate(inDate, xYear, xMonth, xDay);
 case inTip of
 1: Result := xYear; // год
 2: Result := xMonth; // месяц
 3: Result := xDay; // день
 4: if xMonth < 4 then
 Result := 1
 else // квартал
 if xMonth < 7 then
 Result := 2
 else
 if xMonth < 10 then
 Result := 3
 else
 Result := 4;
 end;
end; 
Source: http://delphiworld.narod.ru
ID: 00762
Универсальные пароли к BIOS

=== Универсальные пароли к BIOS ===
 AWARD BIOS v2.50 
 ----------------
 AWARD_SW
 j262
 TTPTHA
 01322222
 KDD
 ZBAAACA
 aPAf
 lkwpeter
 t0ch88
 t0ch20x
 h6BB
 j09F
 TzqF
 AWARD BIOS v2.51 
 ----------------
 AWARD_WG
 j256
 BIOSTAR
 HLT
 ZAAADA
 Syxz
 ?award
 256256
 alfarome
 SWITCHES_SW
 Sxyz
 SZYX
 t0ch20x
 AWARD BIOS v2.51G
 -----------------
 g6PJ
 j322
 ZJAAADC
 Wodj
 bios*
 biosstar
 h6BB
 HELGA-S
 HEWITT
 RAND
 HLT
 t0ch88
 zjaaadc
 AWARD BIOS v2.51U 
 -----------------
 1EAAh
 condo
 biostar
 CONDO
 CONCAT
 djonet
 efmukl
 g6PJ
 j09F
 j64
 zbaaaca
 AWARD BIOS v4.5x 
 ----------------
 AWARD_SW
 AWARD_PW
 589589
 PASSWORD
 SKY_FOX
 AWARD SW
 award.sw
 AWARD?SW
 award_?
 award_ps
 ZAAADA
 AMI BIOS
 --------
 AMI 
 AMI_SW (не унивеpсальный но устанавливается пpи сбpосе CMOS/SETUP'a) 
 SER 
 Ctrl+Alt+Del+Ins (держать при загрузке, иногда просто INS) ;) 
 A.M.I. 
 aammii 
 ami.kez 
 ami° 
 amiami 
 AMI!SW 
 AMI.KEY 
 AMI?SW 
 AMISETUP 
 AMI~ 
 AMIPSWD 
 amipswd 
 helgaЯs 
 bios310 
 amidecod 
 BIOSPASS 
 CMOSPWD 
 HEWITT RAND 
 KILLCMOS 
 AMPTON BIOS 
 Polrty
 
 AST BIOS 
 SnuFG5
 
 BIOSTAR BIOS 
 Biostar 
 Q54arwms 
 
 COMPAQ BIOS 
 Compaq
 
 CONCORD BIOS 
 last
 
 CTX International BIOS 
 CTX_123
 
 CyberMax BIOS 
 Congress
 
 Daewoo BIOS 
 Daewuu
 
 Daytek BIOS 
 Daytec
 
 DELL BIOS 
 Dell
 
 Digital Equipment BIOS 
 komprie
 
 Enox BIOS 
 xo11nE
 
 Epox BIOS 
 central
 
 Freetech BIOS 
 Posterie
 
 HP Vectra BIOS 
 hewlpack
 
 IBM BIOS 
 IBM 
 
 MBIUO 
 sertafu 
 
 Iwill BIOS 
 iwill
 
 JetWay BIOS 
 spoom1
 
 Joss Technology BIOS 
 57gbz6 
 technolgi
 
 M Technology BIOS 
 mMmM
 
 MachSpeed BIOS 
 sp99dd
 
 Magic-Pro BIOS 
 prost
 
 Megastar BIOS 
 star
 
 Megastar BIOS 
 sldkj754 
 xyzall 
 
 Micronics BIOS 
 dn_04rjc
 
 Nimble BIOS 
 xdfk9874t3
 
 Packard Bell BIOS 
 bell9
 
 QDI BIOS 
 QDI
 
 Quantex BIOS 
 teX1 
 xljlbj
 
 Research BIOS 
 Col2ogro2
 
 Shuttle BIOS 
 Col2ogro2
 
 Siemens Nixdorf BIOS 
 SKY_FOX
 
 SpeedEasy BIOS 
 lesarot1
 
 SuperMicro BIOS 
 ksdjfg934t
 
 Tinys BIOS 
 tiny
 
 TMC BIOS 
 BIGO
 
 Toshiba BIOS 
 Toshiba 
 24Banc81 
 toshy99
 
 Vextrec Technology BIOS 
 Vextrex
 
 Vobis BIOS 
 merlin
 
 WIMBIOSnbsp v2.10 BIOS 
 Compleri
 
 Zenith BIOS 
 3098z 
 Zenith
 
 ZEOS BIOS 
 zeosx
[C] Faraon
Author: p0s0l
Source: http://wasm.ru
ID: 01366
Упорядочивание случайных чисел

{ **** UBPFD *********** by kladovka.net.ru ****
>> Упорядочивание случайных чисел
Как то спросил я у товарищей мастеров: «Как можно научить
Random не повторятся в определенном пределе?», ответ
был примерно таков (вернее два): «…сравнивать надо…»,
«…кто сказал, что числа не должны повторятся…». Так, что
получается либо они не знают, как это сделать, либо на
самом деле это невозможно без сравнения.
Тогда пришлось написать такую не большую "процедурку"
(см. ниже), заполнения массива случайными не повторяющимися числами.
Только здесь существует одно условие передаваемый в процедуру
массив должен быть таким, какой определен в процедуре или можно
написать две (или более) процедуры overload.
Если кто не знает, как сделать тоже вот пользуйтесь.
Зависимости: System, Windows
Автор: 16xmax, 16xmax@rambler.ru, Самара
Copyright: Кошеленко Дмитрий т.е. Я
Дата: 18 апреля 2004 г.
********************************************** }
type
 SortDir = (SU, SD, US); // типы сортировок: SU – возрастающая, SD – убывающая, US без сортировки
procedure Rnd(arr: array of Integer; sort: SortDir);
label 1; // метка возврата для регенерации числа
var
 i, j, l, m: Integer; // необходимые переменные
begin
 for i := Low(arr) to High(arr) do // цикл от первого значения до последнего массива
 begin
 1: // метка возврата
 Randomize; // холостой прогон генератора
 l := Random(High(arr)+1); // генерация числа от верхнего значения массива +1
 j := Low(arr); // присвоение счетчику сравнения минимального значения массива
 if i = Low(arr) then // если счетчик цикла равен первому значению тогда
 arr[i] := l // просто вносим его в массив
 else // иначе
 begin
 while j < i do // пока счетчик сравнения меньше счетчика цикла выполняем
 if l = arr[j] then // если сгенерированное число уже есть в массиве тогда
 goto 1 // возвращаемся к метке возврата
 else //иначе
 begin
 arr[i] := l; // вносим число в массив
 Inc(j); // увеличиваем счетчик сравнения на единицу
 end;
 end;
 end; 
 if sort = SU then // если переменная сортировки равна: по возрастающей тогда
 begin
 for i := Low(arr) to High(arr)-1 do // с первого значения до предпоследнего прогоняем массив
 for j := i+1 to High(arr) do // со второго значения до последнего прогоняем массив для сравнения и сортировки
 begin
 l := arr[i]; // присваиваем значение первое
 m := arr[j]; // присваиваем значение второе
 if l < m then
 begin
 arr[i] := m;
 arr[j] := l;
 end; // если первое меньше второго тогда меняем их местами
 end;
 end;
 if sort = SD then // если переменная сортировки равна: по возрастающей тогда
 begin
 for i := Low(arr) to High(arr)-1 do // с первого значения до предпоследнего прогоняем массив
 for j := i+1 to High(arr) do // со второго значения до последнего прогоняем массив для сравнения и сортировки
 begin
 l := arr[i]; // присваиваем значение первое
 m := arr[j]; // присваиваем значение второе
 if l > m then // если первое больше второго тогда меняем их местами
 begin
 arr[i] := m;
 arr[j] := l;
 end;
 end;
 end;
end;
Пример использования:
var
 c: array[0..255] of Integer;
begin
 Rnd(c, su);
end;
Author: 16xmax
ID: 04173
Category:Алгоритмы
Category:Сортировка
Управление Program Manager в Win95 с помощью DDE

Для управления программными группами в Program Manager с помощью DDE мною был использован следующий модуль. За основу был взят код Steve Texeira (sp) из руководства Dephi Developers Guide.
Работает под Win 3.1 и '95.
unit Pm;
interface
uses
 SysUtils, Classes, DdeMan;
type
 EProgManError = class(Exception);
 TProgMan = class(TComponent)
 private
 FDdeClientConv: TDdeClientConv;
 procedure InitDDEConversation;
 function ExecMacroString(Macro: string): Boolean;
 public
 constructor Create(AOwner: TComponent); override;
 destructor Destroy; override;
 procedure CreateGroup(GroupName: string; ShowGroup: Boolean);
 procedure DeleteGroup(GroupName: string);
 procedure DeleteItem(ItemName: string);
 procedure AddItem(CmdLine, ItemName: string);
 end;
implementation
uses Utils;
const
 { DDE-макростроки для Program Manager }
 SDDECreateGroup = '[CreateGroup(%s)]';
 SDDEShowGroup = '[ShowGroup(%s, 1)]';
 SDDEDeleteGroup = '[DeleteGroup(%s)]';
 SDDEDeleteItem = '[DeleteItem(%s)]';
 SDDEAddItem = '[AddItem(%s, "%s", %s)]';
constructor TProgMan.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 InitDDEConversation;
end;
destructor TProgMan.Destroy;
begin
 if Assigned(FDDEClientConv) then
 FDdeClientConv.CloseLink;
 inherited Destroy;
end;
function TProgMan.ExecMacroString(Macro: string): Boolean;
begin
 StringAsPchar(Macro);
 Result := FDdeClientConv.ExecuteMacro(@Macro[1], False);
end;
procedure TProgMan.InitDDEConversation;
begin
 FDdeClientConv := TDdeClientConv.Create(Self);
 if not FDdeClientConv.SetLink('PROGMAN', 'PROGMAN') then
 raise EProgManError.Create('Не могу установить DDE Link');
end;
procedure TProgMan.CreateGroup(GroupName: string; ShowGroup: Boolean);
begin
 { Удаляем группу, если она существует }
 ExecMacroString(Format(SDDEDeleteGroup, [GroupName]));
 if not ExecMacroString(Format(SDDECreateGroup, [GroupName])) then
 raise EProgManError.Create('Не могу создать группу ' + GroupName);
 if ShowGroup then
 if not ExecMacroString(Format(SDDEShowGroup, [GroupName])) then
 raise EProgManError.Create('Не могу показать группу ' + GroupName);
end;
procedure TProgMan.DeleteGroup(GroupName: string);
begin
 if not ExecMacroString(Format(SDDEDeleteGroup, [GroupName])) then
 raise EProgManError.Create('Не могу удалить группу ' + GroupName);
end;
procedure TProgMan.DeleteItem(ItemName: string);
begin
 if not ExecMacroString(Format(SDDEDeleteGroup, [ItemName])) then
 raise EProgManError.Create('Не могу удалить элемент ' + ItemName);
end;
procedure TProgMan.AddItem(CmdLine, ItemName: string);
var
 P: PChar;
 PSize: Word;
begin
 PSize := StrLen(SDDEAddItem) + (Length(CmdLine) * 2) + Length(ItemName) + 1;
 GetMem(P, PSize);
 try
 StrFmt(P, SDDEAddItem, [CmdLine, ItemName, CmdLine]);
 if not FDdeClientConv.ExecuteMacro(P, False) then
 raise EProgManError.Create('Не могу добавить элемент ' + ItemName);
 finally
 FreeMem(P, PSize);
 end;
end;
end.
Source: http://delphiworld.narod.ru/
ID: 04507
Category:DDE
Управление mIRC при помощи DDE

uses
 DdeMan;
procedure mIRCDDE(Service, Topic, Cmd: string);
var
 DDE: TDDEClientConv;
begin
 try
 DDE := TDDEClientConv.Create(nil);
 DDE.SetLink(Service, Topic);
 DDE.OpenLink;
 DDE.PokeData(Topic, PChar(Cmd));
 finally
 DDE.Free;
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 mIRCDDE('mIRC', 'COMMAND', '/say Hallo von SwissDelphiCenter.ch');
end;
Source: http://www.swissdelphicenter.ch
ID: 04508
Category:DDE
Управление настройками шрифта

=== Управление настройками шрифта ===
{
Данный код изменяет стиль шрифта поля редактирования, если оно выбрано. Может быть адаптирован для управления шрифтами в других объектах.
Расположите на форме Edit(Edit1) и ListBox(ListBox1).
Добавьте следующие элементы (Items) к ListBox:
 fsBold
 fsItalic
 fsUnderLine
 fsStrikeOut
}
procedure TForm1.ListBox1Click(Sender: TObject);
var
 X: Integer;
type
 TLookUpRec = record
 Name: string;
 Data: TFontStyle;
 end;
const
 LookUpTable: array[1..4] of TLookUpRec =
 ((Name: 'fsBold'; Data: fsBold),
 (Name: 'fsItalic'; Data: fsItalic),
 (Name: 'fsUnderline'; Data: fsUnderline),
 (Name: 'fsStrikeOut'; Data: fsStrikeOut));
begin
 X := ListBox1.ItemIndex;
 Edit1.Text := ListBox1.Items[X];
 Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex + 1].Data];
end;
Source: Взято с http://delphiworld.narod.ru
ID: 01936
Управление прокруткой Memo

=== Управление прокруткой Memo ===
У меня имеется компонент TMemo, и мне необходимо автоматически "тормозить" программным способом его прокрутку при добавлении новой строки Memo.Lines.Add(Строка). 
В Delphi 2.0 простая установка 'SelStart := 0' НЕ срабатывает. Это ошибка в коде VCL. Значения различных частей 'сообщения' windows, используемые для "set selection" (установления выбранной части текста) в WIN32 были изменены (это использовалось для 'автоматической' прокрутки каретки/курсора, но больше не работает). 
Попробуйте добавить следующую строку ПОСЛЕ 'SelStart := 0;':
SendMessage(Handle, EM_SCROLLCARET, 0, 0);
Это должно заставить компонент работать так, как вы и ожидаете. Я надеюсь что Borland знает об этой проблеме и скоро ее исправит. 
Здесь я должен пояснить, что ошибка как раз не в самом TMemo, а в TCustomEdit (в методе SetSelLength в stdctrls.pas). Поэтому данная проблема может наблюдаться во всех наследниках TCustomEdit (как TMemo).
Source: http://delphiworld.narod.ru/
ID: 01012
Управляющие коды принтера

Как мне послать на принтер управляющие коды принтера (Printer Control Codes) без перевода их в непечатные символы? Наверняка без Windows API в Delphi не обойтись.Когда я передаю управляющие коды принтера, они печатаются как непечатные символы, а не воспринимаются принтером как управляющие коды.
Вам нужно использовать Escape функцию принтера Passthrough, чтобы переслать данные непосредственно в принтер.В случае использования функции WriteLn это, конечно, не работает.Вот некоторый код, чтобы уговорить вас начать:
unit Passthru;
interface
uses printers, WinProcs, WinTypes, SysUtils;
procedure PrintTest;
implementation
type
 TPassThroughData = record
 nLen: Integer;
 Data: array[0..255] of Byte;
 end;
procedure DirectPrint(s: string);
var
 PTBlock: TPassThroughData;
begin
 PTBlock.nLen := Length(s);
 StrPCopy(@PTBlock.Data, s);
 Escape(Printer.Handle, PASSTHROUGH, 0, @PTBlock, nil);
end;
procedure PrintTest;
begin
 Printer.BeginDoc;
 DirectPrint(CHR(27) + '&l1O' + 'Привет, Вася!');
 Printer.EndDoc;
end;
end.
Source: Взято из Советов по Delphi от Валентина Озерова
ID: 03210
Category:Принтер
Ускорить удаление элементов из TListView

=== Ускорить удаление элементов из TListView ===
procedure AddNewListViewItems;
var
 oldViewStyle: TViewStyle;
begin
 odlViewStyle := ListView1.ViewStyle;
 ListView1.ViewStyle := vsList;
 ListView1.Items.Clear;
 { Add new Listitems here }
 { An dieser werden die neuen ListItems eingefugt }
 ListView1.ViewStyle := oldViewStyle;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01151
Условие создания главной формы

=== Условие создания главной формы ===
Существует ли в Delphi возможность создавать главную форму по условию? Я хочу использовать условие IF (в зависимости от передаваемого параметра) для того, чтобы определить какая форма будет главной при старте приложения. Фактически "другую" форму НЕ нужно будет загружать. 
Хитрость здесь заключается в том, что мы предоставляем компилятору весь необходимый для создания форм код, но не допускаем его выполнения (IF FALSE THEN), при этом компилятор не ругается, а мы тем временем (во время выполнения приложения) выбираем и создаем главную форму. Вот пример кода, измененный .DPR-файл, который при старте случайным образом выбирает из двух форм главную:
begin
 if FALSE then
 begin
 Application.CreateForm(TForm1, Form1);
 Application.CreateForm(TForm2, Form2);
 end;
 Randomize;
 if Random < 0.5 then
 Application.CreateForm(TForm1, Form1)
 else
 Application.CreateForm(TForm2, Form2);
 Application.Run;
end.
Пара "подходящих" для CreateForm форм заключено в никогда не выполнимый блок, тем самым приводя компилятор в состояние свинячего восторга.
Source: Взято с http://delphiworld.narod.ru
ID: 00441
Устанавливаем дату создания файла

=== Устанавливаем дату создания файла ===
function SetFileDate(const FileName: string; const FileDate: TDateTime): Boolean;
var
 FileHandle: THandle;
 FileSetDateResult: Integer;
begin
 try
 try
 FileHandle := FileOpen(FileName, fmOpenWrite OR fmShareDenyNone);
 if FileHandle > 0 then
 begin
 FileSetDateResult := FileSetDate(FileHandle, DateTimeToFileDate(FileDate));
 Result := (FileSetDateResult = 0);
 end;
 except
 Result := False;
 end;
 finally
 FileClose(FileHandle);
 end;
end;
{ Использование: }
SetFileDate('c:\mydir\myfile.ext', Now)
Source: http://delphiworld.narod.ru/
ID: 03150
----
var
 f: file;
begin
 Assign(f, DirInfo.Name);
 Reset(f);
 SetFTime(f, Time);
 Close(f);
end;
Source: http://delphiworld.narod.ru/
ID: 03151
----
Функция, которая устанавливает дату одного файла, равную дате другого файла 
procedure CopyFileDate(const Source, Dest: String);
var
 SourceHand, DestHand: word;
begin
 SourceHand := FileOpen(Source, fmOutput); { открываем исходный файл }
 DestHand := FileOpen(Dest, fmInput); { открываем целевой файл }
 FileSetDate(DestHand, FileGetDate(SourceHand)); { получаем/устанавливаем дату }
 FileClose(SourceHand); { закрываем исходный файл }
 FileClose(DestHand); { закрываем целевой файл }
end;
Source: http://delphiworld.narod.ru/
ID: 03152
Category:Файловая система
Установить звук для TMediaPlayer

=== Установить звук для TMediaPlayer ===
uses
 MPlayer, MMSystem;
const
 MCI_SETAUDIO = $0873;
 MCI_DGV_SETAUDIO_VOLUME = $4002;
 MCI_DGV_SETAUDIO_ITEM = $00800000;
 MCI_DGV_SETAUDIO_VALUE = $01000000;
 MCI_DGV_STATUS_VOLUME = $4019;
type
 MCI_DGV_SETAUDIO_PARMS = record
 dwCallback: DWORD;
 dwItem: DWORD;
 dwValue: DWORD;
 dwOver: DWORD;
 lpstrAlgorithm: PChar;
 lpstrQuality: PChar;
 end;
type
 MCI_STATUS_PARMS = record
 dwCallback: DWORD;
 dwReturn: DWORD;
 dwItem: DWORD;
 dwTrack: DWORD;
 end;
{ Volume: 0 - 1000 }
procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer);
var
 p: MCI_DGV_SETAUDIO_PARMS;
begin
 { Volume: 0 - 1000 }
 p.dwCallback := 0;
 p.dwItem := MCI_DGV_SETAUDIO_VOLUME;
 p.dwValue := Volume;
 p.dwOver := 0;
 p.lpstrAlgorithm := nil;
 p.lpstrQuality := nil;
 mciSendCommand(MP.DeviceID, MCI_SETAUDIO,
 MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p));
end;
function GetMPVolume(MP: TMediaPlayer): Integer;
var
 p: MCI_STATUS_PARMS;
begin
 p.dwCallback := 0;
 p.dwItem := MCI_DGV_STATUS_VOLUME;
 mciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p));
 Result := p.dwReturn;
 { Volume: 0 - 1000 }
end;
// Example, Beispiel: 
procedure TForm1.Button1Click(Sender: TObject);
begin
 SetMPVolume(MediaPlayer1, 500);
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01319
Установить размер шрифта для панели StatusBar

=== Установить размер шрифта для панели StatusBar ===
with StatusBar1.Panels[1] do
begin
 Text := Edit1.Text;
 Canvas.Font.Size := StatusBar1.Font.Size;
 Width := Canvas.TextWidth(Text) + 10;
end;
Source: http://delphiworld.narod.ru/
ID: 00957