500+ FAQ по Delphi

Перейти на: Главную | Индексную | Предыдущую | Следующую страницу


Как умертвить PC Speaker?

Это выключит спикеp:
SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);

Это включит:
SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);

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

function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string):
IPersistFile;
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
WideFile : WideString;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do
begin
SetPath(PChar(CmdLine));
SetArguments(PChar(Args));
SetWorkingDirectory(PChar(WorkDir));
end;
WideFile := LinkFile;
MyPFile.Save(PWChar(WideFile), False);
Result := MyPFile;
end;

procedure CreateShortcuts;
var Directory, ExecDir: String;
MyReg: TRegIniFile;
begin
MyReg := TRegIniFile.Create(
'Software\MicroSoft\Windows\CurrentVersion\Explorer');

ExecDir := ExtractFilePath(ParamStr(0));
Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' +
ProgramMenu;
CreateDir(Directory);
MyReg.Free;

CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir,
Directory + '\Demonstration.lnk');
CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir,
Directory + '\Installation notes.lnk');
CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir,
Directory + '\Install Intel Video Interactive.lnk');
end;

Разберешься?

Вообще правильнее в процедуре CreateShortcuts пользовать
Win32API::GetSpecialFolderLocation с нужным параметром
(CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае
"Рабочего стола").

Как по IP адресу получить HostName (и обратно).

Хм... А ты увеpен, что пытался найти эту функцию?
Ты, навеpно, будешь очень удивлен (так уж повелось в этой эхе), но это
gethostbyaddr, а если в Winsock2, то можно еще WSAAddressToString
Скачиваешь с microsoft или с intel WinSock2 SDK и документацию (она отдельно),
там все есть.

Мне лень сейчас вспоминать и pазбиpаться, вот тебе кусочек, в котоpом этим
функции используются (не пpетендую на абсолютную истину, но с IP pаботает):

function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;
const AddressStrMaxLen = 256;
var len : DWORD;
ptr : PChar;
pHE : PHostEnt;
addr : TSockAddr;
buf : Array [0..AddressStrMaxLen-1] of Char;
begin
if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is
not defined',WSAHOST_NOT_FOUND);
len := SizeOf(TSockAddr);
if getpeername(FSocket,addr,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');
case addr.sin_family of
AF_INET: // TCP/IP
begin
pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),
AF_INET );
if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:
gethostbyaddr()');
FPeerNodeName := pHE^.h_name;
if FNet.NodeByName(FPeerNodeName)=nil then
begin
ptr := StrScan(pHE^.h_name,'.');
if ptr<>nil then FPeerNodeName :=
Copy(pHE^.h_name,1,ptr-pHE^.h_name);
end;
end;
else
len := AddressStrMaxLen;
if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');
ptr := StrRScan(buf,':');
if ptr<>nil then len := ptr-buf;
FPeerNodeName := Copy(buf,1,len);
end;
Result :=
FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR
aiseError]);
end; {TGenericNetTask.GetPeerOrigin}

Есть ли у кого алгоритм переноса русского текста по слогам?

Вот, когда-то писал для QuarkXPress, который русских переносов не понимает. Hе
понимает сложные слова, но в 98% работает нормально.

{***********************************************************
* *
* Hypernation for QuarkQPress *
* written by Gorbunov A. A. *
* acdc@media-press.donetsk.ua *
* *
************************************************************}

unit Hyper;

interface

uses
Windows,Classes,SysUtils;

Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
Function SetHyphString(s : String):String;
Function MayBeHyph(p:PChar;pos:Integer):Boolean;

implementation


Type
TSymbol=(st_Empty,st_NoDefined,st_Glas,st_Sogl,st_Spec);
TSymbAR=array [0..1000] of TSymbol;
PSymbAr=^TSymbAr;

Const
HypSymb=#$1F;

Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ];

GlasCHAR=['є', 'L', 'х', '+', 'v', '-','р', '-', 'ю', '+', ' ', '-',
'ш', 'L', '¦', '¦', '¤', '¦',
{ english }
'e', 'E', 'u', 'U','i', 'I', 'o', 'O', 'a', 'A', 'j', 'J'
];

SoglChar=['Ў', 'г' , 'ъ', '¦' ,'э', '=' , 'у', '+' , '°', '+' , '•', '-' ,
'ч', '¦' , 'ї', '-' ,'Ї', 'L' , 'т', 'T' , 'я', '¦' , 'Ё', '¦' ,
'ы', 'T' , 'ф', '-' ,'ц', '¦' , 'ў', '+' , 'ё', 'T' , 'ь', '¦' ,
'Є', 'T' , 'с', '+' ,
{ english }
'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s',
'S',
'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z',
'Z',
'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ];

SpecSign= [ '·', '-','№', '-', 'щ', 'г'];

Function isSogl(c:Char):Boolean;
begin
Result:=c in SoglChar;
end;

Function isGlas(c:Char):Boolean;
begin
Result:=c in GlasChar;
end;

Function isSpecSign(c:Char):Boolean;
begin
Result:=c in SpecSign;
end;

Function GetSymbType(c:Char):TSymbol;
begin
if isSogl(c) then begin Result:=st_Sogl;exit;end;
if isGlas(c) then begin Result:=st_Glas;exit;end;
if isSpecSign(c) then begin Result:=st_Spec;exit;end;
Result:=st_NoDefined;
end;

Function isSlogMore(c:pSymbAr;start,len:Integer):Boolean;
var i:Integer;
glFlag:Boolean;
begin
glFlag:=false;
for i:=Start to Len-1 do
begin
if c^[i]=st_NoDefined then begin Result:=false;exit;end;
if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start))
then
begin
Result:=True;
exit;
end;
end;
Result:=false;
end;

{ ЁрёёЄрты ыър яхЁхэюёют }
Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
var
HypBuff : Pointer;
h : PSymbAr;
i : Integer;
len : Integer;
Cur : Integer; { Tхъє•р  яючшЎш  т Ёрчєы№ЄшЁє¦•хь ьрёёштх }
cw : Integer; { =юьхЁ сєътv т ёыютх }
Lock: Integer; { ёўхЄўшъ сыюъшЁютюъ }
begin
Cur:=0;
len := StrLen(pc);
if (MaxSize=0)OR(Len=0) then
begin
Result:=nil;
Exit;
end;

GetMem(HypBuff,MaxSize);
GetMem(h,Len+1);
{ чряюыэхэшх ьрёёштр Єшяют ёшьтюыют }
for i:=0 to len-1 do h^[i]:=GetSymbType(pc[i]);
{ ёюсёЄтхээю ЁрёёЄрэютър яхЁхэюёют }
cw:=0;
Lock:=0;
for i:=0 to Len-1 do
begin
PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur);

if i>=Len-2 then Continue;
if h^[i]=st_NoDefined then begin cw:=0;Continue;end else Inc(cw);
if Lock<>0 then begin Dec(Lock);Continue;end;
if cw<=1 then Continue;
if not(isSlogMore(h,i+1,len)) then Continue;


if
(h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and(h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec)
then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas)
then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl)
then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

if (h^[i]=st_Spec) then begin
PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1; end;

end;
{}
FreeMem(h,Len+1);
PChar(HypBuff)[cur]:=#0;
Result:=HypBuff;
end;

Function Red_GlasMore(p:Pchar;pos:Integer):Boolean;
begin
While p[pos]<>#0 do
begin
if p[pos] in Spaces then begin Result:=False; Exit; end;
if isGlas(p[pos]) then begin Result:=True; Exit; end;
Inc(pos);
end;
Result:=False;
end;

Function Red_SlogMore(p:Pchar;pos:Integer):Boolean;
Var BeSogl,BeGlas:Boolean;
begin
BeSogl:=False;
BeGlas:=False;
While p[pos]<>#0 do
begin
if p[pos] in Spaces then Break;
if Not BeGlas then BeGlas:=isGlas(p[pos]);
if Not BeSogl then BeSogl:=isSogl(p[pos]);
Inc(pos);
end;
Result:=BeGlas and BeSogl;
end;

Function MayBeHyph(p:PChar;pos:Integer):Boolean;
var i:Integer;
len:Integer;
begin
i:=pos;
Len:=StrLen(p);
Result:=
(Len>3)
AND
(i>2)
AND
(i<Len-2)
AND
(not (p[i] in Spaces))
AND
(not (p[i+1] in Spaces))
AND
(not (p[i-1] in Spaces))
AND
(
(isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and
Red_SlogMore(p,i+1))
OR
((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2])))
OR
((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and
Red_SlogMore(p,i+1) )
OR
((isSpecSign(p[i])))
);

end;

Function SetHyphString(s : String):String;
Var Res:PChar;
begin
Res:=SetHyph(PChar(S),Length(S)*2)
Result:=Res;
FreeMem(Res,Length(S)*2);
end;

end.

Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?

Под Windows 95 это возможно с использованием вспомогательных
инфоpмационных функций (tool help functions).
Для получения списка пpоцессов надо делать следующее:
1. Cпеpва вызывается фукция
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
// - получение снимка состояния системы
2. Process32First() - получене инфоpмации о пеpвом пpоцессе в списке
3. Далее в цикле Process32Next() - получение инфоpмации о следующем
пpоцессе в списке

Пример:

unit KernlUtl;

interface
uses TlHelp32, Windows, Classes, Sysutils;

procedure GetProcessList(List: TStrings);
procedure GetModuleList(List: TStrings);
function GetProcessHandle(ProcessID: DWORD): THandle;
procedure GetParentProcessInfo(var ID: DWORD; var Path: String);

const

PROCESS_TERMINATE = $0001;
PROCESS_CREATE_THREAD = $0002;
PROCESS_VM_OPERATION = $0008;
PROCESS_VM_READ = $0010;
PROCESS_VM_WRITE = $0020;
PROCESS_DUP_HANDLE = $0040;
PROCESS_CREATE_PROCESS = $0080;
PROCESS_SET_QUOTA = $0100;
PROCESS_SET_INFORMATION = $0200;
PROCESS_QUERY_INFORMATION = $0400;
PROCESS_ALL_ACCESS =
STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF;


implementation

procedure GetProcessList(List: TStrings);
var
I: Integer;
hSnapshoot: THandle;
pe32: TProcessEntry32;
begin
List.Clear;
hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

if (hSnapshoot = -1) then
Exit;
pe32.dwSize := SizeOf(TProcessEntry32);
if (Process32First(hSnapshoot, pe32)) then
repeat
I := List.Add(Format('%x, %x: %s',
[pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile]));
List.Objects[I] := Pointer(pe32.th32ProcessID);
until not Process32Next(hSnapshoot, pe32);

CloseHandle (hSnapshoot);
end;

procedure GetModuleList(List: TStrings);
var
I: Integer;
hSnapshoot: THandle;
me32: TModuleEntry32;
begin
List.Clear;
hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);
if (hSnapshoot = -1) then
Exit;
me32.dwSize := SizeOf(TModuleEntry32);
if (Module32First(hSnapshoot, me32)) then
repeat
I := List.Add(me32.szModule);
List.Objects[I] := Pointer(me32.th32ModuleID);
until not Module32Next(hSnapshoot, me32);

CloseHandle (hSnapshoot);
end;

procedure GetParentProcessInfo(var ID: DWORD; var Path: String);
var
ProcessID: DWORD;
hSnapshoot: THandle;
pe32: TProcessEntry32;
begin
ProcessID := GetCurrentProcessID;
ID := -1;
Path := '';

hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

if (hSnapshoot = -1) then
Exit;

pe32.dwSize := SizeOf(TProcessEntry32);
if (Process32First(hSnapshoot, pe32)) then
repeat
if pe32.th32ProcessID = ProcessID then
begin
ID := pe32.th32ParentProcessID;
Break;
end;
until not Process32Next(hSnapshoot, pe32);

if ID <> -1 then
begin
if (Process32First(hSnapshoot, pe32)) then
repeat
if pe32.th32ProcessID = ID then
begin
Path := pe32.szExeFile;
Break;
end;
until not Process32Next(hSnapshoot, pe32);
end;
CloseHandle (hSnapshoot);
end;

function GetProcessHandle(ProcessID: DWORD): THandle;
begin
Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);
end;

end.

Под Windows NT:
Исходный текст на языке Си.

#include <windows.h>

#include <stdio.h>

typedef long (*NtQSI)(LONG, PVOID,LONG, LONG);

struct ThreadInfo
{
FILETIME ftCreationTime;
DWORD dwUnknown1;
DWORD dwStartAddress;
DWORD dwOwningPID;
DWORD dwThreadID;
DWORD dwCurrentPriority;
DWORD dwBasePriority;
DWORD dwContextSwitches;
DWORD dwThreadState;
DWORD dwUnknown2;
DWORD dwUnknown3;
DWORD dwUnknown4;
DWORD dwUnknown5;
DWORD dwUnknown6;
DWORD dwUnknown7;
};

struct ProcessInfo
{
DWORD dwOffset; // an ofset to the next Process structure
DWORD dwThreadCount;
DWORD dwUnkown1[6];
FILETIME ftCreationTime;
DWORD dwUnkown2;
DWORD dwUnkown3;
DWORD dwUnkown4;
DWORD dwUnkown5;
DWORD dwUnkown6;
WCHAR* pszProcessName;
DWORD dwBasePriority;
DWORD dwProcessID;
DWORD dwParentProcessID;
DWORD dwHandleCount;
DWORD dwUnkown7;
DWORD dwUnkown8;
DWORD dwVirtualBytesPeak;
DWORD dwVirtualBytes;
DWORD dwPageFaults;
DWORD dwWorkingSetPeak;
DWORD dwWorkingSet;
DWORD dwUnkown9;
DWORD dwPagedPool; // kbytes
DWORD dwUnkown10;
DWORD dwNonPagedPool; // kbytes
DWORD dwPageFileBytesPeak;
DWORD dwPageFileBytes;
DWORD dwPrivateBytes;
DWORD dwUnkown11;
DWORD dwUnkown12;
DWORD dwUnkown13;
DWORD dwUnkown14;
struct ThreadInfo ati[1];
};


NtQSI ntqsi;
HANDLE h;
int i;
long j;
long tt;
char *vt; // UNICODE

struct ThreadInfo *tinfo, *tinf2;
struct ProcessInfo *pinfo;

char buf[20480];

void main()
{
h=LoadLibrary("NTDLL.DLL");
ntqsi = (NtQSI)GetProcAddress(h,"NtQuerySystemInformation");

j = (*ntqsi)(5,buf,20480,0);
pinfo = buf;

for(;;){
vt = pinfo->pszProcessName;
printf("%4lX|%13s|%8ld|%7lX|%7ld",
pinfo->dwProcessID,vt,
pinfo->dwThreadCount,pinfo->dwParentProcessID,
pinfo->dwOffset);
printf("|%4ld\n",pinfo->dwBasePriority);
printf("\t| ID|Owner|State|Priority|Base Priority\n");
tinfo = &pinfo->ati[0];

for(i=0;i<pinfo->dwThreadCount;++i){
tinf2 = &tinfo[i];
printf("\t|%4lX|%5lX|%5lX|%8s|%8s\n",
tinf2->dwThreadID,
tinf2->dwOwningPID,
tinf2->dwThreadState,
tinf2->dwCurrentPriority,
tinf2->dwBasePriority);
}
if(pinfo->dwOffset==0) break;
pinfo = (struct ProcessInfo*)((char *)pinfo + pinfo->dwOffset);
}
}


Материалы находятся на сайте http://cracklab.narod.ru/faq/


Создатель этого HTML файла не претендует на авторство вопросов/ответов представленных в нём, не отвечает за их содержание и достоверность, а также за последствия использования программных кодов , полученных из этого HTML файла. Также не принимаются претензии относительно не размещённой информации об авторе каждого конкретного FAQ'а. Любые другие вопросы присылайте на bad_guy@cracklab.ru (обращаться к Bad_guy'ю).
Hosted by uCoz